suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

switched to scheme/base

Browse Source 
svn: r8992
This commit is contained in:
Eli Barzilay 2008-03-16 17:24:48 +00:00
parent ca7586e09f
commit 883908580c
13 changed files with 128 additions and 208 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/srfi/1/alist.ss
View File

@ -32,41 +32,30 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require mzlib/etc
srfi/optional
(only "search.ss" find)
"filter.ss"
(rename "fold.ss" s:map map))
(require (only-in "search.ss" find))
(provide (rename my-assoc assoc)
(provide (rename-out [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))))
(define (my-assoc x lis [= equal?])
(find (lambda (entry) (= x (car entry))) lis))
(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))
(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 key alist [= equal?])
(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! key alist [= equal?])
(filter! (lambda (elt) (not (= key (car elt)))) alist))
;;; alist.ss ends here

38
collects/srfi/1/cons.ss
View File

@ -32,11 +32,9 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require mzlib/etc
srfi/optional
"selector.ss")
(require srfi/optional "selector.ss")
(provide xcons
make-list
@ -52,21 +50,16 @@
;; 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 len [elt #f])
(check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list)
(for/list ([i (in-range len)]) elt))
;; 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)))
(for/list ([i (in-range len)]) (proc i)))
;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
;; (cons* a1) = a1; (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
@ -96,15 +89,14 @@
;; 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)))))))
(define (iota 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

61
collects/srfi/1/delete.ss
View File

@ -33,28 +33,19 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require mzlib/etc
srfi/optional
"predicate.ss"
"filter.ss")
(require srfi/optional "predicate.ss")
(provide delete
(rename delete delete!)
delete-duplicates
(rename delete-duplicates delete-duplicates!))
(provide delete (rename-out [delete delete!])
delete-duplicates (rename-out [delete-duplicates delete-duplicates!]))
(define delete
(opt-lambda (x lis (maybe-= equal?))
(let ((= maybe-=))
(filter (lambda (y) (not (= x y))) lis))))
(define (delete x lis [= equal?])
(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! (x lis [= equal?])
(filter! (lambda (y) (not (= x y))) lis))
;; right-duplicate deletion
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -65,27 +56,23 @@
;; 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 lis [elt= equal?])
(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! lis [elt= equal?])
(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

19
collects/srfi/1/filter.ss
View File

@ -32,18 +32,13 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require mzlib/etc
srfi/optional
"predicate.ss")
(require srfi/optional "predicate.ss")
(provide filter
partition
remove
(rename filter filter!)
(rename partition partition!)
(rename remove remove!))
(provide (rename-out [my-filter filter] [my-filter filter!])
partition (rename-out [partition partition!])
(rename-out [my-remove remove] [my-remove remove!]))
;; filter, remove, partition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -54,7 +49,7 @@
;; elements. If Scheme had multi-continuation calls, they could be
;; made more efficient.
(define (filter pred lis) ; Sleazing with EQ? makes this
(define (my-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.
@ -168,7 +163,7 @@
(else (lp l (cdr l)))))))))
;; Inline us, please.
(define (remove pred l) (filter (lambda (x) (not (pred x))) l))
(define (my-remove pred l) (filter (lambda (x) (not (pred x))) l))
#;
(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))

30
collects/srfi/1/fold.ss
View File

@ -32,15 +32,15 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require srfi/optional
"predicate.ss"
"selector.ss"
"util.ss")
(provide (rename my-map map)
(rename my-for-each for-each)
(provide (rename-out [my-map map])
(rename-out [my-for-each for-each])
fold
unfold
pair-fold
@ -50,8 +50,8 @@
pair-fold-right
reduce-right
append-map
(rename append-map append-map!)
(rename my-map map!)
(rename-out [append-map append-map!])
(rename-out [my-map map!])
pair-for-each
filter-map
map-in-order)
@ -176,12 +176,10 @@
(if (pair? lists)
(let lp ((lists (cons lis1 lists)))
(let ((tails (%cdrs lists)))
(if (pair? tails)
(begin (apply proc lists)
(lp tails)))))
(when (pair? tails) (apply proc lists) (lp tails))))
;; Fast path.
(let lp ((lis lis1))
(if (not (null-list? lis))
(unless (null-list? lis)
(let ((tail (cdr lis))) ; Grab the cdr now,
(proc lis) ; in case PROC SET-CDR!s LIS.
(lp tail))))))
@ -250,15 +248,13 @@
(if (pair? lists)
(let recur ((lists (cons lis1 lists)))
(let-values ([(cars cdrs) (%cars+cdrs lists)])
(if (pair? cars)
(begin
(apply f cars) ; Do head first,
(recur cdrs))))) ; then tail.
(when (pair? cars)
(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)))))))
(unless (null-list? lis)
(f (car lis)) ; Do head first,
(recur (cdr lis))))))
;;; fold.ss ends here

14
collects/srfi/1/info.ss
View File

@ -1,14 +0,0 @@
#lang setup/infotab
(define compile-omit-paths
'("alist-test.ss"
"all-srfi-1-tests.ss"
"cons-test.ss"
"delete-test.ss"
"filter-test.ss"
"fold-test.ss"
"lset-test.ss"
"misc-test.ss"
"predicate-test.ss"
"search-test.ss"
"selector-test.ss"))

36
collects/srfi/1/list.ss
View File

