diff options
Diffstat (limited to 'srfi-1.scm')
| -rw-r--r-- | srfi-1.scm | 382 |
1 files changed, 284 insertions, 98 deletions
@@ -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: |