1 ;;; srfi-1.scm --- List Library
3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 2.1 of the License, or (at your option) any later version.
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
24 ;; This is an implementation of SRFI-1 (List Library).
26 ;; All procedures defined in SRFI-1, which are not already defined in
27 ;; the Guile core library, are exported. The procedures in this
28 ;; implementation work, but they have not been tuned for speed or
31 ;; This module is fully documented in the Guile Reference Manual.
35 (define-module (srfi srfi-1)
38 ;; cons <= in the core
39 ;; list <= in the core
41 ;; cons* <= in the core
42 ;; make-list <= in the core
52 ;; pair? <= in the core
53 ;; null? <= in the core
61 ;; caar <= in the core
62 ;; cadr <= in the core
63 ;; cdar <= in the core
64 ;; cddr <= in the core
65 ;; caaar <= in the core
66 ;; caadr <= in the core
67 ;; cadar <= in the core
68 ;; caddr <= in the core
69 ;; cdaar <= in the core
70 ;; cdadr <= in the core
71 ;; cddar <= in the core
72 ;; cdddr <= in the core
73 ;; caaaar <= in the core
74 ;; caaadr <= in the core
75 ;; caadar <= in the core
76 ;; caaddr <= in the core
77 ;; cadaar <= in the core
78 ;; cadadr <= in the core
79 ;; caddar <= in the core
80 ;; cadddr <= in the core
81 ;; cdaaar <= in the core
82 ;; cdaadr <= in the core
83 ;; cdadar <= in the core
84 ;; cdaddr <= in the core
85 ;; cddaar <= in the core
86 ;; cddadr <= in the core
87 ;; cdddar <= in the core
88 ;; cddddr <= in the core
89 ;; list-ref <= in the core
110 ;; last-pair <= in the core
112 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
113 ;; length <= in the core
115 ;; append <= in the core
116 ;; append! <= in the core
119 ;; reverse <= in the core
120 ;; reverse! <= in the core
131 ;;; Fold, unfold & map
141 ;; for-each ; Extended.
145 ;; map-in-order ; Extended.
149 ;;; Filtering & partitioning
150 ;; filter <= in the core
153 ;; filter! <= in the core
169 ;; list-index ; Extended.
170 ;; member ; Extended.
171 ;; memq <= in the core
172 ;; memv <= in the core
175 ;; delete ; Extended.
176 ;; delete! ; Extended.
180 ;;; Association lists
182 ;; assq <= in the core
183 ;; assv <= in the core
189 ;;; Set operations on lists
197 lset-diff+intersection
202 lset-diff+intersection!
204 ;;; Primitive side-effects
205 ;; set-car! <= in the core
206 ;; set-cdr! <= in the core
208 :re-export (cons list cons* make-list pair? null?
209 car cdr caar cadr cdar cddr
210 caaar caadr cadar caddr cdaar cdadr cddar cdddr
211 caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
212 cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
213 list-ref last-pair length append append! reverse reverse!
214 filter filter! memq memv assq assv set-car! set-cdr!)
215 :replace (iota map for-each map-in-order list-copy list-index member
216 delete delete! assoc)
219 (cond-expand-provide (current-module) '(srfi-1))
221 ;; Load the compiled primitives from the shared library.
223 (load-extension "libguile-srfi-srfi-1-v-3" "scm_init_srfi_1")
228 ;; internal helper, similar to (scsh utilities) check-arg.
229 (define (check-arg-type pred arg caller)
232 (scm-error 'wrong-type-arg caller
233 "Wrong type argument: ~S" (list arg) '())))
235 ;; the srfi spec doesn't seem to forbid inexact integers.
236 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
240 (define (circular-list elt1 . elts)
241 (set! elts (cons elt1 elts))
242 (set-cdr! (last-pair elts) elts)
245 (define (iota count . rest)
246 (check-arg-type non-negative-integer? count "iota")
247 (let ((start (if (pair? rest) (car rest) 0))
248 (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
249 (let lp ((n 0) (acc '()))
252 (lp (+ n 1) (cons (+ start (* n step)) acc))))))
256 (define (proper-list? x)
259 (define (circular-list? x)
262 (let lp ((hare (cdr x)) (tortoise x))
265 (let ((hare (cdr hare)))
268 (if (eq? hare tortoise)
270 (lp (cdr hare) (cdr tortoise)))))))))
272 (define (dotted-list? x)
277 (let lp ((hare (cdr x)) (tortoise x))
280 ((not-pair? hare) #t)
282 (let ((hare (cdr hare)))
285 ((not-pair? hare) #t)
286 ((eq? hare tortoise) #f)
288 (lp (cdr hare) (cdr tortoise)))))))))))
290 (define (null-list? x)
297 (error "not a proper list in null-list?"))))
299 (define (list= elt= . rest)
300 (define (lists-equal a b)
301 (let lp ((a a) (b b))
307 (and (elt= (car a) (car b))
308 (lp (cdr a) (cdr b)))))))
310 (let lp ((lists rest))
311 (or (null? (cdr lists))
312 (and (lists-equal (car lists) (cadr lists))
313 (lp (cdr lists)))))))
320 (define fourth cadddr)
322 (define take list-head)
323 (define drop list-tail)
325 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
327 (define (zip clist1 . rest)
328 (let lp ((l (cons clist1 rest)) (acc '()))
331 (lp (map1 cdr l) (cons (map1 car l) acc)))))
337 (values (map1 first l) (map1 second l)))
339 (values (map1 first l) (map1 second l) (map1 third l)))
341 (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
343 (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
346 ;;; Fold, unfold & map
348 (define (fold-right kons knil clist1 . rest)
350 (let f ((list1 clist1))
353 (kons (car list1) (f (cdr list1)))))
354 (let f ((lists (cons clist1 rest)))
355 (if (any null? lists)
357 (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
359 (define (pair-fold kons knil clist1 . rest)
361 (let f ((knil knil) (list1 clist1))
364 (let ((tail (cdr list1)))
365 (f (kons list1 knil) tail))))
366 (let f ((knil knil) (lists (cons clist1 rest)))
367 (if (any null? lists)
369 (let ((tails (map1 cdr lists)))
370 (f (apply kons (append! lists (list knil))) tails))))))
373 (define (pair-fold-right kons knil clist1 . rest)
375 (let f ((list1 clist1))
378 (kons list1 (f (cdr list1)))))
379 (let f ((lists (cons clist1 rest)))
380 (if (any null? lists)
382 (apply kons (append! lists (list (f (map1 cdr lists)))))))))
384 (define (unfold p f g seed . rest)
385 (let ((tail-gen (if (pair? rest)
386 (if (pair? (cdr rest))
387 (scm-error 'wrong-number-of-args
388 "unfold" "too many arguments" '() '())
391 (let uf ((seed seed))
397 (define (unfold-right p f g seed . rest)
398 (let ((tail (if (pair? rest)
399 (if (pair? (cdr rest))
400 (scm-error 'wrong-number-of-args
401 "unfold-right" "too many arguments" '()
405 (let uf ((seed seed) (lis tail))
408 (uf (g seed) (cons (f seed) lis))))))
411 ;; Internal helper procedure. Map `f' over the single list `ls'.
415 (define (append-map f clist1 . rest)
416 (concatenate (apply map f clist1 rest)))
418 (define (append-map! f clist1 . rest)
419 (concatenate! (apply map f clist1 rest)))
421 ;; OPTIMIZE-ME: Re-use cons cells of list1
424 (define (pair-for-each f clist1 . rest)
432 (let lp ((l (cons clist1 rest)))
437 (lp (map1 cdr l)))))))
441 (define (any pred ls . lists)
444 (let lp ((lists (cons ls lists)))
445 (cond ((any1 null? lists)
447 ((any1 null? (map1 cdr lists))
448 (apply pred (map1 car lists)))
450 (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
452 (define (any1 pred ls)
459 (or (pred (car ls)) (lp (cdr ls)))))))
461 (define (every pred ls . lists)
464 (let lp ((lists (cons ls lists)))
465 (cond ((any1 null? lists)
467 ((any1 null? (map1 cdr lists))
468 (apply pred (map1 car lists)))
470 (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
472 (define (every1 pred ls)
479 (and (pred (car ls)) (lp (cdr ls)))))))
481 ;;; Association lists
483 (define alist-cons acons)
485 (define (alist-delete key alist . rest)
486 (let ((k= (if (pair? rest) (car rest) equal?)))
487 (let lp ((a alist) (rl '()))
490 (if (k= key (caar a))
492 (lp (cdr a) (cons (car a) rl)))))))
494 (define (alist-delete! key alist . rest)
495 (let ((k= (if (pair? rest) (car rest) equal?)))
496 (alist-delete key alist k=))) ; XXX:optimize
498 ;;; Set operations on lists
500 (define (lset<= = . rest)
503 (let lp ((f (car rest)) (r (cdr rest)))
505 (and (every (lambda (el) (member el (car r) =)) f)
506 (lp (car r) (cdr r)))))))
508 (define (lset= = . rest)
511 (let lp ((f (car rest)) (r (cdr rest)))
513 (and (every (lambda (el) (member el (car r) =)) f)
514 (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
515 (lp (car r) (cdr r)))))))
517 (define (lset-union = . rest)
519 (for-each (lambda (lst)
522 (for-each (lambda (elem)
523 (if (not (member elem acc
524 (lambda (x y) (= y x))))
525 (set! acc (cons elem acc))))
530 (define (lset-intersection = list1 . rest)
531 (let lp ((l list1) (acc '()))
534 (if (every (lambda (ll) (member (car l) ll =)) rest)
535 (lp (cdr l) (cons (car l) acc))
538 (define (lset-difference = list1 . rest)
541 (let lp ((l list1) (acc '()))
544 (if (any (lambda (ll) (member (car l) ll =)) rest)
546 (lp (cdr l) (cons (car l) acc)))))))
548 ;(define (fold kons knil list1 . rest)
550 (define (lset-xor = . rest)
551 (fold (lambda (lst res)
552 (let lp ((l lst) (acc '()))
554 (let lp0 ((r res) (acc acc))
557 (if (member (car r) lst =)
559 (lp0 (cdr r) (cons (car r) acc)))))
560 (if (member (car l) res =)
562 (lp (cdr l) (cons (car l) acc))))))
566 (define (lset-diff+intersection = list1 . rest)
567 (let lp ((l list1) (accd '()) (acci '()))
569 (values (reverse! accd) (reverse! acci))
570 (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
572 (lp (cdr l) accd (cons (car l) acci))
573 (lp (cdr l) (cons (car l) accd) acci))))))
576 (define (lset-union! = . rest)
577 (apply lset-union = rest)) ; XXX:optimize
579 (define (lset-intersection! = list1 . rest)
580 (apply lset-intersection = list1 rest)) ; XXX:optimize
582 (define (lset-xor! = . rest)
583 (apply lset-xor = rest)) ; XXX:optimize
585 (define (lset-diff+intersection! = list1 . rest)
586 (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
588 ;;; srfi-1.scm ends here