1 ;;;; srfi-1.scm --- SRFI-1 procedures for Guile
3 ;;;; Copyright (C) 2001 Free Software Foundation, Inc.
5 ;;;; This program is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU General Public License as
7 ;;;; published by the Free Software Foundation; either version 2, or
8 ;;;; (at your option) any later version.
10 ;;;; This program 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 ;;;; General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with this software; see the file COPYING. If not, write to
17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 ;;;; Boston, MA 02111-1307 USA
20 ;;;; As a special exception, the Free Software Foundation gives permission
21 ;;;; for additional uses of the text contained in its release of GUILE.
23 ;;;; The exception is that, if you link the GUILE library with other files
24 ;;;; to produce an executable, this does not by itself cause the
25 ;;;; resulting executable to be covered by the GNU General Public License.
26 ;;;; Your use of that executable is in no way restricted on account of
27 ;;;; linking the GUILE library code into it.
29 ;;;; This exception does not however invalidate any other reasons why
30 ;;;; the executable file might be covered by the GNU General Public License.
32 ;;;; This exception applies only to the code released by the
33 ;;;; Free Software Foundation under the name GUILE. If you copy
34 ;;;; code from other Free Software Foundation releases into a copy of
35 ;;;; GUILE, as the General Public License permits, the exception does
36 ;;;; not apply to the code that you add in this way. To avoid misleading
37 ;;;; anyone as to the status of such modified files, you must delete
38 ;;;; this exception notice from them.
40 ;;;; If you write modifications of your own for GUILE, it is your choice
41 ;;;; whether to permit this exception to apply to your modifications.
42 ;;;; If you do not wish that, delete this exception notice.
44 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
49 ;;; This is an implementation of SRFI-1 (List Library)
51 ;;; All procedures defined in SRFI-1, which are not already defined in
52 ;;; the Guile core library, are exported. The procedures in this
53 ;;; implementation work, but they have not been tuned for speed or
59 (define-module (srfi srfi-1)
60 :use-module (ice-9 session)
61 :use-module (ice-9 receive))
65 ;; cons <= in the core
66 ;; list <= in the core
68 ;; cons* <= in the core
69 ;; make-list <= in the core
71 ;; list-copy <= in the core
79 ;; pair? <= in the core
80 ;; null? <= in the core
88 ;; caar <= in the core
89 ;; cadr <= in the core
90 ;; cdar <= in the core
91 ;; cddr <= in the core
92 ;; caaar <= in the core
93 ;; caadr <= in the core
94 ;; cadar <= in the core
95 ;; caddr <= in the core
96 ;; cdaar <= in the core
97 ;; cdadr <= in the core
98 ;; cddar <= in the core
99 ;; cdddr <= in the core
100 ;; caaaar <= in the core
101 ;; caaadr <= in the core
102 ;; caadar <= in the core
103 ;; caaddr <= in the core
104 ;; cadaar <= in the core
105 ;; cadadr <= in the core
106 ;; caddar <= in the core
107 ;; cadddr <= in the core
108 ;; cdaaar <= in the core
109 ;; cdaadr <= in the core
110 ;; cdadar <= in the core
111 ;; cdaddr <= in the core
112 ;; cddaar <= in the core
113 ;; cddadr <= in the core
114 ;; cdddar <= in the core
115 ;; cddddr <= in the core
116 ;; list-ref <= in the core
137 ;; last-pair <= in the core
139 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
140 ;; length <= in the core
142 ;; append <= in the core
143 ;; append! <= in the core
146 ;; reverse <= in the core
147 ;; reverse! <= in the core
158 ;;; Fold, unfold & map
172 map-in-order ; Extended.
176 ;;; Filtering & partitioning
196 list-index ; Extended.
198 ;; memq <= in the core
199 ;; memv <= in the core
207 ;;; Association lists
209 ;; assq <= in the core
210 ;; assv <= in the core
216 ;;; Set operations on lists
224 lset-diff+intersection
229 lset-diff+intersection!
231 ;;; Primitive side-effects
232 ;; set-car! <= in the core
233 ;; set-cdr! <= in the core
236 (cond-expand-provide (current-module) '(srfi-1))
243 ;; internal helper, similar to (scsh utilities) check-arg.
244 (define (check-arg-type pred arg caller)
247 (scm-error 'wrong-type-arg caller
248 "Wrong type argument: ~S" (list arg) '())))
250 ;; the srfi spec doesn't seem to forbid inexact integers.
251 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
253 (define (list-tabulate n init-proc)
254 (check-arg-type non-negative-integer? n "list-tabulate")
255 (let lp ((n n) (acc '()))
258 (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
260 (define (circular-list elt1 . rest)
261 (let ((start (cons elt1 '())))
262 (let lp ((r rest) (p start))
268 (set-cdr! p (cons (car r) '()))
269 (lp (cdr r) (cdr p)))))))
271 (define (iota count . rest)
272 (check-arg-type non-negative-integer? count "iota")
273 (let ((start (if (pair? rest) (car rest) 0))
274 (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
275 (let lp ((n 0) (acc '()))
278 (lp (+ n 1) (cons (+ start (* n step)) acc))))))
282 (define (proper-list? x)
285 (define (circular-list? x)
288 (let lp ((hare (cdr x)) (tortoise x))
291 (let ((hare (cdr hare)))
294 (if (eq? hare tortoise)
296 (lp (cdr hare) (cdr tortoise)))))))))
298 (define (dotted-list? x)
303 (let lp ((hare (cdr x)) (tortoise x))
306 ((not-pair? hare) #t)
308 (let ((hare (cdr hare)))
311 ((not-pair? hare) #t)
312 ((eq? hare tortoise) #f)
314 (lp (cdr hare) (cdr tortoise)))))))))))
316 (define (null-list? x)
323 (error "not a proper list in null-list?"))))
325 (define (not-pair? x)
328 (define (list= elt= . rest)
329 (define (lists-equal a b)
330 (let lp ((a a) (b b))
336 (and (elt= (car a) (car b))
337 (lp (cdr a) (cdr b)))))))
339 (let ((first (car rest)))
340 (let lp ((lists rest))
342 (and (lists-equal first (car lists))
343 (lp (cdr lists))))))))
350 (define fourth cadddr)
351 (define (fifth x) (car (cddddr x)))
352 (define (sixth x) (cadr (cddddr x)))
353 (define (seventh x) (caddr (cddddr x)))
354 (define (eighth x) (cadddr (cddddr x)))
355 (define (ninth x) (car (cddddr (cddddr x))))
356 (define (tenth x) (cadr (cddddr (cddddr x))))
358 (define (car+cdr x) (values (car x) (cdr x)))
361 (let lp ((n i) (l x) (acc '()))
364 (lp (- n 1) (cdr l) (cons (car l) acc)))))
366 (let lp ((n i) (l x))
369 (lp (- n 1) (cdr l)))))
370 (define (take-right flist i)
371 (let lp ((n i) (l flist))
373 (let lp0 ((s flist) (l l))
376 (lp0 (cdr s) (cdr l))))
377 (lp (- n 1) (cdr l)))))
379 (define (drop-right flist i)
380 (let lp ((n i) (l flist))
382 (let lp0 ((s flist) (l l) (acc '()))
385 (lp0 (cdr s) (cdr l) (cons (car s) acc))))
386 (lp (- n 1) (cdr l)))))
391 (let lp ((n (- i 1)) (l x))
396 (lp (- n 1) (cdr l))))))
398 (define (drop-right! flist i)
401 (let lp ((n (+ i 1)) (l flist))
403 (let lp0 ((s flist) (l l))
408 (lp0 (cdr s) (cdr l))))
411 (lp (- n 1) (cdr l)))))))
413 (define (split-at x i)
414 (let lp ((l x) (n i) (acc '()))
416 (values (reverse! acc) l)
417 (lp (cdr l) (- n 1) (cons (car l) acc)))))
419 (define (split-at! x i)
422 (let lp ((l x) (n (- i 1)))
427 (lp (cdr l) (- n 1))))))
430 (car (last-pair pair)))
432 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
434 (define (length+ clist)
437 (let lp ((hare (cdr clist)) (tortoise clist) (l 1))
440 (let ((hare (cdr hare)))
443 (if (eq? hare tortoise)
445 (lp (cdr hare) (cdr tortoise) (+ l 2)))))))))
447 (define (concatenate l-o-l)
448 (let lp ((l l-o-l) (acc '()))
451 (let lp0 ((ll (car l)) (acc acc))
454 (lp0 (cdr ll) (cons (car ll) acc)))))))
456 (define (concatenate! l-o-l)
457 (let lp0 ((l-o-l l-o-l))
464 (let ((result (car l-o-l)) (tail (last-pair (car l-o-l))))
465 (let lp ((l (cdr l-o-l)) (ntail tail))
469 (set-cdr! ntail (car l))
470 (lp (cdr l) (last-pair ntail))))))))))
473 (define (append-reverse rev-head tail)
474 (let lp ((l rev-head) (acc tail))
477 (lp (cdr l) (cons (car l) acc)))))
479 (define (append-reverse! rev-head tail)
480 (append-reverse rev-head tail)) ; XXX:optimize
482 (define (zip clist1 . rest)
483 (let lp ((l (cons clist1 rest)) (acc '()))
486 (lp (map1 cdr l) (cons (map1 car l) acc)))))
492 (values (map1 first l) (map1 second l)))
494 (values (map1 first l) (map1 second l) (map1 third l)))
496 (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
498 (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
501 (define (count pred clist1 . rest)
504 (let lp ((lists (cons clist1 rest)))
505 (cond ((any1 null? lists)
508 (if (apply pred (map1 car lists))
509 (+ 1 (lp (map1 cdr lists)))
510 (lp (map1 cdr lists))))))))
512 (define (count1 pred clist)
513 (let lp ((result 0) (rest clist))
516 (if (pred (car rest))
517 (lp (+ 1 result) (cdr rest))
518 (lp result (cdr rest))))))
520 ;;; Fold, unfold & map
522 (define (fold kons knil list1 . rest)
524 (let f ((knil knil) (list1 list1))
527 (f (kons (car list1) knil) (cdr list1))))
528 (let f ((knil knil) (lists (cons list1 rest)))
529 (if (any null? lists)
531 (let ((cars (map1 car lists))
532 (cdrs (map1 cdr lists)))
533 (f (apply kons (append! cars (list knil))) cdrs))))))
535 (define (fold-right kons knil clist1 . rest)
537 (let f ((list1 clist1))
540 (kons (car list1) (f (cdr list1)))))
541 (let f ((lists (cons clist1 rest)))
542 (if (any null? lists)
544 (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
546 (define (pair-fold kons knil clist1 . rest)
548 (let f ((knil knil) (list1 clist1))
551 (let ((tail (cdr list1)))
552 (f (kons list1 knil) tail))))
553 (let f ((knil knil) (lists (cons clist1 rest)))
554 (if (any null? lists)
556 (let ((tails (map1 cdr lists)))
557 (f (apply kons (append! lists (list knil))) tails))))))
560 (define (pair-fold-right kons knil clist1 . rest)
562 (let f ((list1 clist1))
565 (kons list1 (f (cdr list1)))))
566 (let f ((lists (cons clist1 rest)))
567 (if (any null? lists)
569 (apply kons (append! lists (list (f (map1 cdr lists)))))))))
571 (define (unfold p f g seed . rest)
572 (let ((tail-gen (if (pair? rest)
573 (if (pair? (cdr rest))
574 (scm-error 'wrong-number-of-args
575 "unfold" "too many arguments" '() '())
578 (let uf ((seed seed))
584 (define (unfold-right p f g seed . rest)
585 (let ((tail (if (pair? rest)
586 (if (pair? (cdr rest))
587 (scm-error 'wrong-number-of-args
588 "unfold-right" "too many arguments" '()
592 (let uf ((seed seed) (lis tail))
595 (uf (g seed) (cons (f seed) lis))))))
597 (define (reduce f ridentity lst)
598 (fold f ridentity lst))
600 (define (reduce-right f ridentity lst)
601 (fold-right f ridentity lst))
604 ;; Internal helper procedure. Map `f' over the single list `ls'.
609 (let ((ret (list (f (car ls)))))
610 (let lp ((ls (cdr ls)) (p ret)) ; tail pointer
614 (set-cdr! p (list (f (car ls))))
615 (lp (cdr ls) (cdr p))))))))
617 ;; This `map' is extended from the standard `map'. It allows argument
618 ;; lists of different length, so that the shortest list determines the
619 ;; number of elements processed.
621 (define (map f list1 . rest)
624 (let lp ((l (cons list1 rest)))
627 (cons (apply f (map1 car l)) (lp (map1 cdr l)))))))
629 ;; extended to lists of unequal length.
630 (define map-in-order map)
632 ;; This `for-each' is extended from the standard `for-each'. It
633 ;; allows argument lists of different length, so that the shortest
634 ;; list determines the number of elements processed.
636 (define (for-each f list1 . rest)
640 (if #f #f) ; Return unspecified value.
644 (let lp ((l (cons list1 rest)))
648 (apply f (map1 car l))
649 (lp (map1 cdr l)))))))
652 (define (append-map f clist1 . rest)
657 (append (f (car l)) (lp (cdr l)))))
658 (let lp ((l (cons clist1 rest)))
661 (append (apply f (map1 car l)) (lp (map1 cdr l)))))))
664 (define (append-map! f clist1 . rest)
669 (append! (f (car l)) (lp (cdr l)))))
670 (let lp ((l (cons clist1 rest)))
673 (append! (apply f (map1 car l)) (lp (map1 cdr l)))))))
675 (define (map! f list1 . rest)
681 (set-car! l (f (car l)))
682 (set-cdr! l (lp (cdr l)))
684 (let lp ((l (cons list1 rest)) (res list1))
688 (set-car! res (apply f (map1 car l)))
689 (set-cdr! res (lp (map1 cdr l) (cdr res)))
692 (define (pair-for-each f clist1 . rest)
700 (let lp ((l (cons clist1 rest)))
705 (lp (map1 cdr l)))))))
707 (define (filter-map f clist1 . rest)
712 (let ((res (f (car l))))
714 (cons res (lp (cdr l)))
716 (let lp ((l (cons clist1 rest)))
719 (let ((res (apply f (map1 car l))))
721 (cons res (lp (map1 cdr l)))
722 (lp (map1 cdr l))))))))
724 ;;; Filtering & partitioning
726 (define (filter pred list)
727 (check-arg-type list? list "filter") ; reject circular lists.
728 (letrec ((filiter (lambda (pred rest result)
731 (filiter pred (cdr rest)
732 (cond ((pred (car rest))
733 (cons (car rest) result))
736 (filiter pred list '())))
738 (define (partition pred list)
741 (if (pred (car list))
742 (receive (in out) (partition pred (cdr list))
743 (values (cons (car list) in) out))
744 (receive (in out) (partition pred (cdr list))
745 (values in (cons (car list) out))))))
747 (define (remove pred list)
748 (filter (lambda (x) (not (pred x))) list))
750 (define (filter! pred list)
751 (filter pred list)) ; XXX:optimize
753 (define (partition! pred list)
754 (partition pred list)) ; XXX:optimize
756 (define (remove! pred list)
757 (remove pred list)) ; XXX:optimize
761 (define (find pred clist)
764 (if (pred (car clist))
766 (find pred (cdr clist)))))
768 (define (find-tail pred clist)
771 (if (pred (car clist))
773 (find-tail pred (cdr clist)))))
775 (define (take-while pred ls)
776 (cond ((null? ls) '())
777 ((not (pred (car ls))) '())
779 (let ((result (list (car ls))))
780 (let lp ((ls (cdr ls)) (p result))
781 (cond ((null? ls) result)
782 ((not (pred (car ls))) result)
784 (set-cdr! p (list (car ls)))
785 (lp (cdr ls) (cdr p)))))))))
787 (define (take-while! pred clist)
788 (take-while pred clist)) ; XXX:optimize
790 (define (drop-while pred clist)
793 (if (pred (car clist))
794 (drop-while pred (cdr clist))
797 (define (span pred clist)
800 (if (pred (car clist))
801 (receive (first last) (span pred (cdr clist))
802 (values (cons (car clist) first) last))
803 (values '() clist))))
805 (define (span! pred list)
806 (span pred list)) ; XXX:optimize
808 (define (break pred clist)
811 (if (pred (car clist))
813 (receive (first last) (break pred (cdr clist))
814 (values (cons (car clist) first) last)))))
816 (define (break! pred list)
817 (break pred list)) ; XXX:optimize
819 (define (any pred ls . lists)
822 (let lp ((lists (cons ls lists)))
823 (cond ((any1 null? lists)
825 ((any1 null? (map1 cdr lists))
826 (apply pred (map1 car lists)))
828 (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
830 (define (any1 pred ls)
837 (or (pred (car ls)) (lp (cdr ls)))))))
839 (define (every pred ls . lists)
842 (let lp ((lists (cons ls lists)))
843 (cond ((any1 null? lists)
845 ((any1 null? (map1 cdr lists))
846 (apply pred (map1 car lists)))
848 (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
850 (define (every1 pred ls)
857 (and (pred (car ls)) (lp (cdr ls)))))))
859 (define (list-index pred clist1 . rest)
861 (let lp ((l clist1) (i 0))
866 (lp (cdr l) (+ i 1)))))
867 (let lp ((lists (cons clist1 rest)) (i 0))
868 (cond ((any1 null? lists)
870 ((apply pred (map1 car lists)) i)
872 (lp (map1 cdr lists) (+ i 1)))))))
874 (define (member x list . rest)
875 (let ((l= (if (pair? rest) (car rest) equal?)))
885 (define (delete x list . rest)
886 (let ((l= (if (pair? rest) (car rest) equal?)))
892 (cons (car l) (lp (cdr l))))))))
894 (define (delete! x list . rest)
895 (let ((l= (if (pair? rest) (car rest) equal?)))
896 (delete x list l=))) ; XXX:optimize
898 (define (delete-duplicates list . rest)
899 (let ((l= (if (pair? rest) (car rest) equal?)))
903 (if (let lp1 ((l2 (cdr l1)))
906 (if (l= (car l1) (car l2))
910 (cons (car l1) (lp0 (cdr l1))))))))
912 (define (delete-duplicates list . rest)
913 (let ((l= (if (pair? rest) (car rest) equal?)))
914 (let lp ((list list))
917 (cons (car list) (lp (delete (car list) (cdr list) l=)))))))
919 (define (delete-duplicates! list . rest)
920 (let ((l= (if (pair? rest) (car rest) equal?)))
921 (delete-duplicates list l=))) ; XXX:optimize
923 ;;; Association lists
925 (define (assoc key alist . rest)
926 (let ((k= (if (pair? rest) (car rest) equal?)))
930 (if (k= key (caar a))
934 (define (alist-cons key datum alist)
935 (acons key datum alist))
937 (define (alist-copy alist)
941 (acons (caar a) (cdar a) (lp (cdr a))))))
943 (define (alist-delete key alist . rest)
944 (let ((k= (if (pair? rest) (car rest) equal?)))
948 (if (k= (caar a) key)
950 (cons (car a) (lp (cdr a))))))))
952 (define (alist-delete! key alist . rest)
953 (let ((k= (if (pair? rest) (car rest) equal?)))
954 (alist-delete key alist k=))) ; XXX:optimize
956 ;;; Set operations on lists
958 (define (lset<= = . rest)
961 (let lp ((f (car rest)) (r (cdr rest)))
963 (and (every (lambda (el) (member el (car r) =)) f)
964 (lp (car r) (cdr r)))))))
966 (define (lset= = list1 . rest)
969 (let lp ((f list1) (r rest))
971 (and (every (lambda (el) (member el (car r) =)) f)
972 (every (lambda (el) (member el f =)) (car r))
973 (lp (car r) (cdr r)))))))
975 (define (lset-adjoin = list . rest)
976 (let lp ((l rest) (acc list))
979 (if (member (car l) acc)
981 (lp (cdr l) (cons (car l) acc))))))
983 (define (lset-union = . rest)
984 (let lp0 ((l rest) (acc '()))
987 (let lp1 ((ll (car l)) (acc acc))
990 (if (member (car ll) acc =)
992 (lp1 (cdr ll) (cons (car ll) acc))))))))
994 (define (lset-intersection = list1 . rest)
995 (let lp ((l list1) (acc '()))
998 (if (every (lambda (ll) (member (car l) ll =)) rest)
999 (lp (cdr l) (cons (car l) acc))
1000 (lp (cdr l) acc)))))
1002 (define (lset-difference = list1 . rest)
1005 (let lp ((l list1) (acc '()))
1008 (if (any (lambda (ll) (member (car l) ll =)) rest)
1010 (lp (cdr l) (cons (car l) acc)))))))
1012 ;(define (fold kons knil list1 . rest)
1014 (define (lset-xor = . rest)
1015 (fold (lambda (lst res)
1016 (let lp ((l lst) (acc '()))
1018 (let lp0 ((r res) (acc acc))
1021 (if (member (car r) lst =)
1023 (lp0 (cdr r) (cons (car r) acc)))))
1024 (if (member (car l) res =)
1026 (lp (cdr l) (cons (car l) acc))))))
1030 (define (lset-diff+intersection = list1 . rest)
1031 (let lp ((l list1) (accd '()) (acci '()))
1033 (values (reverse! accd) (reverse! acci))
1034 (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
1036 (lp (cdr l) accd (cons (car l) acci))
1037 (lp (cdr l) (cons (car l) accd) acci))))))
1040 (define (lset-union! = . rest)
1041 (apply lset-union = rest)) ; XXX:optimize
1043 (define (lset-intersection! = list1 . rest)
1044 (apply lset-intersection = list1 rest)) ; XXX:optimize
1046 (define (lset-difference! = list1 . rest)
1047 (apply lset-difference = list1 rest)) ; XXX:optimize
1049 (define (lset-xor! = . rest)
1050 (apply lset-xor = rest)) ; XXX:optimize
1052 (define (lset-diff+intersection! = list1 . rest)
1053 (apply lset-diff+intersection = list1 rest)) ; XXX:optimize