fix rotting indentation, switch to #lang
svn: r8987
This commit is contained in:
Eli Barzilay
parent
696f8a24ba
commit
38ba4f29e8
|
|
@ -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
|
||||
(require mzlib/etc
|
||||
srfi/optional
|
||||
(only "search.ss" find)
|
||||
"filter.ss"
|
||||
(rename "fold.ss" s:map map))
|
||||
|
||||
(provide (rename my-assoc assoc)
|
||||
(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
|
||||
;; 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)
|
||||
(define (alist-copy alist)
|
||||
(s:map (lambda (elt) (cons (car elt) (cdr elt)))
|
||||
alist))
|
||||
|
||||
(define alist-delete
|
||||
(define alist-delete
|
||||
(opt-lambda (key alist (maybe-= equal?))
|
||||
(let ((= maybe-=))
|
||||
(filter (lambda (elt) (not (= key (car elt)))) alist))))
|
||||
|
||||
#;
|
||||
(define alist-delete!
|
||||
#;
|
||||
(define alist-delete!
|
||||
(opt-lambda (key alist (maybe-= equal?))
|
||||
(let ((= maybe-=))
|
||||
(filter! (lambda (elt) (not (= key (car elt)))) alist))))
|
||||
|
||||
)
|
||||
|
||||
;;; alist.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,14 +32,13 @@
|
|||
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
|
||||
;; -Olin
|
||||
|
||||
(module cons
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require mzlib/etc
|
||||
(require mzlib/etc
|
||||
srfi/optional
|
||||
"selector.ss")
|
||||
|
||||
(provide xcons
|
||||
(provide xcons
|
||||
make-list
|
||||
list-tabulate
|
||||
cons*
|
||||
|
|
@ -47,64 +46,57 @@
|
|||
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
|
||||
(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.
|
||||
|
||||
;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
|
||||
|
||||
(define (list-tabulate len proc)
|
||||
(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))
|
||||
;; (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)
|
||||
(define (cons* first . rest)
|
||||
(let recur ((x first) (rest rest))
|
||||
(if (pair? rest)
|
||||
(cons x (recur (car rest) (cdr rest)))
|
||||
x)))
|
||||
|
||||
|
||||
(define (list-copy lis)
|
||||
(define (list-copy lis)
|
||||
(let recur ((lis lis))
|
||||
(if (pair? lis)
|
||||
(cons (car lis) (recur (cdr lis)))
|
||||
lis)))
|
||||
|
||||
|
||||
(define (circular-list val1 . vals)
|
||||
(define (circular-list val1 . vals)
|
||||
(let ([ph (make-placeholder #f)])
|
||||
(placeholder-set! ph
|
||||
(cons val1
|
||||
(let loop ([vals vals])
|
||||
(cons val1 (let loop ([vals vals])
|
||||
(if (null? vals)
|
||||
ph
|
||||
(cons (car vals)
|
||||
(loop (cdr vals)))))))
|
||||
(cons (car vals) (loop (cdr vals)))))))
|
||||
(make-reader-graph ph)))
|
||||
|
||||
;; IOTA count [start step] (start start+step ... start+(count-1)*step)
|
||||
|
||||
;; IOTA count [start step] (start start+step ... start+(count-1)*step)
|
||||
|
||||
(define iota
|
||||
(define iota
|
||||
(opt-lambda (count [start 0] [step 1])
|
||||
(check-arg integer? count 'iota)
|
||||
(check-arg number? start 'iota)
|
||||
|
|
@ -112,12 +104,7 @@
|
|||
(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)))]))))
|
||||
|
||||
|
||||
)
|
||||
(if (= n count) '()
|
||||
(cons (+ start (* n step)) (loop (add1 n)))))))
|
||||
|
||||
;;; cons.ss ends here
|
||||
|
|
|
|||
|
|
@ -33,40 +33,39 @@
|
|||
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
|
||||
;; -Olin
|
||||
|
||||
(module delete
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require mzlib/etc
|
||||
(require mzlib/etc
|
||||
srfi/optional
|
||||
"predicate.ss"
|
||||
"filter.ss")
|
||||
|
||||
(provide delete
|
||||
(provide delete
|
||||
(rename delete delete!)
|
||||
delete-duplicates
|
||||
(rename delete-duplicates delete-duplicates!))
|
||||
|
||||
(define delete
|
||||
(define delete
|
||||
(opt-lambda (x lis (maybe-= equal?))
|
||||
(let ((= maybe-=))
|
||||
(filter (lambda (y) (not (= x y))) lis))))
|
||||
|
||||
#;
|
||||
(define delete!
|
||||
#;
|
||||
(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
|
||||
(define delete-duplicates
|
||||
(opt-lambda (lis (maybe-= equal?))
|
||||
(let ((elt= maybe-=))
|
||||
(check-arg procedure? elt= 'delete-duplicates)
|
||||
|
|
@ -77,8 +76,8 @@
|
|||
(new-tail (recur (delete x tail elt=))))
|
||||
(if (eq? tail new-tail) lis (cons x new-tail))))))))
|
||||
|
||||
#;
|
||||
(define delete-duplicates!
|
||||
#;
|
||||
(define delete-duplicates!
|
||||
(opt-lambda (lis (maybe-= equal?))
|
||||
(let ((elt= maybe-=))
|
||||
(check-arg procedure? elt= 'delete-duplicates!)
|
||||
|
|
@ -89,7 +88,4 @@
|
|||
(new-tail (recur (delete! x tail elt=))))
|
||||
(if (eq? tail new-tail) lis (cons x new-tail))))))))
|
||||
|
||||
)
|
||||
|
||||
|
||||
;;; delete.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,32 +32,30 @@
|
|||
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
|
||||
;; -Olin
|
||||
|
||||
(module filter
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require mzlib/etc
|
||||
(require mzlib/etc
|
||||
srfi/optional
|
||||
"predicate.ss")
|
||||
(require srfi/8/receive)
|
||||
"predicate.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide filter
|
||||
(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
|
||||
(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.
|
||||
|
|
@ -69,25 +67,20 @@
|
|||
(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)
|
||||
;; 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
|
||||
|
|
@ -114,11 +107,9 @@
|
|||
(scan-in ans (cdr ans))
|
||||
ans)))))
|
||||
|
||||
|
||||
|
||||
;; Answers share common tail with LIS where possible;
|
||||
;; the technique is slightly subtle.
|
||||
(define (partition pred lis)
|
||||
;; 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.
|
||||
|
|
@ -129,21 +120,18 @@
|
|||
(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)
|
||||
;; 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.
|
||||
|
|
@ -156,7 +144,6 @@
|
|||
(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)
|
||||
|
|
@ -165,7 +152,6 @@
|
|||
(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.
|
||||
|
|
@ -174,7 +160,6 @@
|
|||
((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))
|
||||
|
|
@ -183,11 +168,9 @@
|
|||
(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))
|
||||
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -32,16 +32,15 @@
|
|||
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
|
||||
;; -Olin
|
||||
|
||||
(module fold
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require srfi/optional
|
||||
(require srfi/optional
|
||||
"predicate.ss"
|
||||
"selector.ss"
|
||||
"util.ss")
|
||||
(require srfi/8/receive)
|
||||
"util.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide (rename my-map map)
|
||||
(provide (rename my-map map)
|
||||
(rename my-for-each for-each)
|
||||
fold
|
||||
unfold
|
||||
|
|
@ -58,11 +57,10 @@
|
|||
filter-map
|
||||
map-in-order)
|
||||
|
||||
;; fold/unfold
|
||||
;;;;;;;;;;;;;;
|
||||
|
||||
;; fold/unfold
|
||||
;;;;;;;;;;;;;;
|
||||
|
||||
(define (unfold-right p f g seed . maybe-tail)
|
||||
(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)
|
||||
|
|
@ -71,40 +69,33 @@
|
|||
(lp (g seed)
|
||||
(cons (f seed) ans)))))
|
||||
|
||||
|
||||
(define (unfold p f g seed . maybe-tail-gen)
|
||||
(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)
|
||||
(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)
|
||||
(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
|
||||
|
|
@ -117,41 +108,37 @@
|
|||
(let ((head (car lis)))
|
||||
(kons head (recur (cdr lis))))))))
|
||||
|
||||
|
||||
(define (pair-fold-right f zero lis1 . lists)
|
||||
(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)
|
||||
(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.
|
||||
|
||||
;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
|
||||
;; These cannot meaningfully be n-ary.
|
||||
|
||||
(define (reduce f ridentity lis)
|
||||
(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)
|
||||
(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)))
|
||||
|
|
@ -159,18 +146,16 @@
|
|||
(f head (recur (car lis) (cdr lis)))
|
||||
head))))
|
||||
|
||||
;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (append-map f lis1 . lists)
|
||||
(define (append-map f lis1 . lists)
|
||||
(really-append-map append-map append f lis1 lists))
|
||||
#;
|
||||
(define (append-map! 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)
|
||||
(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))
|
||||
|
|
@ -180,7 +165,6 @@
|
|||
(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)))
|
||||
|
|
@ -188,17 +172,14 @@
|
|||
(if (null-list? rest) vals
|
||||
(appender vals (recur (car rest) (cdr rest)))))))))
|
||||
|
||||
|
||||
(define (pair-for-each proc lis1 . lists)
|
||||
(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))
|
||||
|
|
@ -206,9 +187,9 @@
|
|||
(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)
|
||||
;; 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))
|
||||
|
|
@ -216,14 +197,12 @@
|
|||
(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)
|
||||
;; 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)))
|
||||
|
|
@ -232,7 +211,6 @@
|
|||
(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
|
||||
|
|
@ -240,12 +218,11 @@
|
|||
(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.
|
||||
|
||||
;; 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)
|
||||
(define (map-in-order f lis1 . lists)
|
||||
(check-arg procedure? f 'map-in-order)
|
||||
(if (pair? lists)
|
||||
(let recur ((lists (cons lis1 lists)))
|
||||
|
|
@ -254,7 +231,6 @@
|
|||
(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
|
||||
|
|
@ -262,16 +238,15 @@
|
|||
(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)
|
||||
;; 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)
|
||||
(define (my-for-each f lis1 . lists)
|
||||
(check-arg procedure? f for-each)
|
||||
(if (pair? lists)
|
||||
(let recur ((lists (cons lis1 lists)))
|
||||
|
|
@ -280,12 +255,11 @@
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -212,11 +212,11 @@
|
|||
;; 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"
|
||||
(require "cons.ss"
|
||||
"selector.ss"
|
||||
"predicate.ss"
|
||||
"misc.ss"
|
||||
|
|
@ -231,9 +231,7 @@
|
|||
(rename "alist.ss" s:assoc assoc)
|
||||
"lset.ss")
|
||||
|
||||
|
||||
(provide
|
||||
(all-from "cons.ss")
|
||||
(provide (all-from "cons.ss")
|
||||
(all-from "selector.ss")
|
||||
(all-from "predicate.ss")
|
||||
(all-from "misc.ss")
|
||||
|
|
@ -243,8 +241,3 @@
|
|||
(all-from "delete.ss")
|
||||
(all-from "alist.ss")
|
||||
(all-from "lset.ss"))
|
||||
|
||||
|
||||
|
||||
;;end of the unit
|
||||
)
|
||||
|
|
|
|||
|
|
@ -32,19 +32,18 @@
|
|||
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
|
||||
;; -Olin
|
||||
|
||||
(module lset
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require srfi/optional
|
||||
(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)
|
||||
"filter.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide lset<=
|
||||
(provide lset<=
|
||||
lset=
|
||||
lset-adjoin
|
||||
lset-union
|
||||
|
|
@ -57,22 +56,22 @@
|
|||
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.
|
||||
;; 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 (%lset2<= = lis1 lis2) (every (lambda (x) (s:member x lis2 =)) lis1))
|
||||
|
||||
(define (lset<= = . lists)
|
||||
(define (lset<= = . lists)
|
||||
(check-arg procedure? = 'lset<=)
|
||||
(or (not (pair? lists)) ; 0-ary case
|
||||
(let lp ((s1 (car lists)) (rest (cdr lists)))
|
||||
|
|
@ -82,7 +81,7 @@
|
|||
(%lset2<= = s1 s2)) ; Real test
|
||||
(lp s2 rest)))))))
|
||||
|
||||
(define (lset= = . lists)
|
||||
(define (lset= = . lists)
|
||||
(check-arg procedure? = 'lset=)
|
||||
(or (not (pair? lists)) ; 0-ary case
|
||||
(let lp ((s1 (car lists)) (rest (cdr lists)))
|
||||
|
|
@ -93,28 +92,27 @@
|
|||
(and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test
|
||||
(lp s2 rest)))))))
|
||||
|
||||
|
||||
(define (lset-adjoin = lis . elts)
|
||||
(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)
|
||||
(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)
|
||||
(fold (lambda (elt ans)
|
||||
(if (any (lambda (x) (= x elt)) ans)
|
||||
ans
|
||||
(cons elt ans)))
|
||||
ans lis))))
|
||||
'() lists))
|
||||
|
||||
#;
|
||||
(define (lset-union! = . 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
|
||||
|
|
@ -129,8 +127,7 @@
|
|||
ans lis))))
|
||||
'() lists))
|
||||
|
||||
|
||||
(define (lset-intersection = lis1 . 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
|
||||
|
|
@ -139,8 +136,8 @@
|
|||
(every (lambda (lis) (s:member x lis =)) lists))
|
||||
lis1)))))
|
||||
|
||||
#;
|
||||
(define (lset-intersection! = lis1 . 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
|
||||
|
|
@ -149,8 +146,7 @@
|
|||
(every (lambda (lis) (s:member x lis =)) lists))
|
||||
lis1)))))
|
||||
|
||||
|
||||
(define (lset-difference = lis1 . lists)
|
||||
(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
|
||||
|
|
@ -160,8 +156,8 @@
|
|||
lists))
|
||||
lis1)))))
|
||||
|
||||
#;
|
||||
(define (lset-difference! = lis1 . lists)
|
||||
#;
|
||||
(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
|
||||
|
|
@ -171,8 +167,7 @@
|
|||
lists))
|
||||
lis1)))))
|
||||
|
||||
|
||||
(define (lset-xor = . 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
|
||||
|
|
@ -181,7 +176,6 @@
|
|||
;; 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)
|
||||
|
|
@ -193,8 +187,8 @@
|
|||
b)))))
|
||||
'() lists))
|
||||
|
||||
#;
|
||||
(define (lset-xor! = . 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
|
||||
|
|
@ -203,21 +197,20 @@
|
|||
;; 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)
|
||||
(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)
|
||||
(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
|
||||
|
|
@ -226,8 +219,8 @@
|
|||
lists)))
|
||||
lis1))))
|
||||
|
||||
#;
|
||||
(define (lset-diff+intersection! = lis1 . 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
|
||||
|
|
@ -236,7 +229,4 @@
|
|||
lists)))
|
||||
lis1))))
|
||||
|
||||
|
||||
)
|
||||
|
||||
;;; lset.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,18 +32,17 @@
|
|||
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
|
||||
;; -Olin
|
||||
|
||||
(module misc
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require srfi/optional
|
||||
(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)
|
||||
(rename "fold.ss" srfi-1:map map)
|
||||
srfi/8/receive)
|
||||
|
||||
(provide length+
|
||||
(provide length+
|
||||
concatenate
|
||||
(rename append append!)
|
||||
(rename concatenate concatenate!)
|
||||
|
|
@ -58,13 +57,11 @@
|
|||
unzip5
|
||||
count)
|
||||
|
||||
|
||||
;; count
|
||||
;;;;;;;;
|
||||
(define (count pred list1 . lists)
|
||||
;; 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
|
||||
|
|
@ -72,14 +69,12 @@
|
|||
(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.
|
||||
(define (length+ x) ; Returns #f if X is circular.
|
||||
(let lp ((x x) (lag x) (len 0))
|
||||
(if (pair? x)
|
||||
(let ((x (cdr x))
|
||||
|
|
@ -92,16 +87,14 @@
|
|||
len))
|
||||
len)))
|
||||
|
||||
(define (zip list1 . more-lists) (apply srfi-1:map list list1 more-lists))
|
||||
|
||||
;; Unzippers -- 1 through 5
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (zip list1 . more-lists) (apply srfi-1:map list list1 more-lists))
|
||||
(define (unzip1 lis) (map car lis))
|
||||
|
||||
;; Unzippers -- 1 through 5
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (unzip1 lis) (map car lis))
|
||||
|
||||
(define (unzip2 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.
|
||||
|
|
@ -109,7 +102,7 @@
|
|||
(values (cons (car elt) a)
|
||||
(cons (cadr elt) b)))))))
|
||||
|
||||
(define (unzip3 lis)
|
||||
(define (unzip3 lis)
|
||||
(let recur ((lis lis))
|
||||
(if (null-list? lis) (values lis lis lis)
|
||||
(let ((elt (car lis)))
|
||||
|
|
@ -118,7 +111,7 @@
|
|||
(cons (cadr elt) b)
|
||||
(cons (caddr elt) c)))))))
|
||||
|
||||
(define (unzip4 lis)
|
||||
(define (unzip4 lis)
|
||||
(let recur ((lis lis))
|
||||
(if (null-list? lis) (values lis lis lis lis)
|
||||
(let ((elt (car lis)))
|
||||
|
|
@ -128,7 +121,7 @@
|
|||
(cons (caddr elt) c)
|
||||
(cons (cadddr elt) d)))))))
|
||||
|
||||
(define (unzip5 lis)
|
||||
(define (unzip5 lis)
|
||||
(let recur ((lis lis))
|
||||
(if (null-list? lis) (values lis lis lis lis lis)
|
||||
(let ((elt (car lis)))
|
||||
|
|
@ -139,19 +132,18 @@
|
|||
(cons (cadddr elt) d)
|
||||
(cons (car (cddddr elt)) e)))))))
|
||||
|
||||
;; append! append-reverse append-reverse! concatenate concatenate!
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; append! append-reverse append-reverse! concatenate concatenate!
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
#;
|
||||
(define (my-append! . lists)
|
||||
#;
|
||||
(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.
|
||||
;; Now, do the splicing.
|
||||
(let lp2 ((tail-cons (last-pair first))
|
||||
(rest rest))
|
||||
(if (pair? rest)
|
||||
|
|
@ -163,40 +155,38 @@
|
|||
first)))))))
|
||||
|
||||
|
||||
;;(define (append-reverse rev-head tail) (fold cons tail rev-head))
|
||||
;;(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))
|
||||
;;(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.
|
||||
;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
|
||||
|
||||
(define (append-reverse rev-head tail)
|
||||
(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)
|
||||
#;
|
||||
(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 (concatenate lists) (reduce-right append '() lists))
|
||||
#;
|
||||
(define (concatenate! lists) (reduce-right my-append! '() lists))
|
||||
|
||||
#;
|
||||
(define (my-reverse! lis)
|
||||
#;
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -33,12 +33,11 @@
|
|||
;; -Olin
|
||||
|
||||
|
||||
(module predicate
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require srfi/optional)
|
||||
(require srfi/optional)
|
||||
|
||||
(provide pair?
|
||||
(provide pair?
|
||||
null?
|
||||
proper-list?
|
||||
circular-list?
|
||||
|
|
@ -47,12 +46,12 @@
|
|||
null-list?
|
||||
list=)
|
||||
|
||||
;; <proper-list> ::= () ; Empty proper list
|
||||
;; | (cons <x> <proper-list>) ; Proper-list pair
|
||||
;; Note that this definition rules out circular lists -- and this
|
||||
;; function is required to detect this case and return false.
|
||||
;; <proper-list> ::= () ; Empty proper list
|
||||
;; | (cons <x> <proper-list>) ; 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)
|
||||
(define (proper-list? x)
|
||||
(let lp ((x x) (lag x))
|
||||
(if (pair? x)
|
||||
(let ((x (cdr x)))
|
||||
|
|
@ -63,15 +62,14 @@
|
|||
(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.
|
||||
;;
|
||||
;; <dotted-list> ::= <non-nil,non-pair> ; Empty dotted list
|
||||
;; | (cons <x> <dotted-list>) ; Proper-list pair
|
||||
|
||||
;; 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.
|
||||
;;
|
||||
;; <dotted-list> ::= <non-nil,non-pair> ; Empty dotted list
|
||||
;; | (cons <x> <dotted-list>) ; Proper-list pair
|
||||
|
||||
(define (dotted-list? x)
|
||||
(define (dotted-list? x)
|
||||
(let lp ((x x) (lag x))
|
||||
(if (pair? x)
|
||||
(let ((x (cdr x)))
|
||||
|
|
@ -82,7 +80,7 @@
|
|||
(not (null? x))))
|
||||
(not (null? x)))))
|
||||
|
||||
(define (circular-list? x)
|
||||
(define (circular-list? x)
|
||||
(let lp ((x x) (lag x))
|
||||
(and (pair? x)
|
||||
(let ((x (cdr x)))
|
||||
|
|
@ -91,18 +89,17 @@
|
|||
(lag (cdr lag)))
|
||||
(or (eq? x lag) (lp x lag))))))))
|
||||
|
||||
(define (not-pair? x) (not (pair? x))) ; Inline me.
|
||||
(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)
|
||||
;; 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)
|
||||
(define (list= = . lists)
|
||||
(or (null? lists) ; special case
|
||||
(let lp1 ((list-a (car lists)) (others (cdr lists)))
|
||||
(or (null? others)
|
||||
|
|
@ -118,6 +115,4 @@
|
|||
(= (car la) (car lb))
|
||||
(lp2 (cdr la) (cdr lb)))))))))))
|
||||
|
||||
)
|
||||
|
||||
;;; predicate.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,16 +32,15 @@
|
|||
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
|
||||
;; -Olin
|
||||
|
||||
(module search
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require mzlib/etc
|
||||
(require mzlib/etc
|
||||
srfi/optional
|
||||
"predicate.ss"
|
||||
"util.ss")
|
||||
(require srfi/8/receive)
|
||||
"util.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide (rename my-member member)
|
||||
(provide (rename my-member member)
|
||||
find
|
||||
find-tail
|
||||
any
|
||||
|
|
@ -55,27 +54,27 @@
|
|||
(rename span span!)
|
||||
(rename break break!))
|
||||
|
||||
;; Extended from R4RS to take an optional comparison argument.
|
||||
(define my-member
|
||||
;; 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)
|
||||
(define (find pred list)
|
||||
(cond ((find-tail pred list) => car)
|
||||
(else #f)))
|
||||
|
||||
(define (find-tail pred list)
|
||||
(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)
|
||||
(define (take-while pred lis)
|
||||
(check-arg procedure? pred 'take-while)
|
||||
(let recur ((lis lis))
|
||||
(if (null-list? lis) '()
|
||||
|
|
@ -84,16 +83,15 @@
|
|||
(cons x (recur (cdr lis)))
|
||||
'())))))
|
||||
|
||||
(define (drop-while pred 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))))
|
||||
(cond ((null-list? lis) '())
|
||||
((pred (car lis)) (lp (cdr lis)))
|
||||
(else lis))))
|
||||
|
||||
#;
|
||||
(define (take-while! pred 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)))
|
||||
|
|
@ -103,7 +101,7 @@
|
|||
(set-cdr! prev '())))))
|
||||
lis)))
|
||||
|
||||
(define (span pred lis)
|
||||
(define (span pred lis)
|
||||
(check-arg procedure? pred 'span)
|
||||
(let recur ((lis lis))
|
||||
(if (null-list? lis) (values '() '())
|
||||
|
|
@ -114,7 +112,7 @@
|
|||
(values '() lis))))))
|
||||
|
||||
#;
|
||||
(define (span! pred 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)))
|
||||
|
|
@ -125,15 +123,13 @@
|
|||
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 (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)
|
||||
(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)
|
||||
|
|
@ -142,7 +138,6 @@
|
|||
(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)))
|
||||
|
|
@ -150,17 +145,15 @@
|
|||
(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.
|
||||
; (or (not (pair? list))
|
||||
; (and (pred (car list))
|
||||
; (lp (cdr list))))))
|
||||
|
||||
(define (every pred lis1 . lists)
|
||||
(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))
|
||||
|
|
@ -169,7 +162,6 @@
|
|||
(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)))
|
||||
|
|
@ -177,21 +169,18 @@
|
|||
(pred head) ; Last PRED app is tail call.
|
||||
(and (pred head) (lp (car tail) (cdr tail))))))))
|
||||
|
||||
(define (list-index pred lis1 . lists)
|
||||
(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)))))))
|
||||
|
||||
)
|
||||
;;; search.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,14 +32,12 @@
|
|||
;; 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
|
||||
(provide first second
|
||||
third fourth
|
||||
fifth sixth
|
||||
seventh eighth
|
||||
|
|
@ -52,83 +50,81 @@
|
|||
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 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 (car+cdr pair) (values (car pair) (cdr pair)))
|
||||
|
||||
;; take & drop
|
||||
;; take & drop
|
||||
|
||||
(define (take lis k)
|
||||
(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)
|
||||
(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)
|
||||
#;
|
||||
(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.
|
||||
;; 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)
|
||||
(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)
|
||||
(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)
|
||||
;; 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)
|
||||
(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)
|
||||
#;
|
||||
(define (split-at! x k)
|
||||
(check-arg integer? k 'split-at!)
|
||||
(if (zero? k) (values '() x)
|
||||
(let* ((prev (drop x (- k 1)))
|
||||
|
|
@ -136,15 +132,12 @@
|
|||
(set-cdr! prev '())
|
||||
(values x suffix))))
|
||||
|
||||
(define (last lis) (car (last-pair lis)))
|
||||
|
||||
(define (last lis) (car (last-pair lis)))
|
||||
|
||||
(define (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
|
||||
|
|
|
|||
|
|
@ -32,41 +32,40 @@
|
|||
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
|
||||
;; -Olin
|
||||
|
||||
(module util
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require srfi/optional
|
||||
(require srfi/optional
|
||||
"predicate.ss"
|
||||
"selector.ss")
|
||||
(require srfi/8/receive)
|
||||
"selector.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide %cdrs
|
||||
(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.
|
||||
;; 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)
|
||||
;; 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))
|
||||
|
|
@ -76,15 +75,15 @@
|
|||
(cons (cdr lis) (recur (cdr lists)))))
|
||||
'())))))
|
||||
|
||||
(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt))
|
||||
(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 [() ()].
|
||||
;; 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)
|
||||
(define (%cars+cdrs lists)
|
||||
(call-with-escape-continuation
|
||||
(lambda (abort)
|
||||
(let recur ((lists lists))
|
||||
|
|
@ -96,9 +95,9 @@
|
|||
(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)
|
||||
;; 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))
|
||||
|
|
@ -110,8 +109,8 @@
|
|||
(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)
|
||||
;; 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)
|
||||
|
|
@ -120,6 +119,4 @@
|
|||
(values (cons a cars) (cons d cdrs)))))
|
||||
(values '() '()))))
|
||||
|
||||
)
|
||||
|
||||
;;; util.ss ends here
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user