@ -212,32 +212,26 @@
;; with an s: to avoid colliding with mzscheme. The wrapper 1.ss
;; changes their names back to the non-prefixed form.
#lang mzscheme
(require srfi/optional)
#lang scheme/base
(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"
(rename-in "fold.ss" [map s:map] [for-each s:for-each])
(rename-in "search.ss" [member s:member])
(rename-in "filter.ss" [filter s:filter] [remove s:remove])
"delete.ss"
(all-except "alist.ss" assoc)
(rename "alist.ss" s:assoc assoc)
(rename-in "alist.ss" [assoc s: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"))
(provide (all-from-out "cons.ss")
(all-from-out "selector.ss")
(all-from-out "predicate.ss")
(all-from-out "misc.ss")
(all-from-out "fold.ss")
(all-from-out "search.ss")
(all-from-out "filter.ss")
(all-from-out "delete.ss")
(all-from-out "alist.ss")
(all-from-out "lset.ss"))

20
collects/srfi/1/lset.ss
View File

@ -32,28 +32,24 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require srfi/optional
(all-except "search.ss" member)
(all-except "fold.ss" map for-each)
(rename "search.ss" s:member member)
(rename-in "search.ss" [member s:member])
(except-in "fold.ss" map for-each)
"delete.ss"
"predicate.ss"
"filter.ss")
(except-in "filter.ss" remove filter))
(provide lset<=
lset=
lset-adjoin
lset-union
(rename lset-union lset-union!)
lset-union (rename-out [lset-union lset-union!])
lset-intersection
lset-difference
(rename lset-difference lset-difference!)
lset-xor
(rename lset-xor lset-xor!)
lset-difference (rename-out [lset-difference lset-difference!])
lset-xor (rename-out [lset-xor lset-xor!])
lset-diff+intersection
(rename lset-diff+intersection lset-diff+intersection!))
(rename-out [lset-diff+intersection lset-diff+intersection!]))
;; Lists-as-sets
;;;;;;;;;;;;;;;;;

25
collects/srfi/1/misc.ss
View File

@ -32,28 +32,21 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require srfi/optional
"predicate.ss"
"selector.ss"
"util.ss"
(only "fold.ss" reduce-right)
(rename "fold.ss" srfi-1:map map))
(only-in "fold.ss" reduce-right)
(rename-in "fold.ss" [map s:map] [for-each s:for-each]))
(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
concatenate (rename-out [concatenate concatenate!])
(rename-out [append append!])
(rename-out [reverse reverse!])
append-reverse (rename-out [append-reverse append-reverse!])
zip unzip1 unzip2 unzip3 unzip4 unzip5
count)
;; count
@ -86,7 +79,7 @@
len))
len)))
(define (zip list1 . more-lists) (apply srfi-1:map list list1 more-lists))
(define (zip list1 . more-lists) (apply s:map list list1 more-lists))
;; Unzippers -- 1 through 5
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

4
collects/srfi/1/predicate.ss
View File

@ -33,9 +33,7 @@
;; -Olin
#lang mzscheme
(require srfi/optional)
#lang scheme/base
(provide pair?
null?

22
collects/srfi/1/search.ss
View File

@ -32,32 +32,26 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require mzlib/etc
srfi/optional
(require srfi/optional
"predicate.ss"
"util.ss")
(provide (rename my-member member)
(provide (rename-out [my-member member])
find
find-tail
any
every
list-index
take-while
take-while (rename-out [take-while take-while!])
drop-while
(rename take-while take-while!)
span
break
(rename span span!)
(rename break break!))
span (rename-out [span span!])
break (rename-out [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))))
(define [my-member x lis [= equal?]]
(find-tail (lambda (y) (= x y)) lis))
;; find find-tail take-while drop-while span break any every list-index
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

6
collects/srfi/1/selector.ss
View File

@ -32,7 +32,7 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require srfi/optional)
@ -44,8 +44,8 @@
car+cdr
take drop
take-right drop-right
(rename take take!) (rename drop-right drop-right!)
split-at (rename split-at split-at!)
(rename-out [take take!]) (rename-out [drop-right drop-right!])
split-at (rename-out [split-at split-at!])
last
last-pair)

30
collects/srfi/1/util.ss
View File

@ -32,7 +32,7 @@
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;; -Olin
#lang mzscheme
#lang scheme/base
(require "predicate.ss"
"selector.ss")
@ -65,12 +65,12 @@
;; However, if any element of LISTS is empty, just abort and return '().
(define (%cdrs lists)
(let/ec abort
(let recur ((lists lists))
(if (pair? lists)
(let ((lis (car lists)))
(if (null-list? lis) (abort '())
(cons (cdr lis) (recur (cdr lists)))))
'()))))
(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))
@ -82,14 +82,14 @@
(define (%cars+cdrs lists)
(let/ec abort
(let recur ((lists lists))
(if (pair? lists)
(let-values ([(list other-lists) (car+cdr lists)])
(if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
(let-values ([(a d) (car+cdr list)]
[(cars cdrs) (recur other-lists)])
(values (cons a cars) (cons d cdrs)))))
(values '() '())))))
(let recur ((lists lists))
(if (pair? lists)
(let-values ([(list other-lists) (car+cdr lists)])
(if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
(let-values ([(a d) (car+cdr list)]
[(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.