diff --git a/collects/srfi/1/alist.ss b/collects/srfi/1/alist.ss index adda2d8ae6..ef35ca5d40 100644 --- a/collects/srfi/1/alist.ss +++ b/collects/srfi/1/alist.ss @@ -2,7 +2,7 @@ ;;; ---- Association list functions ;;; Time-stamp: <02/03/01 13:56:33 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -32,45 +32,41 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module alist - mzscheme +#lang mzscheme - (require mzlib/etc - srfi/optional - (only "search.ss" find) - "filter.ss" - (rename "fold.ss" s:map map)) +(require mzlib/etc + srfi/optional + (only "search.ss" find) + "filter.ss" + (rename "fold.ss" s:map map)) - (provide (rename my-assoc assoc) - alist-cons - alist-copy - alist-delete - #;alist-delete!) +(provide (rename my-assoc assoc) + alist-cons + alist-copy + alist-delete + #;alist-delete!) - - ;; Extended from R4RS to take an optional comparison argument. - (define my-assoc - (opt-lambda (x lis (maybe-= equal?)) - (let ((= maybe-=)) - (find (lambda (entry) (= x (car entry))) lis)))) +;; Extended from R4RS to take an optional comparison argument. +(define my-assoc + (opt-lambda (x lis (maybe-= equal?)) + (let ((= maybe-=)) + (find (lambda (entry) (= x (car entry))) lis)))) - (define (alist-cons key datum alist) (cons (cons key datum) alist)) +(define (alist-cons key datum alist) (cons (cons key datum) alist)) - (define (alist-copy alist) - (s:map (lambda (elt) (cons (car elt) (cdr elt))) - alist)) +(define (alist-copy alist) + (s:map (lambda (elt) (cons (car elt) (cdr elt))) + alist)) - (define alist-delete - (opt-lambda (key alist (maybe-= equal?)) - (let ((= maybe-=)) - (filter (lambda (elt) (not (= key (car elt)))) alist)))) +(define alist-delete + (opt-lambda (key alist (maybe-= equal?)) + (let ((= maybe-=)) + (filter (lambda (elt) (not (= key (car elt)))) alist)))) - #; - (define alist-delete! - (opt-lambda (key alist (maybe-= equal?)) - (let ((= maybe-=)) - (filter! (lambda (elt) (not (= key (car elt)))) alist)))) - - ) +#; +(define alist-delete! + (opt-lambda (key alist (maybe-= equal?)) + (let ((= maybe-=)) + (filter! (lambda (elt) (not (= key (car elt)))) alist)))) ;;; alist.ss ends here diff --git a/collects/srfi/1/cons.ss b/collects/srfi/1/cons.ss index 3644528dc0..ca2277487f 100644 --- a/collects/srfi/1/cons.ss +++ b/collects/srfi/1/cons.ss @@ -2,7 +2,7 @@ ;;; ---- List constructors ;;; Time-stamp: <02/02/27 12:19:59 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -32,92 +32,79 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module cons - mzscheme +#lang mzscheme - (require mzlib/etc - srfi/optional - "selector.ss") +(require mzlib/etc + srfi/optional + "selector.ss") - (provide xcons - make-list - list-tabulate - cons* - list-copy - circular-list - iota) +(provide xcons + make-list + list-tabulate + cons* + list-copy + circular-list + iota) - ;; Occasionally useful as a value to be passed to a fold or other - ;; higher-order procedure. - (define (xcons d a) (cons a d)) +;; Occasionally useful as a value to be passed to a fold or other +;; higher-order procedure. +(define (xcons d a) (cons a d)) +;; Make a list of length LEN. - ;; Make a list of length LEN. - - (define make-list - (opt-lambda (len [elt #f]) - (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list) - (do ((i len (- i 1)) - (ans '() (cons elt ans))) - ((<= i 0) ans)))) - +(define make-list + (opt-lambda (len [elt #f]) + (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list) + (do ((i len (- i 1)) + (ans '() (cons elt ans))) + ((<= i 0) ans)))) - ;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. - - (define (list-tabulate len proc) - (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'list-tabulate) - (check-arg procedure? proc 'list-tabulate) - (do ((i (- len 1) (- i 1)) - (ans '() (cons (proc i) ans))) - ((< i 0) ans))) - - ;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an))) - ;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...)) - ;; - ;; (cons first (unfold not-pair? car cdr rest values)) +;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. - (define (cons* first . rest) - (let recur ((x first) (rest rest)) - (if (pair? rest) - (cons x (recur (car rest) (cdr rest))) - x))) - +(define (list-tabulate len proc) + (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'list-tabulate) + (check-arg procedure? proc 'list-tabulate) + (do ((i (- len 1) (- i 1)) + (ans '() (cons (proc i) ans))) + ((< i 0) ans))) - (define (list-copy lis) - (let recur ((lis lis)) - (if (pair? lis) - (cons (car lis) (recur (cdr lis))) - lis))) - - - (define (circular-list val1 . vals) - (let ([ph (make-placeholder #f)]) - (placeholder-set! ph - (cons val1 - (let loop ([vals vals]) - (if (null? vals) - ph - (cons (car vals) - (loop (cdr vals))))))) - (make-reader-graph ph))) +;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an))) +;; (cons* a1) = a1; (cons* a1 a2 ...) = (cons a1 (cons* a2 ...)) +;; +;; (cons first (unfold not-pair? car cdr rest values)) +(define (cons* first . rest) + (let recur ((x first) (rest rest)) + (if (pair? rest) + (cons x (recur (car rest) (cdr rest))) + x))) - ;; IOTA count [start step] (start start+step ... start+(count-1)*step) - - (define iota - (opt-lambda (count [start 0] [step 1]) - (check-arg integer? count 'iota) - (check-arg number? start 'iota) - (check-arg number? step 'iota) - (unless (or (zero? count) (positive? count)) - (error 'iota "count expected to be non-negative, got: ~a" count)) - (let loop ([n 0]) - (cond - [(= n count) '()] - [else (cons (+ start (* n step)) - (loop (add1 n)))])))) - +(define (list-copy lis) + (let recur ((lis lis)) + (if (pair? lis) + (cons (car lis) (recur (cdr lis))) + lis))) - ) +(define (circular-list val1 . vals) + (let ([ph (make-placeholder #f)]) + (placeholder-set! ph + (cons val1 (let loop ([vals vals]) + (if (null? vals) + ph + (cons (car vals) (loop (cdr vals))))))) + (make-reader-graph ph))) + +;; IOTA count [start step] (start start+step ... start+(count-1)*step) + +(define iota + (opt-lambda (count [start 0] [step 1]) + (check-arg integer? count 'iota) + (check-arg number? start 'iota) + (check-arg number? step 'iota) + (unless (or (zero? count) (positive? count)) + (error 'iota "count expected to be non-negative, got: ~a" count)) + (let loop ([n 0]) + (if (= n count) '() + (cons (+ start (* n step)) (loop (add1 n))))))) ;;; cons.ss ends here diff --git a/collects/srfi/1/delete.ss b/collects/srfi/1/delete.ss index d446b7fbaa..0452611d73 100644 --- a/collects/srfi/1/delete.ss +++ b/collects/srfi/1/delete.ss @@ -2,7 +2,7 @@ ;;; ---- List deletion functions ;;; Time-stamp: <02/03/01 07:26:12 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -33,63 +33,59 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module delete - mzscheme +#lang mzscheme - (require mzlib/etc - srfi/optional - "predicate.ss" - "filter.ss") +(require mzlib/etc + srfi/optional + "predicate.ss" + "filter.ss") - (provide delete - (rename delete delete!) - delete-duplicates - (rename delete-duplicates delete-duplicates!)) +(provide delete + (rename delete delete!) + delete-duplicates + (rename delete-duplicates delete-duplicates!)) - (define delete - (opt-lambda (x lis (maybe-= equal?)) - (let ((= maybe-=)) - (filter (lambda (y) (not (= x y))) lis)))) +(define delete + (opt-lambda (x lis (maybe-= equal?)) + (let ((= maybe-=)) + (filter (lambda (y) (not (= x y))) lis)))) - #; - (define delete! - (opt-lambda (x lis (maybe-= equal?)) - (let ((= maybe-=)) - (filter! (lambda (y) (not (= x y))) lis)))) +#; +(define delete! + (opt-lambda (x lis (maybe-= equal?)) + (let ((= maybe-=)) + (filter! (lambda (y) (not (= x y))) lis)))) - ;; right-duplicate deletion - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; delete-duplicates delete-duplicates! - ;; - ;; Beware -- these are N^2 algorithms. To efficiently remove duplicates - ;; in long lists, sort the list to bring duplicates together, then use a - ;; linear-time algorithm to kill the dups. Or use an algorithm based on - ;; element-marking. The former gives you O(n lg n), the latter is linear. +;; right-duplicate deletion +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; delete-duplicates delete-duplicates! +;; +;; Beware -- these are N^2 algorithms. To efficiently remove duplicates +;; in long lists, sort the list to bring duplicates together, then use a +;; linear-time algorithm to kill the dups. Or use an algorithm based on +;; element-marking. The former gives you O(n lg n), the latter is linear. - (define delete-duplicates - (opt-lambda (lis (maybe-= equal?)) - (let ((elt= maybe-=)) - (check-arg procedure? elt= 'delete-duplicates) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail)))))))) - - #; - (define delete-duplicates! - (opt-lambda (lis (maybe-= equal?)) - (let ((elt= maybe-=)) - (check-arg procedure? elt= 'delete-duplicates!) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete! x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail)))))))) - - ) +(define delete-duplicates + (opt-lambda (lis (maybe-= equal?)) + (let ((elt= maybe-=)) + (check-arg procedure? elt= 'delete-duplicates) + (let recur ((lis lis)) + (if (null-list? lis) lis + (let* ((x (car lis)) + (tail (cdr lis)) + (new-tail (recur (delete x tail elt=)))) + (if (eq? tail new-tail) lis (cons x new-tail)))))))) +#; +(define delete-duplicates! + (opt-lambda (lis (maybe-= equal?)) + (let ((elt= maybe-=)) + (check-arg procedure? elt= 'delete-duplicates!) + (let recur ((lis lis)) + (if (null-list? lis) lis + (let* ((x (car lis)) + (tail (cdr lis)) + (new-tail (recur (delete! x tail elt=)))) + (if (eq? tail new-tail) lis (cons x new-tail)))))))) ;;; delete.ss ends here diff --git a/collects/srfi/1/filter.ss b/collects/srfi/1/filter.ss index a00d360626..07eb93cf5d 100644 --- a/collects/srfi/1/filter.ss +++ b/collects/srfi/1/filter.ss @@ -2,7 +2,7 @@ ;;; ---- List filtering and partitioning functions ;;; Time-stamp: <02/03/01 07:26:43 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -32,162 +32,145 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module filter - mzscheme +#lang mzscheme - (require mzlib/etc - srfi/optional - "predicate.ss") - (require srfi/8/receive) +(require mzlib/etc + srfi/optional + "predicate.ss" + srfi/8/receive) - (provide filter - partition - remove - (rename filter filter!) - (rename partition partition!) - (rename remove remove!)) +(provide filter + partition + remove + (rename filter filter!) + (rename partition partition!) + (rename remove remove!)) +;; filter, remove, partition +;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FILTER, REMOVE, PARTITION and their destructive counterparts do not +;; disorder the elements of their argument. - ;; filter, remove, partition - ;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; FILTER, REMOVE, PARTITION and their destructive counterparts do not - ;; disorder the elements of their argument. +;; This FILTER shares the longest tail of L that has no deleted +;; elements. If Scheme had multi-continuation calls, they could be +;; made more efficient. - ;; This FILTER shares the longest tail of L that has no deleted - ;; elements. If Scheme had multi-continuation calls, they could be - ;; made more efficient. +(define (filter pred lis) ; Sleazing with EQ? makes this + (check-arg procedure? pred 'filter) ; one faster. + (let recur ((lis lis)) + (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. + (let ((head (car lis)) + (tail (cdr lis))) + (if (pred head) + (let ((new-tail (recur tail))) ; Replicate the RECUR call so + (if (eq? tail new-tail) lis + (cons head new-tail))) + (recur tail)))))) ; this one can be a tail call. - (define (filter pred lis) ; Sleazing with EQ? makes this - (check-arg procedure? pred 'filter) ; one faster. - (let recur ((lis lis)) - (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. - (let ((head (car lis)) - (tail (cdr lis))) - (if (pred head) - (let ((new-tail (recur tail))) ; Replicate the RECUR call so - (if (eq? tail new-tail) lis - (cons head new-tail))) - (recur tail)))))) ; this one can be a tail call. +;; This implementation of FILTER! +;; - doesn't cons, and uses no stack; +;; - is careful not to do redundant SET-CDR! writes, as writes to memory are +;; usually expensive on modern machines, and can be extremely expensive on +;; modern Schemes (e.g., ones that have generational GC's). +;; It just zips down contiguous runs of in and out elts in LIS doing the +;; minimal number of SET-CDR!s to splice the tail of one run of ins to the +;; beginning of the next. +#; +(define (filter! pred lis) + (check-arg procedure? pred 'filter!) + (let lp ((ans lis)) + (cond ((null-list? ans) ans) ; Scan looking for + ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. + ;; ANS is the eventual answer. + ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. + ;; Scan over a contiguous segment of the list that + ;; satisfies PRED. + ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous + ;; segment of the list that *doesn't* satisfy PRED. + ;; When the segment ends, patch in a link from PREV + ;; to the start of the next good segment, and jump to + ;; SCAN-IN. + (else + (letrec ((scan-in (lambda (prev lis) + (if (pair? lis) + (if (pred (car lis)) + (scan-in lis (cdr lis)) + (scan-out prev (cdr lis)))))) + (scan-out (lambda (prev lis) + (let lp ((lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (begin (set-cdr! prev lis) + (scan-in lis (cdr lis))) + (lp (cdr lis))) + (set-cdr! prev lis)))))) + (scan-in ans (cdr ans)) + ans))))) +;; Answers share common tail with LIS where possible; +;; the technique is slightly subtle. +(define (partition pred lis) + (check-arg procedure? pred 'partition) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. + (let ((elt (car lis)) + (tail (cdr lis))) + (receive (in out) (recur tail) + (if (pred elt) + (values (if (pair? out) (cons elt in) lis) out) + (values in (if (pair? in) (cons elt out) lis)))))))) +;; This implementation of PARTITION! +;; - doesn't cons, and uses no stack; +;; - is careful not to do redundant SET-CDR! writes, as writes to memory are +;; usually expensive on modern machines, and can be extremely expensive on +;; modern Schemes (e.g., ones that have generational GC's). +;; It just zips down contiguous runs of in and out elts in LIS doing the +;; minimal number of SET-CDR!s to splice these runs together into the result +;; lists. +#; +(define (partition! pred lis) + (check-arg procedure? pred 'partition!) + (if (null-list? lis) (values lis lis) + ;; This pair of loops zips down contiguous in & out runs of the + ;; list, splicing the runs together. The invariants are + ;; SCAN-IN: (cdr in-prev) = LIS. + ;; SCAN-OUT: (cdr out-prev) = LIS. + (letrec ((scan-in (lambda (in-prev out-prev lis) + (let lp ((in-prev in-prev) (lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (lp lis (cdr lis)) + (begin (set-cdr! out-prev lis) + (scan-out in-prev lis (cdr lis)))) + (set-cdr! out-prev lis))))) ; Done. + (scan-out (lambda (in-prev out-prev lis) + (let lp ((out-prev out-prev) (lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (begin (set-cdr! in-prev lis) + (scan-in lis out-prev (cdr lis))) + (lp lis (cdr lis))) + (set-cdr! in-prev lis)))))) ; Done. + ;; Crank up the scan&splice loops. + (if (pred (car lis)) + ;; LIS begins in-list. Search for out-list's first pair. + (let lp ((prev-l lis) (l (cdr lis))) + (cond ((not (pair? l)) (values lis l)) + ((pred (car l)) (lp l (cdr l))) + (else (scan-out prev-l l (cdr l)) + (values lis l)))) ; Done. + ;; LIS begins out-list. Search for in-list's first pair. + (let lp ((prev-l lis) (l (cdr lis))) + (cond ((not (pair? l)) (values l lis)) + ((pred (car l)) + (scan-in l prev-l (cdr l)) + (values l lis)) ; Done. + (else (lp l (cdr l))))))))) +;; Inline us, please. +(define (remove pred l) (filter (lambda (x) (not (pred x))) l)) +#; +(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) - - ;; This implementation of FILTER! - ;; - doesn't cons, and uses no stack; - ;; - is careful not to do redundant SET-CDR! writes, as writes to memory are - ;; usually expensive on modern machines, and can be extremely expensive on - ;; modern Schemes (e.g., ones that have generational GC's). - ;; It just zips down contiguous runs of in and out elts in LIS doing the - ;; minimal number of SET-CDR!s to splice the tail of one run of ins to the - ;; beginning of the next. - #; - (define (filter! pred lis) - (check-arg procedure? pred 'filter!) - (let lp ((ans lis)) - (cond ((null-list? ans) ans) ; Scan looking for - ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. - - ;; ANS is the eventual answer. - ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. - ;; Scan over a contiguous segment of the list that - ;; satisfies PRED. - ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous - ;; segment of the list that *doesn't* satisfy PRED. - ;; When the segment ends, patch in a link from PREV - ;; to the start of the next good segment, and jump to - ;; SCAN-IN. - (else - (letrec ((scan-in (lambda (prev lis) - (if (pair? lis) - (if (pred (car lis)) - (scan-in lis (cdr lis)) - (scan-out prev (cdr lis)))))) - (scan-out (lambda (prev lis) - (let lp ((lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! prev lis) - (scan-in lis (cdr lis))) - (lp (cdr lis))) - (set-cdr! prev lis)))))) - (scan-in ans (cdr ans)) - ans))))) - - - - ;; Answers share common tail with LIS where possible; - ;; the technique is slightly subtle. - (define (partition pred lis) - (check-arg procedure? pred 'partition) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. - (let ((elt (car lis)) - (tail (cdr lis))) - (receive (in out) (recur tail) - (if (pred elt) - (values (if (pair? out) (cons elt in) lis) out) - (values in (if (pair? in) (cons elt out) lis)))))))) - - - - ;; This implementation of PARTITION! - ;; - doesn't cons, and uses no stack; - ;; - is careful not to do redundant SET-CDR! writes, as writes to memory are - ;; usually expensive on modern machines, and can be extremely expensive on - ;; modern Schemes (e.g., ones that have generational GC's). - ;; It just zips down contiguous runs of in and out elts in LIS doing the - ;; minimal number of SET-CDR!s to splice these runs together into the result - ;; lists. - #; - (define (partition! pred lis) - (check-arg procedure? pred 'partition!) - (if (null-list? lis) (values lis lis) - - ;; This pair of loops zips down contiguous in & out runs of the - ;; list, splicing the runs together. The invariants are - ;; SCAN-IN: (cdr in-prev) = LIS. - ;; SCAN-OUT: (cdr out-prev) = LIS. - (letrec ((scan-in (lambda (in-prev out-prev lis) - (let lp ((in-prev in-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (lp lis (cdr lis)) - (begin (set-cdr! out-prev lis) - (scan-out in-prev lis (cdr lis)))) - (set-cdr! out-prev lis))))) ; Done. - - (scan-out (lambda (in-prev out-prev lis) - (let lp ((out-prev out-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! in-prev lis) - (scan-in lis out-prev (cdr lis))) - (lp lis (cdr lis))) - (set-cdr! in-prev lis)))))) ; Done. - - ;; Crank up the scan&splice loops. - (if (pred (car lis)) - ;; LIS begins in-list. Search for out-list's first pair. - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values lis l)) - ((pred (car l)) (lp l (cdr l))) - (else (scan-out prev-l l (cdr l)) - (values lis l)))) ; Done. - - ;; LIS begins out-list. Search for in-list's first pair. - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values l lis)) - ((pred (car l)) - (scan-in l prev-l (cdr l)) - (values l lis)) ; Done. - (else (lp l (cdr l))))))))) - - - ;; Inline us, please. - (define (remove pred l) (filter (lambda (x) (not (pred x))) l)) - #; - (define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) - - ) ;;; filter.ss ends here diff --git a/collects/srfi/1/fold.ss b/collects/srfi/1/fold.ss index 7c5756cf4b..8baa201e3f 100644 --- a/collects/srfi/1/fold.ss +++ b/collects/srfi/1/fold.ss @@ -2,7 +2,7 @@ ;;; ---- List folds ;;; Time-stamp: <02/02/28 12:02:38 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -32,260 +32,234 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module fold - mzscheme +#lang mzscheme - (require srfi/optional - "predicate.ss" - "selector.ss" - "util.ss") - (require srfi/8/receive) +(require srfi/optional + "predicate.ss" + "selector.ss" + "util.ss" + srfi/8/receive) - (provide (rename my-map map) - (rename my-for-each for-each) - fold - unfold - pair-fold - reduce - fold-right - unfold-right - pair-fold-right - reduce-right - append-map - (rename append-map append-map!) - (rename my-map map!) - pair-for-each - filter-map - map-in-order) +(provide (rename my-map map) + (rename my-for-each for-each) + fold + unfold + pair-fold + reduce + fold-right + unfold-right + pair-fold-right + reduce-right + append-map + (rename append-map append-map!) + (rename my-map map!) + pair-for-each + filter-map + map-in-order) + +;; fold/unfold +;;;;;;;;;;;;;; + +(define (unfold-right p f g seed . maybe-tail) + (check-arg procedure? p 'unfold-right) + (check-arg procedure? f 'unfold-right) + (check-arg procedure? g 'unfold-right) + (let lp ((seed seed) (ans maybe-tail)) + (if (p seed) ans + (lp (g seed) + (cons (f seed) ans))))) + +(define (unfold p f g seed . maybe-tail-gen) + (check-arg procedure? p 'unfold) + (check-arg procedure? f 'unfold) + (check-arg procedure? g 'unfold) + (if (pair? maybe-tail-gen) + (let ((tail-gen (car maybe-tail-gen))) + (if (pair? (cdr maybe-tail-gen)) + (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) + (let recur ((seed seed)) + (if (p seed) (tail-gen seed) + (cons (f seed) (recur (g seed))))))) + (let recur ((seed seed)) + (if (p seed) '() + (cons (f seed) (recur (g seed))))))) + +(define (fold kons knil lis1 . lists) + (check-arg procedure? kons 'fold) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case + (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) + (if (null? cars+ans) ans ; Done. + (lp cdrs (apply kons cars+ans))))) + (let lp ((lis lis1) (ans knil)) ; Fast path + (if (null-list? lis) ans + (lp (cdr lis) (kons (car lis) ans)))))) + +(define (fold-right kons knil lis1 . lists) + (check-arg procedure? kons 'fold-right) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) ; N-ary case + (let ((cdrs (%cdrs lists))) + (if (null? cdrs) knil + (apply kons (%cars+ lists (recur cdrs)))))) + + (let recur ((lis lis1)) ; Fast path + (if (null-list? lis) knil + (let ((head (car lis))) + (kons head (recur (cdr lis)))))))) + +(define (pair-fold-right f zero lis1 . lists) + (check-arg procedure? f 'pair-fold-right) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) ; N-ary case + (let ((cdrs (%cdrs lists))) + (if (null? cdrs) zero + (apply f (append lists (list (recur cdrs))))))) + (let recur ((lis lis1)) ; Fast path + (if (null-list? lis) zero (f lis (recur (cdr lis))))))) + +(define (pair-fold f zero lis1 . lists) + (check-arg procedure? f 'pair-fold) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case + (let ((tails (%cdrs lists))) + (if (null? tails) ans + (lp tails (apply f (append lists (list ans))))))) + (let lp ((lis lis1) (ans zero)) + (if (null-list? lis) ans + (let ((tail (cdr lis))) ; Grab the cdr now, + (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. + +;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. +;; These cannot meaningfully be n-ary. + +(define (reduce f ridentity lis) + (check-arg procedure? f 'reduce) + (if (null-list? lis) ridentity + (fold f (car lis) (cdr lis)))) + +(define (reduce-right f ridentity lis) + (check-arg procedure? f 'reduce-right) + (if (null-list? lis) ridentity + (let recur ((head (car lis)) (lis (cdr lis))) + (if (pair? lis) + (f head (recur (car lis) (cdr lis))) + head)))) + +;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (append-map f lis1 . lists) + (really-append-map append-map append f lis1 lists)) +#; +(define (append-map! f lis1 . lists) + (really-append-map append-map! append! f lis1 lists)) + +(define (really-append-map who appender f lis1 lists) + (check-arg procedure? f 'who) + (if (pair? lists) + (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) + (if (null? cars) '() + (let recur ((cars cars) (cdrs cdrs)) + (let ((vals (apply f cars))) + (receive (cars2 cdrs2) (%cars+cdrs cdrs) + (if (null? cars2) vals + (appender vals (recur cars2 cdrs2)))))))) + ;; Fast path + (if (null-list? lis1) '() + (let recur ((elt (car lis1)) (rest (cdr lis1))) + (let ((vals (f elt))) + (if (null-list? rest) vals + (appender vals (recur (car rest) (cdr rest))))))))) + +(define (pair-for-each proc lis1 . lists) + (check-arg procedure? proc 'pair-for-each) + (if (pair? lists) + (let lp ((lists (cons lis1 lists))) + (let ((tails (%cdrs lists))) + (if (pair? tails) + (begin (apply proc lists) + (lp tails))))) + ;; Fast path. + (let lp ((lis lis1)) + (if (not (null-list? lis)) + (let ((tail (cdr lis))) ; Grab the cdr now, + (proc lis) ; in case PROC SET-CDR!s LIS. + (lp tail)))))) + +;; We stop when LIS1 runs out, not when any list runs out. +#; +(define (map! f lis1 . lists) + (check-arg procedure? f 'map!) + (if (pair? lists) + (let lp ((lis1 lis1) (lists lists)) + (if (not (null-list? lis1)) + (receive (heads tails) (%cars+cdrs/no-test lists) + (set-car! lis1 (apply f (car lis1) heads)) + (lp (cdr lis1) tails)))) + ;; Fast path. + (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) + lis1) + +;; Map F across L, and save up all the non-false results. +(define (filter-map f lis1 . lists) + (check-arg procedure? f 'filter-map) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) + (else (recur cdrs))) ; Tail call in this arm. + '()))) + ;; Fast path. + (let recur ((lis lis1)) + (if (null-list? lis) lis + (let ((tail (recur (cdr lis)))) + (cond ((f (car lis)) => (lambda (x) (cons x tail))) + (else tail))))))) + +;; Map F across lists, guaranteeing to go left-to-right. +;; NOTE: Some implementations of R5RS MAP are compliant with this spec; +;; in which case this procedure may simply be defined as a synonym for MAP. + +(define (map-in-order f lis1 . lists) + (check-arg procedure? f 'map-in-order) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (let ((x (apply f cars))) ; Do head first, + (cons x (recur cdrs))) ; then tail. + '()))) + ;; Fast path. + (let recur ((lis lis1)) + (if (null-list? lis) lis + (let ((tail (cdr lis)) + (x (f (car lis)))) ; Do head first, + (cons x (recur tail))))))) ; then tail. + +;; We extend MAP to handle arguments of unequal length. +(define my-map map-in-order) - - ;; fold/unfold - ;;;;;;;;;;;;;; - - (define (unfold-right p f g seed . maybe-tail) - (check-arg procedure? p 'unfold-right) - (check-arg procedure? f 'unfold-right) - (check-arg procedure? g 'unfold-right) - (let lp ((seed seed) (ans maybe-tail)) - (if (p seed) ans - (lp (g seed) - (cons (f seed) ans))))) - - - (define (unfold p f g seed . maybe-tail-gen) - (check-arg procedure? p 'unfold) - (check-arg procedure? f 'unfold) - (check-arg procedure? g 'unfold) - (if (pair? maybe-tail-gen) - - (let ((tail-gen (car maybe-tail-gen))) - (if (pair? (cdr maybe-tail-gen)) - (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) - - (let recur ((seed seed)) - (if (p seed) (tail-gen seed) - (cons (f seed) (recur (g seed))))))) - - (let recur ((seed seed)) - (if (p seed) '() - (cons (f seed) (recur (g seed))))))) - - - (define (fold kons knil lis1 . lists) - (check-arg procedure? kons 'fold) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case - (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) - (if (null? cars+ans) ans ; Done. - (lp cdrs (apply kons cars+ans))))) - - (let lp ((lis lis1) (ans knil)) ; Fast path - (if (null-list? lis) ans - (lp (cdr lis) (kons (car lis) ans)))))) - - - (define (fold-right kons knil lis1 . lists) - (check-arg procedure? kons 'fold-right) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) ; N-ary case - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) knil - (apply kons (%cars+ lists (recur cdrs)))))) - - (let recur ((lis lis1)) ; Fast path - (if (null-list? lis) knil - (let ((head (car lis))) - (kons head (recur (cdr lis)))))))) - - - (define (pair-fold-right f zero lis1 . lists) - (check-arg procedure? f 'pair-fold-right) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) ; N-ary case - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) zero - (apply f (append lists (list (recur cdrs))))))) - - (let recur ((lis lis1)) ; Fast path - (if (null-list? lis) zero (f lis (recur (cdr lis))))))) - - (define (pair-fold f zero lis1 . lists) - (check-arg procedure? f 'pair-fold) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case - (let ((tails (%cdrs lists))) - (if (null? tails) ans - (lp tails (apply f (append lists (list ans))))))) - - (let lp ((lis lis1) (ans zero)) - (if (null-list? lis) ans - (let ((tail (cdr lis))) ; Grab the cdr now, - (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. - - - ;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. - ;; These cannot meaningfully be n-ary. - - (define (reduce f ridentity lis) - (check-arg procedure? f 'reduce) - (if (null-list? lis) ridentity - (fold f (car lis) (cdr lis)))) - - (define (reduce-right f ridentity lis) - (check-arg procedure? f 'reduce-right) - (if (null-list? lis) ridentity - (let recur ((head (car lis)) (lis (cdr lis))) - (if (pair? lis) - (f head (recur (car lis) (cdr lis))) - head)))) - - - - ;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (append-map f lis1 . lists) - (really-append-map append-map append f lis1 lists)) - #; - (define (append-map! f lis1 . lists) - (really-append-map append-map! append! f lis1 lists)) - - (define (really-append-map who appender f lis1 lists) - (check-arg procedure? f 'who) - (if (pair? lists) - (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) - (if (null? cars) '() - (let recur ((cars cars) (cdrs cdrs)) - (let ((vals (apply f cars))) - (receive (cars2 cdrs2) (%cars+cdrs cdrs) - (if (null? cars2) vals - (appender vals (recur cars2 cdrs2)))))))) - - ;; Fast path - (if (null-list? lis1) '() - (let recur ((elt (car lis1)) (rest (cdr lis1))) - (let ((vals (f elt))) - (if (null-list? rest) vals - (appender vals (recur (car rest) (cdr rest))))))))) - - - (define (pair-for-each proc lis1 . lists) - (check-arg procedure? proc 'pair-for-each) - (if (pair? lists) - - (let lp ((lists (cons lis1 lists))) - (let ((tails (%cdrs lists))) - (if (pair? tails) - (begin (apply proc lists) - (lp tails))))) - - ;; Fast path. - (let lp ((lis lis1)) - (if (not (null-list? lis)) - (let ((tail (cdr lis))) ; Grab the cdr now, - (proc lis) ; in case PROC SET-CDR!s LIS. - (lp tail)))))) - - ;; We stop when LIS1 runs out, not when any list runs out. - #; - (define (map! f lis1 . lists) - (check-arg procedure? f 'map!) - (if (pair? lists) - (let lp ((lis1 lis1) (lists lists)) - (if (not (null-list? lis1)) - (receive (heads tails) (%cars+cdrs/no-test lists) - (set-car! lis1 (apply f (car lis1) heads)) - (lp (cdr lis1) tails)))) - - ;; Fast path. - (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) - lis1) - - - ;; Map F across L, and save up all the non-false results. - (define (filter-map f lis1 . lists) - (check-arg procedure? f 'filter-map) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) - (else (recur cdrs))) ; Tail call in this arm. - '()))) - - ;; Fast path. - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (recur (cdr lis)))) - (cond ((f (car lis)) => (lambda (x) (cons x tail))) - (else tail))))))) - - - ;; Map F across lists, guaranteeing to go left-to-right. - ;; NOTE: Some implementations of R5RS MAP are compliant with this spec; - ;; in which case this procedure may simply be defined as a synonym for MAP. - - (define (map-in-order f lis1 . lists) - (check-arg procedure? f 'map-in-order) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (let ((x (apply f cars))) ; Do head first, - (cons x (recur cdrs))) ; then tail. - '()))) - - ;; Fast path. - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (cdr lis)) - (x (f (car lis)))) ; Do head first, - (cons x (recur tail))))))) ; then tail. - - - ;; We extend MAP to handle arguments of unequal length. - (define my-map map-in-order) - ;;; Apply F across lists, guaranteeing to go left-to-right. ;;; NOTE: Some implementations of R5RS MAP are compliant with this spec; ;;; in which case this procedure may simply be defined as a synonym for FOR-EACH. - (define (my-for-each f lis1 . lists) - (check-arg procedure? f for-each) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (begin - (apply f cars) ; Do head first, - (recur cdrs))))) ; then tail. - - ;; Fast path. - (let recur ((lis lis1)) - (if (not (null-list? lis)) - (begin - (f (car lis)) ; Do head first, - (recur (cdr lis))))))) - ) +(define (my-for-each f lis1 . lists) + (check-arg procedure? f for-each) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (begin + (apply f cars) ; Do head first, + (recur cdrs))))) ; then tail. + ;; Fast path. + (let recur ((lis lis1)) + (if (not (null-list? lis)) + (begin + (f (car lis)) ; Do head first, + (recur (cdr lis))))))) + ;;; fold.ss ends here diff --git a/collects/srfi/1/list.ss b/collects/srfi/1/list.ss index 771968242e..4112e919c2 100644 --- a/collects/srfi/1/list.ss +++ b/collects/srfi/1/list.ss @@ -1,4 +1,4 @@ -;;; SRFI-1 list-processing library -*- Scheme -*- +;;; SRFI-1 list-processing library -*- Scheme -*- ;;; Reference implementation ;;; ;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with @@ -17,25 +17,25 @@ ;;; for SRFI-1. See the porting notes below for more information. ;;; Exported: -;;; xcons tree-copy make-list list-tabulate cons* list-copy +;;; xcons tree-copy make-list list-tabulate cons* list-copy ;;; proper-list? circular-list? dotted-list? not-pair? null-list? list= ;;; circular-list length+ ;;; iota ;;; first second third fourth fifth sixth seventh eighth ninth tenth ;;; car+cdr -;;; take drop -;;; take-right drop-right +;;; take drop +;;; take-right drop-right ;;; take! drop-right! ;;; split-at split-at! ;;; last last-pair ;;; zip unzip1 unzip2 unzip3 unzip4 unzip5 ;;; count -;;; append! append-reverse append-reverse! concatenate concatenate! +;;; append! append-reverse append-reverse! concatenate concatenate! ;;; unfold fold pair-fold reduce ;;; unfold-right fold-right pair-fold-right reduce-right ;;; append-map append-map! map! pair-for-each filter-map map-in-order ;;; filter partition remove -;;; filter! partition! remove! +;;; filter! partition! remove! ;;; find find-tail any every list-index ;;; take-while drop-while take-while! ;;; span break span! break! @@ -43,11 +43,11 @@ ;;; alist-cons alist-copy ;;; delete-duplicates delete-duplicates! ;;; alist-delete alist-delete! -;;; reverse! -;;; lset<= lset= lset-adjoin +;;; reverse! +;;; lset<= lset= lset-adjoin ;;; lset-union lset-intersection lset-difference lset-xor lset-diff+intersection ;;; lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection! -;;; +;;; ;;; In principle, the following R4RS list- and pair-processing procedures ;;; are also part of this package's exports, although they are not defined ;;; in this file: @@ -60,7 +60,7 @@ ;;; in this file: ;;; map for-each member assoc ;;; -;;; The remaining two R4RS list-processing procedures are not included: +;;; The remaining two R4RS list-processing procedures are not included: ;;; list-tail (use drop) ;;; list? (use proper-list?) @@ -70,7 +70,7 @@ ;;; of the answer list in the wrong order (left-to-right or head-to-tail) from ;;; the order needed to cons them into the proper answer (right-to-left, or ;;; tail-then-head). One style or idiom of programming these algorithms, then, -;;; loops, consing up the elements in reverse order, then destructively +;;; loops, consing up the elements in reverse order, then destructively ;;; reverses the list at the end of the loop. I do not do this. The natural ;;; and efficient way to code these algorithms is recursively. This trades off ;;; intermediate temporary list structure for intermediate temporary stack @@ -83,16 +83,16 @@ ;;; This is carefully tuned code; do not modify casually. ;;; - It is careful to share storage when possible; ;;; - Side-effecting code tries not to perform redundant writes. -;;; +;;; ;;; That said, a port of this library to a specific Scheme system might wish -;;; to tune this code to exploit particulars of the implementation. +;;; to tune this code to exploit particulars of the implementation. ;;; The single most important compiler-specific optimisation you could make ;;; to this library would be to add rewrite rules or transforms to: ;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND, -;;; LSET-UNION) into multiple applications of a primitive two-argument +;;; LSET-UNION) into multiple applications of a primitive two-argument ;;; variant. -;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, -;;; ANY, EVERY) into open-coded loops. The killer here is that these +;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, +;;; ANY, EVERY) into open-coded loops. The killer here is that these ;;; functions are n-ary. Handling the general case is quite inefficient, ;;; requiring many intermediate data structures to be allocated and ;;; discarded. @@ -114,13 +114,13 @@ ;;; ;;; Note that this code is, of course, dependent upon standard bindings for ;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound -;;; to the procedure that takes the car of a list. If your Scheme +;;; to the procedure that takes the car of a list. If your Scheme ;;; implementation allows user code to alter the bindings of these procedures ;;; in a manner that would be visible to these definitions, then there might ;;; be trouble. You could consider horrible kludgery along the lines of -;;; (define fact +;;; (define fact ;;; (let ((= =) (- -) (* *)) -;;; (letrec ((real-fact (lambda (n) +;;; (letrec ((real-fact (lambda (n) ;;; (if (= n 0) 1 (* n (real-fact (- n 1))))))) ;;; real-fact))) ;;; Or you could consider shifting to a reasonable Scheme system that, say, @@ -130,18 +130,18 @@ ;;; Scheme system has a sophisticated compiler that can eliminate redundant ;;; error checks, this is no problem. However, if not, these checks incur ;;; some performance overhead -- and, in a safe Scheme implementation, they -;;; are in some sense redundant: if we don't check to see that the PROC +;;; are in some sense redundant: if we don't check to see that the PROC ;;; parameter is a procedure, we'll find out anyway three lines later when -;;; we try to call the value. It's pretty easy to rip all this argument +;;; we try to call the value. It's pretty easy to rip all this argument ;;; checking code out if it's inappropriate for your implementation -- just ;;; nuke every call to CHECK-ARG. ;;; ;;; On the other hand, if you *do* have a sophisticated compiler that will ;;; actually perform soft-typing and eliminate redundant checks (Rice's systems -;;; being the only possible candidate of which I'm aware), leaving these checks +;;; being the only possible candidate of which I'm aware), leaving these checks ;;; in can *help*, since their presence can be elided in redundant cases, ;;; and in cases where they are needed, performing the checks early, at -;;; procedure entry, can "lift" a check out of a loop. +;;; procedure entry, can "lift" a check out of a loop. ;;; ;;; Finally, I have only checked the properties that can portably be checked ;;; with R5RS Scheme -- and this is not complete. You may wish to alter @@ -197,7 +197,7 @@ ;;; the definition and implementation of this library. ;;; ;;; The argument *against* defining these procedures to work on dotted -;;; lists is that dotted lists are the rare, odd case, and that by +;;; lists is that dotted lists are the rare, odd case, and that by ;;; arranging for the procedures to handle them, we lose error checking ;;; in the cases where a dotted list is passed by accident -- e.g., when ;;; the programmer swaps a two arguments to a list-processing function, @@ -209,42 +209,35 @@ ;;; The SRFI discussion record contains more discussion on this topic. ;; JBC, 2003-10-20: some of the names provided by list.ss are prefixed -;; with an s: to avoid colliding with mzscheme. The wrapper 1.ss -;; changes their names back to the non-prefixed form. +;; with an s: to avoid colliding with mzscheme. The wrapper 1.ss +;; changes their names back to the non-prefixed form. -(module list mzscheme +#lang mzscheme - (require srfi/optional) +(require srfi/optional) - (require "cons.ss" - "selector.ss" - "predicate.ss" - "misc.ss" - (all-except "fold.ss" map for-each) - (rename "fold.ss" s:map map) - (rename "fold.ss" s:for-each for-each) - (all-except "search.ss" member) - (rename "search.ss" s:member member) - "filter.ss" - "delete.ss" - (all-except "alist.ss" assoc) - (rename "alist.ss" s:assoc assoc) - "lset.ss") +(require "cons.ss" + "selector.ss" + "predicate.ss" + "misc.ss" + (all-except "fold.ss" map for-each) + (rename "fold.ss" s:map map) + (rename "fold.ss" s:for-each for-each) + (all-except "search.ss" member) + (rename "search.ss" s:member member) + "filter.ss" + "delete.ss" + (all-except "alist.ss" assoc) + (rename "alist.ss" s:assoc assoc) + "lset.ss") - - (provide - (all-from "cons.ss") - (all-from "selector.ss") - (all-from "predicate.ss") - (all-from "misc.ss") - (all-from "fold.ss") - (all-from "search.ss") - (all-from "filter.ss") - (all-from "delete.ss") - (all-from "alist.ss") - (all-from "lset.ss")) - - - -;;end of the unit -) +(provide (all-from "cons.ss") + (all-from "selector.ss") + (all-from "predicate.ss") + (all-from "misc.ss") + (all-from "fold.ss") + (all-from "search.ss") + (all-from "filter.ss") + (all-from "delete.ss") + (all-from "alist.ss") + (all-from "lset.ss")) diff --git a/collects/srfi/1/lset.ss b/collects/srfi/1/lset.ss index 302c74d965..32ad141591 100644 --- a/collects/srfi/1/lset.ss +++ b/collects/srfi/1/lset.ss @@ -2,7 +2,7 @@ ;;; ---- Lists as Sets ;;; Time-stamp: <03/03/13 16:20:56 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -32,211 +32,201 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module lset - mzscheme +#lang mzscheme - (require srfi/optional - (all-except "search.ss" member) - (all-except "fold.ss" map for-each) - (rename "search.ss" s:member member) - "delete.ss" - "predicate.ss" - "filter.ss") - (require srfi/8/receive) +(require srfi/optional + (all-except "search.ss" member) + (all-except "fold.ss" map for-each) + (rename "search.ss" s:member member) + "delete.ss" + "predicate.ss" + "filter.ss" + srfi/8/receive) - (provide lset<= - lset= - lset-adjoin - lset-union - (rename lset-union lset-union!) - lset-intersection - lset-difference - (rename lset-difference lset-difference!) - lset-xor - (rename lset-xor lset-xor!) - lset-diff+intersection - (rename lset-diff+intersection lset-diff+intersection!)) +(provide lset<= + lset= + lset-adjoin + lset-union + (rename lset-union lset-union!) + lset-intersection + lset-difference + (rename lset-difference lset-difference!) + lset-xor + (rename lset-xor lset-xor!) + lset-diff+intersection + (rename lset-diff+intersection lset-diff+intersection!)) - ;; Lists-as-sets - ;;;;;;;;;;;;;;;;; +;; Lists-as-sets +;;;;;;;;;;;;;;;;; - ;; This is carefully tuned code; do not modify casually. - ;; - It is careful to share storage when possible; - ;; - Side-effecting code tries not to perform redundant writes. - ;; - It tries to avoid linear-time scans in special cases where constant-time - ;; computations can be performed. - ;; - It relies on similar properties from the other list-lib procs it calls. - ;; For example, it uses the fact that the implementations of MEMBER and - ;; FILTER in this source code share longest common tails between args - ;; and results to get structure sharing in the lset procedures. - - (define (%lset2<= = lis1 lis2) (every (lambda (x) (s:member x lis2 =)) lis1)) - - (define (lset<= = . lists) - (check-arg procedure? = 'lset<=) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) (rest (cdr rest))) - (and (or (eq? s2 s1) ; Fast path - (%lset2<= = s1 s2)) ; Real test - (lp s2 rest))))))) - - (define (lset= = . lists) - (check-arg procedure? = 'lset=) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) - (rest (cdr rest))) - (and (or (eq? s1 s2) ; Fast path - (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test - (lp s2 rest))))))) - - - (define (lset-adjoin = lis . elts) - (check-arg procedure? = 'lset-adjoin) - (fold (lambda (elt ans) (if (s:member elt ans =) ans (cons elt ans))) - lis elts)) - - - (define (lset-union = . lists) - (check-arg procedure? = 'lset-union) - (reduce (lambda (lis ans) ; Compute ANS + LIS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) - ans - (cons elt ans))) - ans lis)))) - '() lists)) - - #; - (define (lset-union! = . lists) - (check-arg procedure? = 'lset-union!) - (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (pair-fold (lambda (pair ans) - (let ((elt (car pair))) - (if (any (lambda (x) (= x elt)) ans) - ans - (begin (set-cdr! pair ans) pair)))) - ans lis)))) - '() lists)) - - - (define (lset-intersection = lis1 . lists) - (check-arg procedure? = 'lset-intersection) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (s:member x lis =)) lists)) - lis1))))) - - #; - (define (lset-intersection! = lis1 . lists) - (check-arg procedure? = 'lset-intersection!) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (s:member x lis =)) lists)) - lis1))))) - - - (define (lset-difference = lis1 . lists) - (check-arg procedure? = 'lset-difference) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (not (s:member x lis =))) - lists)) - lis1))))) - - #; - (define (lset-difference! = lis1 . lists) - (check-arg procedure? = 'lset-difference!) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (not (s:member x lis =))) - lists)) - lis1))))) - - - (define (lset-xor = . lists) - (check-arg procedure? = 'lset-xor) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection = a b) - (cond ((null? a-b) (lset-difference = b a)) - ((null? a-int-b) (append b a)) - (else (fold (lambda (xb ans) - (if (s:member xb a-int-b =) ans (cons xb ans))) - a-b - b))))) - '() lists)) - - #; - (define (lset-xor! = . lists) - (check-arg procedure? = 'lset-xor!) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection! = a b) - (cond ((null? a-b) (lset-difference! = b a)) - ((null? a-int-b) (append! b a)) - (else (pair-fold (lambda (b-pair ans) - (if (s:member (car b-pair) a-int-b =) ans - (begin (set-cdr! b-pair ans) b-pair))) - a-b - b))))) - '() lists)) - - - (define (lset-diff+intersection = lis1 . lists) - (check-arg procedure? = 'lset-diff+intersection) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition (lambda (elt) - (not (any (lambda (lis) (s:member elt lis =)) - lists))) - lis1)))) - - #; - (define (lset-diff+intersection! = lis1 . lists) - (check-arg procedure? = 'lset-diff+intersection!) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition! (lambda (elt) - (not (any (lambda (lis) (s:member elt lis =)) - lists))) - lis1)))) - - - ) +;; This is carefully tuned code; do not modify casually. +;; - It is careful to share storage when possible; +;; - Side-effecting code tries not to perform redundant writes. +;; - It tries to avoid linear-time scans in special cases where constant-time +;; computations can be performed. +;; - It relies on similar properties from the other list-lib procs it calls. +;; For example, it uses the fact that the implementations of MEMBER and +;; FILTER in this source code share longest common tails between args +;; and results to get structure sharing in the lset procedures. + +(define (%lset2<= = lis1 lis2) (every (lambda (x) (s:member x lis2 =)) lis1)) + +(define (lset<= = . lists) + (check-arg procedure? = 'lset<=) + (or (not (pair? lists)) ; 0-ary case + (let lp ((s1 (car lists)) (rest (cdr lists))) + (or (not (pair? rest)) + (let ((s2 (car rest)) (rest (cdr rest))) + (and (or (eq? s2 s1) ; Fast path + (%lset2<= = s1 s2)) ; Real test + (lp s2 rest))))))) + +(define (lset= = . lists) + (check-arg procedure? = 'lset=) + (or (not (pair? lists)) ; 0-ary case + (let lp ((s1 (car lists)) (rest (cdr lists))) + (or (not (pair? rest)) + (let ((s2 (car rest)) + (rest (cdr rest))) + (and (or (eq? s1 s2) ; Fast path + (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test + (lp s2 rest))))))) + +(define (lset-adjoin = lis . elts) + (check-arg procedure? = 'lset-adjoin) + (fold (lambda (elt ans) (if (s:member elt ans =) ans (cons elt ans))) + lis elts)) + +(define (lset-union = . lists) + (check-arg procedure? = 'lset-union) + (reduce (lambda (lis ans) ; Compute ANS + LIS. + (cond ((null? lis) ans) ; Don't copy any lists + ((null? ans) lis) ; if we don't have to. + ((eq? lis ans) ans) + (else + (fold (lambda (elt ans) + (if (any (lambda (x) (= x elt)) ans) + ans + (cons elt ans))) + ans lis)))) + '() lists)) + +#; +(define (lset-union! = . lists) + (check-arg procedure? = 'lset-union!) + (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. + (cond ((null? lis) ans) ; Don't copy any lists + ((null? ans) lis) ; if we don't have to. + ((eq? lis ans) ans) + (else + (pair-fold (lambda (pair ans) + (let ((elt (car pair))) + (if (any (lambda (x) (= x elt)) ans) + ans + (begin (set-cdr! pair ans) pair)))) + ans lis)))) + '() lists)) + +(define (lset-intersection = lis1 . lists) + (check-arg procedure? = 'lset-intersection) + (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. + (cond ((any null-list? lists) '()) ; Short cut + ((null? lists) lis1) ; Short cut + (else (filter (lambda (x) + (every (lambda (lis) (s:member x lis =)) lists)) + lis1))))) + +#; +(define (lset-intersection! = lis1 . lists) + (check-arg procedure? = 'lset-intersection!) + (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. + (cond ((any null-list? lists) '()) ; Short cut + ((null? lists) lis1) ; Short cut + (else (filter! (lambda (x) + (every (lambda (lis) (s:member x lis =)) lists)) + lis1))))) + +(define (lset-difference = lis1 . lists) + (check-arg procedure? = 'lset-difference) + (let ((lists (filter pair? lists))) ; Throw out empty lists. + (cond ((null? lists) lis1) ; Short cut + ((memq lis1 lists) '()) ; Short cut + (else (filter (lambda (x) + (every (lambda (lis) (not (s:member x lis =))) + lists)) + lis1))))) + +#; +(define (lset-difference! = lis1 . lists) + (check-arg procedure? = 'lset-difference!) + (let ((lists (filter pair? lists))) ; Throw out empty lists. + (cond ((null? lists) lis1) ; Short cut + ((memq lis1 lists) '()) ; Short cut + (else (filter! (lambda (x) + (every (lambda (lis) (not (s:member x lis =))) + lists)) + lis1))))) + +(define (lset-xor = . lists) + (check-arg procedure? = 'lset-xor) + (reduce (lambda (b a) ; Compute A xor B: + ;; Note that this code relies on the constant-time + ;; short-cuts provided by LSET-DIFF+INTERSECTION, + ;; LSET-DIFFERENCE & APPEND to provide constant-time short + ;; cuts for the cases A = (), B = (), and A eq? B. It takes + ;; a careful case analysis to see it, but it's carefully + ;; built in. + ;; Compute a-b and a^b, then compute b-(a^b) and + ;; cons it onto the front of a-b. + (receive (a-b a-int-b) (lset-diff+intersection = a b) + (cond ((null? a-b) (lset-difference = b a)) + ((null? a-int-b) (append b a)) + (else (fold (lambda (xb ans) + (if (s:member xb a-int-b =) ans (cons xb ans))) + a-b + b))))) + '() lists)) + +#; +(define (lset-xor! = . lists) + (check-arg procedure? = 'lset-xor!) + (reduce (lambda (b a) ; Compute A xor B: + ;; Note that this code relies on the constant-time + ;; short-cuts provided by LSET-DIFF+INTERSECTION, + ;; LSET-DIFFERENCE & APPEND to provide constant-time short + ;; cuts for the cases A = (), B = (), and A eq? B. It takes + ;; a careful case analysis to see it, but it's carefully + ;; built in. + ;; Compute a-b and a^b, then compute b-(a^b) and + ;; cons it onto the front of a-b. + (receive (a-b a-int-b) (lset-diff+intersection! = a b) + (cond ((null? a-b) (lset-difference! = b a)) + ((null? a-int-b) (append! b a)) + (else (pair-fold + (lambda (b-pair ans) + (if (s:member (car b-pair) a-int-b =) ans + (begin (set-cdr! b-pair ans) b-pair))) + a-b + b))))) + '() lists)) + +(define (lset-diff+intersection = lis1 . lists) + (check-arg procedure? = 'lset-diff+intersection) + (cond ((every null-list? lists) (values lis1 '())) ; Short cut + ((memq lis1 lists) (values '() lis1)) ; Short cut + (else (partition (lambda (elt) + (not (any (lambda (lis) (s:member elt lis =)) + lists))) + lis1)))) + +#; +(define (lset-diff+intersection! = lis1 . lists) + (check-arg procedure? = 'lset-diff+intersection!) + (cond ((every null-list? lists) (values lis1 '())) ; Short cut + ((memq lis1 lists) (values '() lis1)) ; Short cut + (else (partition! (lambda (elt) + (not (any (lambda (lis) (s:member elt lis =)) + lists))) + lis1)))) ;;; lset.ss ends here diff --git a/collects/srfi/1/misc.ss b/collects/srfi/1/misc.ss index 5b0d9cf47e..1d258844c0 100644 --- a/collects/srfi/1/misc.ss +++ b/collects/srfi/1/misc.ss @@ -2,7 +2,7 @@ ;;; ---- Miscellaneous list procedures ;;; Time-stamp: <02/03/01 13:52:22 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -32,171 +32,161 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module misc - mzscheme +#lang mzscheme - (require srfi/optional - "predicate.ss" - "selector.ss" - "util.ss" - (only "fold.ss" reduce-right) - (rename "fold.ss" srfi-1:map map)) - (require srfi/8/receive) +(require srfi/optional + "predicate.ss" + "selector.ss" + "util.ss" + (only "fold.ss" reduce-right) + (rename "fold.ss" srfi-1:map map) + srfi/8/receive) - (provide length+ - concatenate - (rename append append!) - (rename concatenate concatenate!) - (rename reverse reverse!) - append-reverse - (rename append-reverse append-reverse!) - zip - unzip1 - unzip2 - unzip3 - unzip4 - unzip5 - count) +(provide length+ + concatenate + (rename append append!) + (rename concatenate concatenate!) + (rename reverse reverse!) + append-reverse + (rename append-reverse append-reverse!) + zip + unzip1 + unzip2 + unzip3 + unzip4 + unzip5 + count) + +;; count +;;;;;;;; +(define (count pred list1 . lists) + (check-arg procedure? pred 'count) + (if (pair? lists) + ;; N-ary case + (let lp ((list1 list1) (lists lists) (i 0)) + (if (null-list? list1) i + (receive (as ds) (%cars+cdrs lists) + (if (null? as) i + (lp (cdr list1) ds + (if (apply pred (car list1) as) (+ i 1) i)))))) + ;; Fast path + (let lp ((lis list1) (i 0)) + (if (null-list? lis) i + (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) + +(define (length+ x) ; Returns #f if X is circular. + (let lp ((x x) (lag x) (len 0)) + (if (pair? x) + (let ((x (cdr x)) + (len (+ len 1))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag)) + (len (+ len 1))) + (and (not (eq? x lag)) (lp x lag len))) + len)) + len))) + +(define (zip list1 . more-lists) (apply srfi-1:map list list1 more-lists)) + +;; Unzippers -- 1 through 5 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (unzip1 lis) (map car lis)) + +(define (unzip2 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle + (let ((elt (car lis))) ; dotted lists. + (receive (a b) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b))))))) + +(define (unzip3 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis) + (let ((elt (car lis))) + (receive (a b c) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c))))))) + +(define (unzip4 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis lis) + (let ((elt (car lis))) + (receive (a b c d) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c) + (cons (cadddr elt) d))))))) + +(define (unzip5 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis lis lis) + (let ((elt (car lis))) + (receive (a b c d e) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c) + (cons (cadddr elt) d) + (cons (car (cddddr elt)) e))))))) + +;; append! append-reverse append-reverse! concatenate concatenate! +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#; +(define (my-append! . lists) + ;; First, scan through lists looking for a non-empty one. + (let lp ((lists lists) (prev '())) + (if (not (pair? lists)) prev + (let ((first (car lists)) + (rest (cdr lists))) + (if (not (pair? first)) (lp rest first) + ;; Now, do the splicing. + (let lp2 ((tail-cons (last-pair first)) + (rest rest)) + (if (pair? rest) + (let ((next (car rest)) + (rest (cdr rest))) + (set-cdr! tail-cons next) + (lp2 (if (pair? next) (last-pair next) tail-cons) + rest)) + first))))))) - ;; count - ;;;;;;;; - (define (count pred list1 . lists) - (check-arg procedure? pred 'count) - (if (pair? lists) +;;(define (append-reverse rev-head tail) (fold cons tail rev-head)) - ;; N-ary case - (let lp ((list1 list1) (lists lists) (i 0)) - (if (null-list? list1) i - (receive (as ds) (%cars+cdrs lists) - (if (null? as) i - (lp (cdr list1) ds - (if (apply pred (car list1) as) (+ i 1) i)))))) +;;(define (append-reverse! rev-head tail) +;; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) +;; tail +;; rev-head)) - ;; Fast path - (let lp ((lis list1) (i 0)) - (if (null-list? lis) i - (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) +;; Hand-inline the FOLD and PAIR-FOLD ops for speed. +(define (append-reverse rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (lp (cdr rev-head) (cons (car rev-head) tail))))) - (define (length+ x) ; Returns #f if X is circular. - (let lp ((x x) (lag x) (len 0)) - (if (pair? x) - (let ((x (cdr x)) - (len (+ len 1))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag)) - (len (+ len 1))) - (and (not (eq? x lag)) (lp x lag len))) - len)) - len))) +#; +(define (append-reverse! rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (let ((next-rev (cdr rev-head))) + (set-cdr! rev-head tail) + (lp next-rev rev-head))))) +(define (concatenate lists) (reduce-right append '() lists)) +#; +(define (concatenate! lists) (reduce-right my-append! '() lists)) +#; +(define (my-reverse! lis) + (let lp ((lis lis) (ans '())) + (if (null-list? lis) ans + (let ((tail (cdr lis))) + (set-cdr! lis ans) + (lp tail lis))))) - (define (zip list1 . more-lists) (apply srfi-1:map list list1 more-lists)) - - ;; Unzippers -- 1 through 5 - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (unzip1 lis) (map car lis)) - - (define (unzip2 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle - (let ((elt (car lis))) ; dotted lists. - (receive (a b) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b))))))) - - (define (unzip3 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis) - (let ((elt (car lis))) - (receive (a b c) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c))))))) - - (define (unzip4 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d))))))) - - (define (unzip5 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d e) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d) - (cons (car (cddddr elt)) e))))))) - - - ;; append! append-reverse append-reverse! concatenate concatenate! - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - #; - (define (my-append! . lists) - ;; First, scan through lists looking for a non-empty one. - (let lp ((lists lists) (prev '())) - (if (not (pair? lists)) prev - (let ((first (car lists)) - (rest (cdr lists))) - (if (not (pair? first)) (lp rest first) -; ;; Now, do the splicing. - (let lp2 ((tail-cons (last-pair first)) - (rest rest)) - (if (pair? rest) - (let ((next (car rest)) - (rest (cdr rest))) - (set-cdr! tail-cons next) - (lp2 (if (pair? next) (last-pair next) tail-cons) - rest)) - first))))))) - - - ;;(define (append-reverse rev-head tail) (fold cons tail rev-head)) - - ;;(define (append-reverse! rev-head tail) - ;; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) - ;; tail - ;; rev-head)) - - ;; Hand-inline the FOLD and PAIR-FOLD ops for speed. - - (define (append-reverse rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (lp (cdr rev-head) (cons (car rev-head) tail))))) - - #; - (define (append-reverse! rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (let ((next-rev (cdr rev-head))) - (set-cdr! rev-head tail) - (lp next-rev rev-head))))) - - - (define (concatenate lists) (reduce-right append '() lists)) - #; - (define (concatenate! lists) (reduce-right my-append! '() lists)) - - #; - (define (my-reverse! lis) - (let lp ((lis lis) (ans '())) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (set-cdr! lis ans) - (lp tail lis))))) - - ) ;;; misc.ss ends here diff --git a/collects/srfi/1/predicate.ss b/collects/srfi/1/predicate.ss index dc58692c68..2d361c9343 100644 --- a/collects/srfi/1/predicate.ss +++ b/collects/srfi/1/predicate.ss @@ -2,7 +2,7 @@ ;;; ---- List Predicates ;;; Time-stamp: <02/02/27 12:57:15 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -33,91 +33,86 @@ ;; -Olin -(module predicate - mzscheme +#lang mzscheme - (require srfi/optional) +(require srfi/optional) - (provide pair? - null? - proper-list? - circular-list? - dotted-list? - not-pair? - null-list? - list=) +(provide pair? + null? + proper-list? + circular-list? + dotted-list? + not-pair? + null-list? + list=) + +;; ::= () ; Empty proper list +;; | (cons ) ; Proper-list pair +;; Note that this definition rules out circular lists -- and this +;; function is required to detect this case and return false. + +(define (proper-list? x) + (let lp ((x x) (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) (lp x lag))) + (null? x))) + (null? x)))) + +;; A dotted list is a finite list (possibly of length 0) terminated +;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5) +;; is a dotted list of length 0. +;; +;; ::= ; Empty dotted list +;; | (cons ) ; Proper-list pair + +(define (dotted-list? x) + (let lp ((x x) (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) (lp x lag))) + (not (null? x)))) + (not (null? x))))) + +(define (circular-list? x) + (let lp ((x x) (lag x)) + (and (pair? x) + (let ((x (cdr x))) + (and (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (or (eq? x lag) (lp x lag)))))))) + +(define (not-pair? x) (not (pair? x))) ; Inline me. + +;; This is a legal definition which is fast and sloppy: +;; (define null-list? not-pair?) +;; but we'll provide a more careful one: +(define (null-list? l) + (cond ((pair? l) #f) + ((null? l) #t) + (else (error "null-list?: argument out of domain" l)))) + +(define (list= = . lists) + (or (null? lists) ; special case + (let lp1 ((list-a (car lists)) (others (cdr lists))) + (or (null? others) + (let ((list-b (car others)) + (others (cdr others))) + (if (eq? list-a list-b) ; EQ? => LIST= + (lp1 list-b others) + (let lp2 ((la list-a) (lb list-b)) + (if (null-list? la) + (and (null-list? lb) + (lp1 list-b others)) + (and (not (null-list? lb)) + (= (car la) (car lb)) + (lp2 (cdr la) (cdr lb))))))))))) - ;; ::= () ; Empty proper list - ;; | (cons ) ; Proper-list pair - ;; Note that this definition rules out circular lists -- and this - ;; function is required to detect this case and return false. - - (define (proper-list? x) - (let lp ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (lp x lag))) - (null? x))) - (null? x)))) - - - ;; A dotted list is a finite list (possibly of length 0) terminated - ;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5) - ;; is a dotted list of length 0. - ;; - ;; ::= ; Empty dotted list - ;; | (cons ) ; Proper-list pair - - (define (dotted-list? x) - (let lp ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (lp x lag))) - (not (null? x)))) - (not (null? x))))) - - (define (circular-list? x) - (let lp ((x x) (lag x)) - (and (pair? x) - (let ((x (cdr x))) - (and (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (or (eq? x lag) (lp x lag)))))))) - - (define (not-pair? x) (not (pair? x))) ; Inline me. - - ;; This is a legal definition which is fast and sloppy: - ;; (define null-list? not-pair?) - ;; but we'll provide a more careful one: - (define (null-list? l) - (cond ((pair? l) #f) - ((null? l) #t) - (else (error "null-list?: argument out of domain" l)))) - - - (define (list= = . lists) - (or (null? lists) ; special case - (let lp1 ((list-a (car lists)) (others (cdr lists))) - (or (null? others) - (let ((list-b (car others)) - (others (cdr others))) - (if (eq? list-a list-b) ; EQ? => LIST= - (lp1 list-b others) - (let lp2 ((la list-a) (lb list-b)) - (if (null-list? la) - (and (null-list? lb) - (lp1 list-b others)) - (and (not (null-list? lb)) - (= (car la) (car lb)) - (lp2 (cdr la) (cdr lb))))))))))) - - ) - ;;; predicate.ss ends here diff --git a/collects/srfi/1/search.ss b/collects/srfi/1/search.ss index b7923434cd..25e6ff6e6a 100644 --- a/collects/srfi/1/search.ss +++ b/collects/srfi/1/search.ss @@ -2,7 +2,7 @@ ;;; ---- List searching functions ;;; Time-stamp: <02/02/28 12:11:01 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -32,124 +32,118 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module search - mzscheme +#lang mzscheme - (require mzlib/etc - srfi/optional - "predicate.ss" - "util.ss") - (require srfi/8/receive) +(require mzlib/etc + srfi/optional + "predicate.ss" + "util.ss" + srfi/8/receive) - (provide (rename my-member member) - find - find-tail - any - every - list-index - take-while - drop-while - (rename take-while take-while!) - span - break - (rename span span!) - (rename break break!)) +(provide (rename my-member member) + find + find-tail + any + every + list-index + take-while + drop-while + (rename take-while take-while!) + span + break + (rename span span!) + (rename break break!)) - ;; Extended from R4RS to take an optional comparison argument. - (define my-member - (opt-lambda (x lis (maybe-= equal?)) - (let ((= maybe-=)) - (find-tail (lambda (y) (= x y)) lis)))) +;; Extended from R4RS to take an optional comparison argument. +(define my-member + (opt-lambda (x lis (maybe-= equal?)) + (let ((= maybe-=)) + (find-tail (lambda (y) (= x y)) lis)))) - ;; find find-tail take-while drop-while span break any every list-index - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; find find-tail take-while drop-while span break any every list-index +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define (find pred list) - (cond ((find-tail pred list) => car) - (else #f))) +(define (find pred list) + (cond ((find-tail pred list) => car) + (else #f))) - (define (find-tail pred list) - (check-arg procedure? pred 'find-tail) - (let lp ((list list)) - (and (not (null-list? list)) - (if (pred (car list)) list - (lp (cdr list)))))) - - (define (take-while pred lis) - (check-arg procedure? pred 'take-while) - (let recur ((lis lis)) - (if (null-list? lis) '() - (let ((x (car lis))) - (if (pred x) - (cons x (recur (cdr lis))) - '()))))) - - (define (drop-while pred lis) - (check-arg procedure? pred 'drop-while) - (let lp ((lis lis)) - (if (null-list? lis) '() - (if (pred (car lis)) - (lp (cdr lis)) - lis)))) - - #; - (define (take-while! pred lis) - (check-arg procedure? pred 'take-while!) - (if (or (null-list? lis) (not (pred (car lis)))) '() - (begin (let lp ((prev lis) (rest (cdr lis))) - (if (pair? rest) - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (set-cdr! prev '()))))) - lis))) - - (define (span pred lis) - (check-arg procedure? pred 'span) - (let recur ((lis lis)) - (if (null-list? lis) (values '() '()) - (let ((x (car lis))) - (if (pred x) - (receive (prefix suffix) (recur (cdr lis)) - (values (cons x prefix) suffix)) - (values '() lis)))))) +(define (find-tail pred list) + (check-arg procedure? pred 'find-tail) + (let lp ((list list)) + (and (not (null-list? list)) + (if (pred (car list)) list + (lp (cdr list)))))) + +(define (take-while pred lis) + (check-arg procedure? pred 'take-while) + (let recur ((lis lis)) + (if (null-list? lis) '() + (let ((x (car lis))) + (if (pred x) + (cons x (recur (cdr lis))) + '()))))) + +(define (drop-while pred lis) + (check-arg procedure? pred 'drop-while) + (let lp ((lis lis)) + (cond ((null-list? lis) '()) + ((pred (car lis)) (lp (cdr lis))) + (else lis)))) #; - (define (span! pred lis) - (check-arg procedure? pred 'span!) - (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) - (let ((suffix (let lp ((prev lis) (rest (cdr lis))) - (if (null-list? rest) rest - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (begin (set-cdr! prev '()) - rest))))))) - (values lis suffix)))) - - - (define (break pred lis) (span (lambda (x) (not (pred x))) lis)) - #; - (define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) - - (define (any pred lis1 . lists) - (check-arg procedure? pred 'any) - (if (pair? lists) - - ;; N-ary case - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (and (pair? heads) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (or (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) ; Last PRED app is tail call. - - ;; Fast path - (and (not (null-list? lis1)) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) ; Last PRED app is tail call. - (or (pred head) (lp (car tail) (cdr tail)))))))) +(define (take-while! pred lis) + (check-arg procedure? pred 'take-while!) + (if (or (null-list? lis) (not (pred (car lis)))) '() + (begin (let lp ((prev lis) (rest (cdr lis))) + (if (pair? rest) + (let ((x (car rest))) + (if (pred x) (lp rest (cdr rest)) + (set-cdr! prev '()))))) + lis))) +(define (span pred lis) + (check-arg procedure? pred 'span) + (let recur ((lis lis)) + (if (null-list? lis) (values '() '()) + (let ((x (car lis))) + (if (pred x) + (receive (prefix suffix) (recur (cdr lis)) + (values (cons x prefix) suffix)) + (values '() lis)))))) + +#; +(define (span! pred lis) + (check-arg procedure? pred 'span!) + (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) + (let ((suffix (let lp ((prev lis) (rest (cdr lis))) + (if (null-list? rest) rest + (let ((x (car rest))) + (if (pred x) (lp rest (cdr rest)) + (begin (set-cdr! prev '()) + rest))))))) + (values lis suffix)))) + +(define (break pred lis) (span (lambda (x) (not (pred x))) lis)) +#; +(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) + +(define (any pred lis1 . lists) + (check-arg procedure? pred 'any) + (if (pair? lists) + ;; N-ary case + (receive (heads tails) (%cars+cdrs (cons lis1 lists)) + (and (pair? heads) + (let lp ((heads heads) (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (or (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))) ; Last PRED app is tail call. + ;; Fast path + (and (not (null-list? lis1)) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null-list? tail) + (pred head) ; Last PRED app is tail call. + (or (pred head) (lp (car tail) (cdr tail)))))))) ;(define (every pred list) ; Simple definition. ; (let lp ((list list)) ; Doesn't return the last PRED value. @@ -157,41 +151,36 @@ ; (and (pred (car list)) ; (lp (cdr list)))))) - (define (every pred lis1 . lists) - (check-arg procedure? pred 'every) - (if (pair? lists) - - ;; N-ary case - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (or (not (pair? heads)) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (and (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) ; Last PRED app is tail call. - - ;; Fast path - (or (null-list? lis1) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) ; Last PRED app is tail call. - (and (pred head) (lp (car tail) (cdr tail)))))))) +(define (every pred lis1 . lists) + (check-arg procedure? pred 'every) + (if (pair? lists) + ;; N-ary case + (receive (heads tails) (%cars+cdrs (cons lis1 lists)) + (or (not (pair? heads)) + (let lp ((heads heads) (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (and (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))) ; Last PRED app is tail call. + ;; Fast path + (or (null-list? lis1) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null-list? tail) + (pred head) ; Last PRED app is tail call. + (and (pred head) (lp (car tail) (cdr tail)))))))) - (define (list-index pred lis1 . lists) - (check-arg procedure? pred 'list-index) - (if (pair? lists) - - ;; N-ary case - (let lp ((lists (cons lis1 lists)) (n 0)) - (receive (heads tails) (%cars+cdrs lists) - (and (pair? heads) - (if (apply pred heads) n - (lp tails (+ n 1)))))) +(define (list-index pred lis1 . lists) + (check-arg procedure? pred 'list-index) + (if (pair? lists) + ;; N-ary case + (let lp ((lists (cons lis1 lists)) (n 0)) + (receive (heads tails) (%cars+cdrs lists) + (and (pair? heads) + (if (apply pred heads) n + (lp tails (+ n 1)))))) + ;; Fast path + (let lp ((lis lis1) (n 0)) + (and (not (null-list? lis)) + (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) - ;; Fast path - (let lp ((lis lis1) (n 0)) - (and (not (null-list? lis)) - (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) - - ) ;;; search.ss ends here diff --git a/collects/srfi/1/selector.ss b/collects/srfi/1/selector.ss index 3e399cdaeb..3e57b06980 100644 --- a/collects/srfi/1/selector.ss +++ b/collects/srfi/1/selector.ss @@ -2,7 +2,7 @@ ;;; ---- List selectors ;;; Time-stamp: <02/02/27 12:49:44 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -32,119 +32,112 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module selector - mzscheme +#lang mzscheme - (require srfi/optional) - (require srfi/8/receive) +(require srfi/optional + srfi/8/receive) - (provide - first second - third fourth - fifth sixth - seventh eighth - ninth tenth - car+cdr - take drop - take-right drop-right - (rename take take!) (rename drop-right drop-right!) - split-at (rename split-at split-at!) - last - last-pair) +(provide first second + third fourth + fifth sixth + seventh eighth + ninth tenth + car+cdr + take drop + take-right drop-right + (rename take take!) (rename drop-right drop-right!) + split-at (rename split-at split-at!) + last + last-pair) - (define first car) - (define second cadr) - (define third caddr) - (define fourth cadddr) - (define (fifth x) (car (cddddr x))) - (define (sixth x) (cadr (cddddr x))) - (define (seventh x) (caddr (cddddr x))) - (define (eighth x) (cadddr (cddddr x))) - (define (ninth x) (car (cddddr (cddddr x)))) - (define (tenth x) (cadr (cddddr (cddddr x)))) - - (define (car+cdr pair) (values (car pair) (cdr pair))) +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) +(define (fifth x) (car (cddddr x))) +(define (sixth x) (cadr (cddddr x))) +(define (seventh x) (caddr (cddddr x))) +(define (eighth x) (cadddr (cddddr x))) +(define (ninth x) (car (cddddr (cddddr x)))) +(define (tenth x) (cadr (cddddr (cddddr x)))) + +(define (car+cdr pair) (values (car pair) (cdr pair))) + +;; take & drop + +(define (take lis k) + (check-arg integer? k 'take) + (let recur ((lis lis) (k k)) + (if (zero? k) '() + (cons (car lis) + (recur (cdr lis) (- k 1)))))) + +(define (drop lis k) + (check-arg integer? k 'drop) + (let iter ((lis lis) (k k)) + (if (zero? k) lis (iter (cdr lis) (- k 1))))) + +#; +(define (take! lis k) + (check-arg integer? k 'take!) + (if (zero? k) '() + (begin (set-cdr! (drop lis (- k 1)) '()) + lis))) + +;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, +;; off by K, then chasing down the list until the lead pointer falls off +;; the end. + +(define (take-right lis k) + (check-arg integer? k 'take-right) + (let lp ((lag lis) (lead (drop lis k))) + (if (pair? lead) + (lp (cdr lag) (cdr lead)) + lag))) + +(define (drop-right lis k) + (check-arg integer? k 'drop-right) + (let recur ((lag lis) (lead (drop lis k))) + (if (pair? lead) + (cons (car lag) (recur (cdr lag) (cdr lead))) + '()))) + +;; In this function, LEAD is actually K+1 ahead of LAG. This lets +;; us stop LAG one step early, in time to smash its cdr to (). +#; +(define (drop-right! lis k) + (check-arg integer? k 'drop-right!) + (let ((lead (drop lis k))) + (if (pair? lead) + (let lp ((lag lis) (lead (cdr lead))) ; Standard case + (if (pair? lead) + (lp (cdr lag) (cdr lead)) + (begin (set-cdr! lag '()) + lis))) + '()))) ; Special case dropping everything -- no cons to side-effect. + +(define (split-at x k) + (check-arg integer? k 'split-at) + (let recur ((lis x) (k k)) + (if (zero? k) (values '() lis) + (receive (prefix suffix) (recur (cdr lis) (- k 1)) + (values (cons (car lis) prefix) suffix))))) + +#; +(define (split-at! x k) + (check-arg integer? k 'split-at!) + (if (zero? k) (values '() x) + (let* ((prev (drop x (- k 1))) + (suffix (cdr prev))) + (set-cdr! prev '()) + (values x suffix)))) + +(define (last lis) (car (last-pair lis))) + +(define (last-pair lis) + (check-arg pair? lis 'last-pair) + (let lp ((lis lis)) + (let ((tail (cdr lis))) + (if (pair? tail) (lp tail) lis)))) - ;; take & drop - - (define (take lis k) - (check-arg integer? k 'take) - (let recur ((lis lis) (k k)) - (if (zero? k) '() - (cons (car lis) - (recur (cdr lis) (- k 1)))))) - - (define (drop lis k) - (check-arg integer? k 'drop) - (let iter ((lis lis) (k k)) - (if (zero? k) lis (iter (cdr lis) (- k 1))))) - - #; - (define (take! lis k) - (check-arg integer? k 'take!) - (if (zero? k) '() - (begin (set-cdr! (drop lis (- k 1)) '()) - lis))) - - ;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, - ;; off by K, then chasing down the list until the lead pointer falls off - ;; the end. - - (define (take-right lis k) - (check-arg integer? k 'take-right) - (let lp ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (lp (cdr lag) (cdr lead)) - lag))) - - (define (drop-right lis k) - (check-arg integer? k 'drop-right) - (let recur ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (cons (car lag) (recur (cdr lag) (cdr lead))) - '()))) - - ;; In this function, LEAD is actually K+1 ahead of LAG. This lets - ;; us stop LAG one step early, in time to smash its cdr to (). - #; - (define (drop-right! lis k) - (check-arg integer? k 'drop-right!) - (let ((lead (drop lis k))) - (if (pair? lead) - - (let lp ((lag lis) (lead (cdr lead))) ; Standard case - (if (pair? lead) - (lp (cdr lag) (cdr lead)) - (begin (set-cdr! lag '()) - lis))) - - '()))) ; Special case dropping everything -- no cons to side-effect. - - (define (split-at x k) - (check-arg integer? k 'split-at) - (let recur ((lis x) (k k)) - (if (zero? k) (values '() lis) - (receive (prefix suffix) (recur (cdr lis) (- k 1)) - (values (cons (car lis) prefix) suffix))))) - - #; - (define (split-at! x k) - (check-arg integer? k 'split-at!) - (if (zero? k) (values '() x) - (let* ((prev (drop x (- k 1))) - (suffix (cdr prev))) - (set-cdr! prev '()) - (values x suffix)))) - - - (define (last lis) (car (last-pair lis))) - - (define (last-pair lis) - (check-arg pair? lis 'last-pair) - (let lp ((lis lis)) - (let ((tail (cdr lis))) - (if (pair? tail) (lp tail) lis)))) - - - ) ;;; selector.ss ends here diff --git a/collects/srfi/1/util.ss b/collects/srfi/1/util.ss index 1feeb8f75c..704a30f871 100644 --- a/collects/srfi/1/util.ss +++ b/collects/srfi/1/util.ss @@ -2,7 +2,7 @@ ;;; ---- Utility functions ;;; Time-stamp: <02/02/28 12:05:00 noel> ;;; -;;; Copyright (C) 2002 by Noel Welsh. +;;; Copyright (C) 2002 by Noel Welsh. ;;; ;;; This file is part of SRFI-1. @@ -32,94 +32,91 @@ ;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. ;; -Olin -(module util - mzscheme +#lang mzscheme - (require srfi/optional - "predicate.ss" - "selector.ss") - (require srfi/8/receive) +(require srfi/optional + "predicate.ss" + "selector.ss" + srfi/8/receive) - (provide %cdrs - %cars+ - %cars+cdrs - %cars+cdrs+ - %cars+cdrs/no-test) +(provide %cdrs + %cars+ + %cars+cdrs + %cars+cdrs+ + %cars+cdrs/no-test) - ;; Fold/map internal utilities - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; These little internal utilities are used by the general - ;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined. - ;; One the other hand, the n-ary cases are painfully inefficient as it is. - ;; An aggressive implementation should simply re-write these functions - ;; for raw efficiency; I have written them for as much clarity, portability, - ;; and simplicity as can be achieved. - ;; - ;; I use the dreaded call/cc to do local aborts. A good compiler could - ;; handle this with extreme efficiency. An implementation that provides - ;; a one-shot, non-persistent continuation grabber could help the compiler - ;; out by using that in place of the call/cc's in these routines. - ;; - ;; These functions have funky definitions that are precisely tuned to - ;; the needs of the fold/map procs -- for example, to minimize the number - ;; of times the argument lists need to be examined. - - ;; Return (map cdr lists). - ;; However, if any element of LISTS is empty, just abort and return '(). - (define (%cdrs lists) - (call-with-escape-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (let ((lis (car lists))) - (if (null-list? lis) (abort '()) - (cons (cdr lis) (recur (cdr lists))))) - '()))))) - - (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) - (let recur ((lists lists)) - (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) - - ;; LISTS is a (not very long) non-empty list of lists. - ;; Return two lists: the cars & the cdrs of the lists. - ;; However, if any of the lists is empty, just abort and return [() ()]. - - (define (%cars+cdrs lists) - (call-with-escape-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values '() '())))))) - - ;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the - ;; cars list. What a hack. - (define (%cars+cdrs+ lists cars-final) - (call-with-escape-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values (list cars-final) '())))))) - - ;; Like %CARS+CDRS, but blow up if any list is empty. - (define (%cars+cdrs/no-test lists) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs))))) - (values '() '())))) - - ) +;; Fold/map internal utilities +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; These little internal utilities are used by the general +;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined. +;; One the other hand, the n-ary cases are painfully inefficient as it is. +;; An aggressive implementation should simply re-write these functions +;; for raw efficiency; I have written them for as much clarity, portability, +;; and simplicity as can be achieved. +;; +;; I use the dreaded call/cc to do local aborts. A good compiler could +;; handle this with extreme efficiency. An implementation that provides +;; a one-shot, non-persistent continuation grabber could help the compiler +;; out by using that in place of the call/cc's in these routines. +;; +;; These functions have funky definitions that are precisely tuned to +;; the needs of the fold/map procs -- for example, to minimize the number +;; of times the argument lists need to be examined. + +;; Return (map cdr lists). +;; However, if any element of LISTS is empty, just abort and return '(). +(define (%cdrs lists) + (call-with-escape-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (let ((lis (car lists))) + (if (null-list? lis) (abort '()) + (cons (cdr lis) (recur (cdr lists))))) + '()))))) + +(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) + (let recur ((lists lists)) + (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) + +;; LISTS is a (not very long) non-empty list of lists. +;; Return two lists: the cars & the cdrs of the lists. +;; However, if any of the lists is empty, just abort and return [() ()]. + +(define (%cars+cdrs lists) + (call-with-escape-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs)))))) + (values '() '())))))) + +;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the +;; cars list. What a hack. +(define (%cars+cdrs+ lists cars-final) + (call-with-escape-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs)))))) + (values (list cars-final) '())))))) + +;; Like %CARS+CDRS, but blow up if any list is empty. +(define (%cars+cdrs/no-test lists) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs))))) + (values '() '())))) ;;; util.ss ends here