summaryrefslogtreecommitdiffstats
path: root/srfi-1.scm
diff options
context:
space:
mode:
Diffstat (limited to 'srfi-1.scm')
-rw-r--r--srfi-1.scm382
1 files changed, 284 insertions, 98 deletions
diff --git a/srfi-1.scm b/srfi-1.scm
index d0f436f..c479491 100644
--- a/srfi-1.scm
+++ b/srfi-1.scm
@@ -1,6 +1,7 @@
;;; "srfi-1.scm" SRFI-1 list-processing library -*-scheme-*-
;; Copyright 2001 Aubrey Jaffer
;; Copyright 2003 Sven Hartrumpf
+;; Copyright 2003-2004 Lars Buitinck
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -38,11 +39,13 @@
;;@subheading Constructors
-;;@body @code{(define (xcons d a) (cons a d))}.
+;;@body
+;; @code{(define (xcons d a) (cons a d))}.
(define (xcons d a) (cons a d))
-;;@body Returns a list of length @1. Element @var{i} is @code{(@2
-;;@var{i})} for 0 <= @var{i} < @1.
+;;@body
+;; Returns a list of length @1. Element @var{i} is
+;;@code{(@2 @var{i})} for 0 <= @var{i} < @1.
(define (list-tabulate len proc)
(do ((i (- len 1) (- i 1))
(ans '() (cons (proc i) ans)))
@@ -122,23 +125,24 @@
(define third caddr)
;;@args pair
(define fourth cadddr)
-;;@args pair
-(define (fifth obj) (car (cddddr obj)))
-(define (sixth obj) (cadr (cddddr obj)))
-(define (seventh obj) (caddr (cddddr obj)))
-(define (eighth obj) (cadddr (cddddr obj)))
-(define (ninth obj) (car (cddddr (cddddr obj))))
-(define (tenth obj) (cadr (cddddr (cddddr obj))))
+;;@body
+(define (fifth pair) (car (cddddr pair)))
+(define (sixth pair) (cadr (cddddr pair)))
+(define (seventh pair) (caddr (cddddr pair)))
+(define (eighth pair) (cadddr (cddddr pair)))
+(define (ninth pair) (car (cddddr (cddddr pair))))
+(define (tenth pair) (cadr (cddddr (cddddr pair))))
;;@body
(define (car+cdr pair) (values (car pair) (cdr pair)))
-;;@body
+;;@args lst k
(define (drop lst k) (nthcdr k lst))
(define (take lst k) (butnthcdr k lst))
-;;@args lst k
-(define take! take)
-
+(define (take! lst k)
+ (if (or (null? lst) (<= k 0))
+ '()
+ (begin (set-cdr! (drop (- k 1) lst) '()) lst)))
;;@args lst k
(define take-right last)
;;@args lst k
@@ -146,13 +150,21 @@
;;@args lst k
(define drop-right! drop-right)
-;;@args lst k
-(define (split-at lst k) (values (take lst k) (drop lst k)))
-;;@args lst k
-(define split-at! split-at)
+;;@body
+(define (split-at lst k)
+ (let loop ((l '()) (r lst) (k k))
+ (if (or (null? r) (= k 0))
+ (values (reverse! l) r)
+ (loop (cons (car r) l) (cdr r) (- k 1)))))
+(define (split-at! lst k)
+ (if (= k 0)
+ (values '() lst)
+ (let* ((half (drop lst (- k 1)))
+ (r (cdr half)))
+ (set-cdr! half '())
+ (values lst r))))
-;;@args lst
-;;(car (last-pair lst))
+;;@body
(define (last lst . k)
(if (null? k)
(car (last-pair lst))
@@ -161,7 +173,7 @@
;;@subheading Miscellaneous
;;@body
-(define (length+ obj) (and (list? obj) (length obj)))
+(define (length+ clist) (and (list? clist) (length clist)))
;;Append and append! are provided by R4RS and rev2-procedures.
@@ -214,42 +226,83 @@
;;@subheading Fold and Unfold
+;;@args kons knil clist1 clist2 ...
+(define (fold f z l1 . l)
+ (set! l (cons l1 l))
+ (if (any null? l)
+ z
+ (apply fold (cons* f (apply f (append! (map car l) (list z)))
+ (map cdr l)))))
+;;@args kons knil clist1 clist2 ...
+(define (fold-right f z l1 . l)
+ (set! l (cons l1 l))
+ (if (any null? l)
+ z
+ (apply f (append! (map car l)
+ (list (apply fold-right (cons* f z (map cdr l))))))))
+;;@args kons knil clist1 clist2 ...
+(define (pair-fold f z l) ;XXX should be multi-arg
+ (if (null? l)
+ z
+ (let ((tail (cdr l)))
+ (pair-fold f (f l z) tail))))
+;;@args kons knil clist1 clist2 ...
+(define (pair-fold-right f z l) ;XXX should be multi-arg
+ (if (null? l)
+ z
+ (f l (pair-fold-right f z (cdr l)))))
-;;; We stop when LIS1 runs out, not when any list runs out.
-;;@args f list1 clist2 ...
-(define (map! f lis1 . lists)
+;;@body
+(define (reduce f ridentity list)
+ (if (null? list) ridentity (fold f (car list) (cdr list))))
+(define (reduce-right f ridentity list)
+ (if (null? list)
+ ridentity
+ (let red ((l (cdr list)) (ridentity (car list)))
+ (if (null? list)
+ ridentity
+ (f ridentity (red (cdr list) (car list)))))))
+
+;;; We stop when CLIST1 runs out, not when any list runs out.
+;;@args f clist1 clist2 ...
+(define (map! f clist1 . lists)
(if (pair? lists)
- (let lp ((lis1 lis1) (lists lists))
- (if (not (null-list? lis1))
+ (let lp ((clist1 clist1) (lists lists))
+ (if (not (null-list? clist1))
(call-with-values ; expanded a receive call
(lambda () (%cars+cdrs/no-test lists))
(lambda (heads tails)
- (set-car! lis1 (apply f (car lis1) heads))
- (lp (cdr lis1) tails)))))
-
+ (set-car! clist1 (apply f (car clist1) heads))
+ (lp (cdr clist1) tails)))))
;; Fast path.
- (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
- lis1)
-
+ (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) clist1))
+ clist1)
;;@args f clist1 clist2 ...
-(define (pair-for-each proc lis1 . lists)
+(define (pair-for-each proc clist1 . lists)
(if (pair? lists)
- (let lp ((lists (cons lis1 lists)))
+ (let lp ((lists (cons clist1 lists)))
(let ((tails (%cdrs lists)))
(if (pair? tails)
(begin (apply proc lists)
(lp tails)))))
;; Fast path.
- (let lp ((lis lis1))
+ (let lp ((lis clist1))
(if (not (null-list? lis))
(let ((tail (cdr lis))) ; Grab the cdr now,
(proc lis) ; in case PROC SET-CDR!s LIS.
(lp tail))))))
+(define (filter-map f l1 . l)
+ (let loop ((l (cons l1 l)) (r '()))
+ (if (any null? l)
+ (reverse! r)
+ (let ((x (apply f (map car l))))
+ (loop (map! cdr l) (if x (cons x r) r))))))
+
;;@subheading Filtering and Partitioning
-;;@body
+;;@args pred list
(define (filter pred lis) ; Sleazing with EQ? makes this one faster.
(let recur ((lis lis))
(if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists.
@@ -260,32 +313,10 @@
(if (eq? tail new-tail) lis
(cons head new-tail)))
(recur tail)))))) ; this one can be a tail call.
-;;@body
-(define (filter! pred l)
- (if (null? l)
- l
- (let ((l2 l)
- (l3 (cdr l)))
- (do ((end #f)
- (result '()))
- (end result)
- (cond ((pred (car l2)) ; keep the first element of l2
- (cond ((null? result)
- (set! result l2))) ; first pair of remaining elements
- (cond ((pair? l3)
- (set! l2 l3)
- (set! l3 (cdr l2)))
- (else
- (set! end #t))))
- (else ; remove the first element of l2
- (cond ((pair? l3)
- (set-car! l2 (car l3))
- (set! l3 (cdr l3))
- (set-cdr! l2 l3))
- (else
- (cond ((pair? result)
- (list-remove-last! result)))
- (set! end #t)))))))))
+;;@args pred list
+(define (filter! p? l)
+ (call-with-values (lambda () (partition! p? l))
+ (lambda (x y) x)))
;;@args pred list
(define (partition pred lis)
@@ -300,24 +331,61 @@
(values (if (pair? out) (cons elt in) lis) out)
(values in (if (pair? in) (cons elt out) lis)))))))))
-;;@subheading Searching
-
;;@args pred list
-(define find find-if)
-
-;;@args pred list
-(define find-tail member-if)
-
-;;@body
(define remove
(let ((comlist:remove remove))
(lambda (pred l)
(if (procedure? pred)
(filter (lambda (x) (not (pred x))) l)
(comlist:remove pred l))))) ; 'remove' has incompatible semantics in comlist of SLIB!
-;;@body
+
+;;@args pred list
+(define (partition! p? l)
+ (if (null? l)
+ (values l l)
+ (let ((p-ptr (cons '*unused* l)) (not-ptr (cons '*unused* l)))
+ (let loop ((l l) (p-prev p-ptr) (not-prev not-ptr))
+ (cond ((null? l) (values (cdr p-ptr) (cdr not-ptr)))
+ ((p? (car l)) (begin (set-cdr! not-prev (cdr l))
+ (loop (cdr l) l not-prev)))
+ (else (begin (set-cdr! p-prev (cdr l))
+ (loop (cdr l) p-prev l))))))))
+
+;;@args pred list
(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+
+;;@subheading Searching
+
+;;@args pred clist
+(define find find-if)
+;;@args pred clist
+(define find-tail member-if)
+
+;;@args pred list
+(define (span pred lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values '() '())
+ (let ((x (car lis)))
+ (if (pred x)
+ (call-with-values ; eliminated a receive call
+ (lambda () (recur (cdr lis)))
+ (lambda (prefix suffix)
+ (values (cons x prefix) suffix)))
+ (values '() lis))))))
+
+;;@args pred list
+(define (span! p? lst)
+ (let loop ((l lst) (prev (cons '*unused* lst)))
+ (cond ((null? l) (values lst '()))
+ ((p? (car l)) (loop (cdr l) l))
+ (else (begin (set-cdr! prev '()) (values lst l))))))
+
+;;@args pred list
+(define (break p? l) (span (lambda (x) (not (p? x))) l))
+;;@args pred list
+(define (break! p? l) (span! (lambda (x) (not (p? x))) l))
+
;;@args pred clist1 clist2 ...
(define (any pred lis1 . lists)
(if (pair? lists)
@@ -339,7 +407,6 @@
(if (null-list? tail)
(pred head) ; Last PRED app is tail call.
(or (pred head) (lp (car tail) (cdr tail))))))))
-
;;@args pred clist1 clist2 ...
(define (list-index pred lis1 . lists)
(if (pair? lists)
@@ -356,27 +423,8 @@
(and (not (null-list? lis))
(if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
-;;@args pred list
-(define (span pred lis)
- (let recur ((lis lis))
- (if (null-list? lis) (values '() '())
- (let ((x (car lis)))
- (if (pred x)
- (call-with-values ; eliminated a receive call
- (lambda () (recur (cdr lis)))
- (lambda (prefix suffix)
- (values (cons x prefix) suffix)))
- (values '() lis))))))
-
-;;@args obj list pred
+;;@args obj list =
;;@args obj list
-;;
-;;@0 returns the first sublist of @2 whose car is @1, where the sublists
-;;of @2 are the non-empty lists returned by @t{(list-tail @2 @var{k})}
-;;for @var{k} less than the length of @2. If @1 does not occur in @2,
-;;then @t{#f} (not the empty list) is returned. The procedure @3 is
-;;used for testing equality. If @3 is not provided, @samp{equal?} is
-;;used.
(define member
(let ((old-member member))
(lambda (obj list . pred)
@@ -387,16 +435,22 @@
;;@subheading Deleting
+;;@args x list =
+;;@args x list
+(define (delete-duplicates l =?)
+ (let loop ((l l) (r '()))
+ (if (null? l)
+ (reverse! r)
+ (loop (cdr l)
+ (if (member (car l) r =?) r (cons (car l) r))))))
+;;@args x list =
+;;@args x list
+(define delete-duplicates! delete-duplicates)
+
;;@subheading Association lists
;;@args obj alist pred
;;@args obj alist
-;;
-;;@2 (for ``association list'') must be a list of pairs. These
-;;procedures find the first pair in @2 whose car field is @1, and
-;;returns that pair. If no pair in @2 has @1 as its car, then @t{#f}
-;;(not the empty list) is returned. The procedure @3 is used for
-;;testing equality. If @3 is not provided, @samp{equal?} is used.
(define assoc
(let ((old-assoc assoc))
(lambda (obj alist . pred)
@@ -405,8 +459,140 @@
(let ((pred (car pred)))
(find (lambda (pair) (pred obj (car pair))) alist))))))
+;; XXX maybe define the following in alist and require that module here?
+
+;;@args key datum alist
+(define (alist-cons k d l) (cons (cons k d) l))
+
+;;@args alist
+(define (alist-copy l)
+ (map (lambda (x) (cons (car x) (cdr x))) l))
+
+;;@args key alist =
+;;@args key alist
+(define (alist-delete k l . opt)
+ (let ((key=? (if (pair? opt) (car opt) equal?)))
+ (remove (lambda (x) (key=? (car x) k)) l)))
+;;@args key alist =
+;;@args key alist
+(define (alist-delete! k l . opt)
+ (let ((key=? (if (pair? opt) (car opt) equal?)))
+ (remove! (lambda (x) (key=? (car x) k)) l)))
+
;;@subheading Set operations
+;;@args = list1 @dots{}
+;;Determine if a transitive subset relation exists between the lists @2
+;;@dots{}, using @1 to determine equality of list members.
+(define (lset<= =? . l)
+ (or (null? l)
+ (letrec ((subset? (lambda (l1 l2)
+ (or (eq? l1 l2)
+ (every (lambda (x) (member x l2)) l1)))))
+ (let loop ((l1 (car l)) (l (cdr l)))
+ (or (null? l)
+ (let ((l2 (car l)))
+ (and (subset? l1 l2)
+ (loop l2 (cdr l)))))))))
+
+;;@args = list1 list2 @dots{}
+(define (lset= =? . l)
+ (or (null? l)
+ (let loop ((l1 (car l)) (l (cdr l)))
+ (or (null? l)
+ (let ((l2 (car l)))
+ (and (lset<= =? l1 l2)
+ (lset<= =? l2 l1)
+ (loop (if (< (length l1) (length l2)) l1 l2)
+ (cdr l))))))))
+
+;;@args list elt1 @dots{}
+(define (lset-adjoin =? l1 . l2)
+ (let ((adjoin (lambda (x l)
+ (if (member x l =?) l (cons x l)))))
+ (fold adjoin l1 l2)))
+
+;;@args = list1 @dots{}
+(define (lset-union =? . l)
+ (let ((union (lambda (l1 l2)
+ (if (or (null? l2) (eq? l1 l2))
+ l1
+ (apply lset-adjoin (cons* =? l2 l1))))))
+ (fold union '() l)))
+
+;;@args = list1 list2 @dots{}
+(define (lset-intersection =? l1 . l)
+ (let loop ((l l) (r l1))
+ (cond ((null? l) r)
+ ((null? (car l)) '())
+ (else (loop (cdr l)
+ (filter (lambda (x) (member x (car l) =?)) r))))))
+
+;;@args = list1 list2 ...
+(define (lset-difference =? l1 . l)
+ (call-with-current-continuation
+ (lambda (return)
+ (let ((diff (lambda (l1 l2)
+ (cond ((null? l2) (return '()))
+ ((null? l1) l2)
+ (else (remove (lambda (x) (member x l1 =?))
+ l2))))))
+ (fold diff l1 l)))))
+
+;; Alternatively definition of lset-difference, for large numbers of sets.
+;(define (lset-difference =? l1 . l)
+; (set! l (cdr (delete-duplicates! (cons l1 l) eq?)))
+; (case (length l)
+; ((0) l1)
+; ((1) (remove (lambda (x) (member x l1 =?)) (car l)))
+; (else (apply (lset-difference! (cons* =? (list-copy l1) l))))))
+
+;;@args = list1 ...
+(define (lset-xor =? . l)
+ (let ((xor (lambda (l1 l2) (lset-union =? (lset-difference =? l1 l2)
+ (lset-difference =? l2 l1)))))
+ (fold xor '() l)))
+
+;;@args = list1 list2 ...
+(define (lset-diff+intersection =? l1 . l)
+ (let ((u (apply lset-union (cons =? l))))
+ (values (lset-difference =? l1 u)
+ (lset-intersection =? l1 u))))
+
+;;@noindent
+;;These are linear-update variants. They are allowed, but not
+;;required, to use the cons cells in their first list parameter to
+;;construct their answer. @code{lset-union!} is permitted to recycle
+;;cons cells from any of its list arguments.
+
+;;@args = list1 list2 ...
+(define lset-intersection! lset-intersection)
+;;@args = list1 list2 ...
+(define (lset-difference! =? l1 . l)
+ (let loop ((l l) (d l1))
+ (if (or (null? l) (null? d))
+ d
+ (loop (cdr l)
+ (let ((l1 (car l)))
+ (if (null? l1) d (remove! (lambda (x) (member x l1 =?)) d)))))))
+
+;;@args = list1 ...
+(define (lset-union! =? . l)
+ (let loop ((l l) (u '()))
+ (if (null? l)
+ u
+ (loop (cdr l)
+ (cond ((null? (car l)) u)
+ ((eq? (car l) u) u)
+ ((null? u) (car l))
+ (else (append-reverse! (lset-difference! =? (car l) u)
+ u)))))))
+;;@args = list1 ...
+(define lset-xor! lset-xor)
+
+;;@args = list1 list2 ...
+(define lset-diff+intersection! lset-diff+intersection)
+
;;;; helper functions from the reference implementation: