fix rotting indentation, switch to #lang
svn: r8987
This commit is contained in:
Eli Barzilay
parent
696f8a24ba
commit
38ba4f29e8
|
|
@ -32,8 +32,7 @@
|
|||
;; 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
|
||||
|
|
@ -47,7 +46,6 @@
|
|||
alist-delete
|
||||
#;alist-delete!)
|
||||
|
||||
|
||||
;; Extended from R4RS to take an optional comparison argument.
|
||||
(define my-assoc
|
||||
(opt-lambda (x lis (maybe-= equal?))
|
||||
|
|
@ -71,6 +69,4 @@
|
|||
(let ((= maybe-=))
|
||||
(filter! (lambda (elt) (not (= key (car elt)))) alist))))
|
||||
|
||||
)
|
||||
|
||||
;;; alist.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,8 +32,7 @@
|
|||
;; 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
|
||||
|
|
@ -51,7 +50,6 @@
|
|||
;; higher-order procedure.
|
||||
(define (xcons d a) (cons a d))
|
||||
|
||||
|
||||
;; Make a list of length LEN.
|
||||
|
||||
(define make-list
|
||||
|
|
@ -61,7 +59,6 @@
|
|||
(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)
|
||||
|
|
@ -72,7 +69,7 @@
|
|||
((< i 0) ans)))
|
||||
|
||||
;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
|
||||
;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
|
||||
;; (cons* a1) = a1; (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
|
||||
;;
|
||||
;; (cons first (unfold not-pair? car cdr rest values))
|
||||
|
||||
|
|
@ -82,26 +79,21 @@
|
|||
(cons x (recur (car rest) (cdr rest)))
|
||||
x)))
|
||||
|
||||
|
||||
(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])
|
||||
(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)
|
||||
|
||||
(define 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,8 +33,7 @@
|
|||
;; 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
|
||||
|
|
@ -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,13 +32,12 @@
|
|||
;; 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)
|
||||
"predicate.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide filter
|
||||
partition
|
||||
|
|
@ -47,7 +46,6 @@
|
|||
(rename partition partition!)
|
||||
(rename remove remove!))
|
||||
|
||||
|
||||
;; filter, remove, partition
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
|
||||
|
|
@ -69,10 +67,6 @@
|
|||
(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
|
||||
|
|
@ -87,7 +81,6 @@
|
|||
(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,8 +107,6 @@
|
|||
(scan-in ans (cdr ans))
|
||||
ans)))))
|
||||
|
||||
|
||||
|
||||
;; Answers share common tail with LIS where possible;
|
||||
;; the technique is slightly subtle.
|
||||
(define (partition pred lis)
|
||||
|
|
@ -129,8 +120,6 @@
|
|||
(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
|
||||
|
|
@ -143,7 +132,6 @@
|
|||
(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))
|
||||
|
||||
)
|
||||
;;; filter.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,14 +32,13 @@
|
|||
;; 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)
|
||||
"util.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide (rename my-map map)
|
||||
(rename my-for-each for-each)
|
||||
|
|
@ -58,7 +57,6 @@
|
|||
filter-map
|
||||
map-in-order)
|
||||
|
||||
|
||||
;; fold/unfold
|
||||
;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -71,26 +69,21 @@
|
|||
(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)
|
||||
|
|
@ -98,12 +91,10 @@
|
|||
(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)
|
||||
|
|
@ -117,7 +108,6 @@
|
|||
(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)
|
||||
|
|
@ -125,7 +115,6 @@
|
|||
(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)))))))
|
||||
|
||||
|
|
@ -136,13 +125,11 @@
|
|||
(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.
|
||||
|
||||
|
|
@ -159,8 +146,6 @@
|
|||
(f head (recur (car lis) (cdr lis)))
|
||||
head))))
|
||||
|
||||
|
||||
|
||||
;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -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)
|
||||
(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))
|
||||
|
|
@ -216,12 +197,10 @@
|
|||
(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)
|
||||
|
|
@ -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,7 +218,6 @@
|
|||
(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.
|
||||
|
|
@ -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,7 +238,6 @@
|
|||
(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)
|
||||
|
||||
|
|
@ -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,7 +212,7 @@
|
|||
;; 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)
|
||||
|
||||
|
|
@ -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,8 +32,7 @@
|
|||
;; 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)
|
||||
|
|
@ -41,8 +40,8 @@
|
|||
(rename "search.ss" s:member member)
|
||||
"delete.ss"
|
||||
"predicate.ss"
|
||||
"filter.ss")
|
||||
(require srfi/8/receive)
|
||||
"filter.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide lset<=
|
||||
lset=
|
||||
|
|
@ -93,13 +92,11 @@
|
|||
(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.
|
||||
|
|
@ -107,7 +104,8 @@
|
|||
((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))))
|
||||
|
|
@ -129,7 +127,6 @@
|
|||
ans lis))))
|
||||
'() lists))
|
||||
|
||||
|
||||
(define (lset-intersection = lis1 . lists)
|
||||
(check-arg procedure? = 'lset-intersection)
|
||||
(let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
|
||||
|
|
@ -149,7 +146,6 @@
|
|||
(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.
|
||||
|
|
@ -171,7 +167,6 @@
|
|||
lists))
|
||||
lis1)))))
|
||||
|
||||
|
||||
(define (lset-xor = . lists)
|
||||
(check-arg procedure? = 'lset-xor)
|
||||
(reduce (lambda (b a) ; Compute A xor B:
|
||||
|
|
@ -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)
|
||||
|
|
@ -203,20 +197,19 @@
|
|||
;; 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)
|
||||
(check-arg procedure? = 'lset-diff+intersection)
|
||||
(cond ((every null-list? lists) (values lis1 '())) ; Short cut
|
||||
|
|
@ -236,7 +229,4 @@
|
|||
lists)))
|
||||
lis1))))
|
||||
|
||||
|
||||
)
|
||||
|
||||
;;; lset.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,16 +32,15 @@
|
|||
;; 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)
|
||||
(rename "fold.ss" srfi-1:map map)
|
||||
srfi/8/receive)
|
||||
|
||||
(provide length+
|
||||
concatenate
|
||||
|
|
@ -58,13 +57,11 @@
|
|||
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
|
||||
|
|
@ -72,13 +69,11 @@
|
|||
(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)
|
||||
|
|
@ -92,8 +87,6 @@
|
|||
len))
|
||||
len)))
|
||||
|
||||
|
||||
|
||||
(define (zip list1 . more-lists) (apply srfi-1:map list list1 more-lists))
|
||||
|
||||
;; Unzippers -- 1 through 5
|
||||
|
|
@ -139,7 +132,6 @@
|
|||
(cons (cadddr elt) d)
|
||||
(cons (car (cddddr elt)) e)))))))
|
||||
|
||||
|
||||
;; append! append-reverse append-reverse! concatenate concatenate!
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -151,7 +143,7 @@
|
|||
(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)
|
||||
|
|
@ -185,7 +177,6 @@
|
|||
(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))
|
||||
|
|
@ -198,5 +189,4 @@
|
|||
(set-cdr! lis ans)
|
||||
(lp tail lis)))))
|
||||
|
||||
)
|
||||
;;; misc.ss ends here
|
||||
|
|
|
|||
|
|
@ -33,8 +33,7 @@
|
|||
;; -Olin
|
||||
|
||||
|
||||
(module predicate
|
||||
mzscheme
|
||||
#lang mzscheme
|
||||
|
||||
(require srfi/optional)
|
||||
|
||||
|
|
@ -63,7 +62,6 @@
|
|||
(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.
|
||||
|
|
@ -101,7 +99,6 @@
|
|||
((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)))
|
||||
|
|
@ -118,6 +115,4 @@
|
|||
(= (car la) (car lb))
|
||||
(lp2 (cdr la) (cdr lb)))))))))))
|
||||
|
||||
)
|
||||
|
||||
;;; predicate.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,14 +32,13 @@
|
|||
;; 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)
|
||||
"util.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide (rename my-member member)
|
||||
find
|
||||
|
|
@ -87,10 +86,9 @@
|
|||
(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)
|
||||
|
|
@ -125,7 +123,6 @@
|
|||
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))
|
||||
|
|
@ -133,7 +130,6 @@
|
|||
(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,7 +145,6 @@
|
|||
(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))
|
||||
|
|
@ -160,7 +154,6 @@
|
|||
(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)))
|
||||
|
|
@ -180,18 +172,15 @@
|
|||
(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
|
||||
|
|
@ -111,13 +109,11 @@
|
|||
(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)
|
||||
|
|
@ -136,7 +132,6 @@
|
|||
(set-cdr! prev '())
|
||||
(values x suffix))))
|
||||
|
||||
|
||||
(define (last lis) (car (last-pair lis)))
|
||||
|
||||
(define (last-pair lis)
|
||||
|
|
@ -145,6 +140,4 @@
|
|||
(let ((tail (cdr lis)))
|
||||
(if (pair? tail) (lp tail) lis))))
|
||||
|
||||
|
||||
)
|
||||
;;; selector.ss ends here
|
||||
|
|
|
|||
|
|
@ -32,13 +32,12 @@
|
|||
;; 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)
|
||||
"selector.ss"
|
||||
srfi/8/receive)
|
||||
|
||||
(provide %cdrs
|
||||
%cars+
|
||||
|
|
@ -120,6 +119,4 @@
|
|||
(values (cons a cars) (cons d cdrs)))))
|
||||
(values '() '()))))
|
||||
|
||||
)
|
||||
|
||||
;;; util.ss ends here
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user