aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorbnewbold <bnewbold@eta.mit.edu>2009-01-16 04:51:29 -0500
committerbnewbold <bnewbold@eta.mit.edu>2009-01-16 04:51:29 -0500
commit9b37cbb3f730f3a4a3f13de8f3c5351b207f68f2 (patch)
tree0f1216d4c061dcc7b03e46260052a91141f99d4e
parentdf1d1038048c1db7e1f7c2436993c3017de2542a (diff)
download8thesis-9b37cbb3f730f3a4a3f13de8f3c5351b207f68f2.tar.gz
8thesis-9b37cbb3f730f3a4a3f13de8f3c5351b207f68f2.zip
added play files for scheme textbooks
-rw-r--r--little_schemer.scm1335
-rw-r--r--seasoned_schemer.scm640
2 files changed, 1975 insertions, 0 deletions
diff --git a/little_schemer.scm b/little_schemer.scm
new file mode 100644
index 0000000..8a31425
--- /dev/null
+++ b/little_schemer.scm
@@ -0,0 +1,1335 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Play-along log to The Little Schemer by Friedman and Felleisen
+; Jan 2008, bryan newbold
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Preface: define and test primative
+
+(define atom?
+ (lambda (x)
+ (and (not (pair? x)) (not (null? x)))))
+
+(atom? (quote ()))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 01: Toys
+
+(car '(c b a)) ; returns c
+(cdr '(c b a)) ; returns '(b a)
+;(car ()) ; gives an error, () is null (but is still a list)
+
+; [[ Law of Car ]]
+; The primative car is defind only for non-empty lists.
+
+; [[ Law of Cdr ]]
+; The primative cdr is defined only for non-empty lists. The cdr of any
+; non-empty list is always another list.
+
+(cons 2 3) ; returns (2 . 3), though book says undefined.
+(cons 'a ()) ; returns (a)
+
+; [[ Law of Cons ]]
+; The primative cons takes two arguments. The second argument to cons must be
+; a list. The result is a list.
+
+(null? ()) ; #t
+(null? 3) ; #f
+;(null? (() ())); error
+;(null? ('() '())) ; error
+(null? '(() ())) ; #f
+(null? 'asdf) ; #f, book says undefined
+
+;(cdr (1)) ; error!
+(cdr '(1)) ; reurns ()
+
+; [[ Law of Null? ]]
+; The primative null? is defined only for lists.
+
+; [[ Law of Eq? ]]
+; The primative eq? takes two arguments. Each must be a non-numeric atom.
+
+; in practice some numbers can be eq? ?
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 02: Do It, Do It Again, and Again, and Again...
+
+(define lat?
+ (lambda (l)
+ (cond
+ ((null? l) #t)
+ ((atom? (car l)) (lat? (cdr l)))
+ (else #f))))
+
+; lat = list of atoms
+(lat? '(a b c d)) ; #t
+(lat? '('(1 2 3) 4 5 6)) ; #f
+(lat? ()) ; #t
+
+(define member?
+ (lambda (a lat)
+ (cond
+ ((null? lat) #f)
+ (else (or (eq? (car lat) a)
+ (member? a (cdr lat)))))))
+
+(member? 'beef '(meat and potatoes and beef)) ; #t
+(member? 'tofu ()) ; #f
+
+; {{ The First Commandment }}
+; When recurring on a list of atoms, lat, ask two questions about it:
+; (null? lat) and else.
+; When recurring on a number, n, ask two questions about it: (zero? n) and
+; else.
+; When recurring on a list of S-expressions, l, ask three questions about it:
+; (null? l), (atom? (car l)), and else.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 03: Cons the Magnificent
+
+(define rember
+ (lambda (a lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? (car lat) a) (cdr lat))
+ (else (cons (car lat)
+ (rember a (cdr lat)))))))
+
+(rember 'and '(peanut butter and jelly)) ; (peanut butter jelly)
+
+; {{ The Second Commandment }}
+; Use cons to build lists.
+
+; returns list of first elements off each list in a list of lists ;)
+(define firsts
+ (lambda (l)
+ (cond
+ ((null? l) ())
+ (else (cons (car (car l)) (firsts (cdr l)))))))
+
+(firsts '((a b c) (1 2 3) (j k l))) ; (a 1 j)
+
+; {{ The Third Commandment }}
+; When building a list, describe the first typical element, and then
+; cons it onto the natural recursion.
+
+(define insertR
+ (lambda (new old lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? old (car lat)) (cons (car lat) (cons new (cdr lat))))
+ (else (cons (car lat) (insertR new old (cdr lat)))))))
+
+(insertR 'jalapeno 'and '(tacos tamales and salsa))
+; (tacos tamales and jalapeno salsa)
+
+(define insertL
+ (lambda (new old lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? old (car lat)) (cons new lat))
+ (else (cons (car lat) (insertL new old (cdr lat)))))))
+
+(insertL 'now 'please '(do it please)) ; (do it now please)
+
+(define subst
+ (lambda (new old lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? old (car lat)) (cons new (cdr lat)))
+ (else (cons (car lat) (subst new old (cdr lat)))))))
+
+(subst 'both 'and '(meat and potatoes)) ; (meat both potatoes)
+
+(define subst2
+ (lambda (new o1 o2 lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? o1 (car lat)) (cons new (cdr lat)))
+ ((eq? o2 (car lat)) (cons new (cdr lat)))
+ (else (cons (car lat) (subst2 new o1 o2 (cdr lat)))))))
+
+(subst2 'a 'q 'r '(a s d r q)) ; (a s d a q)
+(subst2 'a 'q 'r '(a s q d r)) ; (a s a d r)
+
+(define multirember
+ (lambda (a lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? (car lat) a) (multirember a (cdr lat)))
+ (else (cons (car lat) (multirember a (cdr lat)))))))
+
+(multirember 'd '(a d b d s g r c d d d w r)) ; (a b s g r c w r)
+
+; {{ The Fourth Commandment }}
+; Always change at least one argument while recurring. It must be changed to
+; be closer to termination. The changing argument must be tested in the
+; termination condition: when using cdr, test temrination with null?.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 04: Numbers Games
+
+(atom? 0) ; #t
+(atom? 3.123123132) ; #t
+(atom? -12i) ; #t
+
+(define add1
+ (lambda (n)
+ (+ n 1)))
+
+(add1 67)
+
+(define sub1
+ (lambda (n)
+ (- n 1)))
+
+(sub1 0) ; -1
+(sub1 -12i) ; -1-12i
+(sub1 +2i) ; -1+2i
+
+(zero? 2) ; #f
+
+; doesn't handle negatives!
+(define o+
+ (lambda (a b)
+ (cond
+ ((zero? b) a)
+ (else (o+ (add1 a) (sub1 b))))))
+
+(o+ 12 3)
+
+(define o-
+ (lambda (a b)
+ (cond
+ ((zero? b) a)
+ (else (o- (sub1 a) (sub1 b))))))
+
+(o- 12 3) ; 9
+(o- 10 25) ; -15
+;(o- 4 -1) ; infinite loop!
+
+(zero? ()) ; #f
+
+(define addtup
+ (lambda (tup)
+ (cond
+ ((null? tup) 0)
+ (else (o+ (car tup) (addtup (cdr tup)))))))
+
+(addtup '(1 1 1 1 1)) ; 5
+(addtup '()) ; 0
+
+(define ox
+ (lambda (a b)
+ (cond
+ ((zero? b) 0)
+ (else (o+ a (ox a (sub1 b)))))))
+
+(ox 4 4) ; 16
+;(ox 12983761498 12983472) ; max recursion depth exceeded ;(
+;(ox 39485 345) ; SLOW!
+
+; {{ The Fourth Commandment }}
+; Always change at least one argument while recurring. It must be changed to be
+; closer to termination. The changing argument must be tested in the
+; termination condition:
+; when using cdr, test termination with null? and
+; when using sub1, test termination with zero?.
+
+; {{ The Fifth Commandment }}
+; When building a value with +, always use 0 for the value of the terminating
+; line, for adding 0 does not change the value of an addition.
+; When building a value with x, always use 1 for the value of the terminating
+; line, for multiplying by 1 does not change the value of a multiplication.
+; When building a value with cons, always condsider () for the value of the
+; terminating line.
+
+(define tup+
+ (lambda (a b)
+ (cond
+ ((or (null? a) (null? b)) ())
+ (else (cons (o+ (car a) (car b)) (tup+ (cdr a) (cdr b)))))))
+; the book uses 'and' instead of 'or' because it specifies the tups must
+; be of equal length
+
+(tup+ '(1 2 3 4 5) '(5 4 3 2 1)) ; (6 6 6 6 6)
+
+; improved version
+(define tup+
+ (lambda (a b)
+ (cond
+ ((and (null? a) (null? b)) (quote ()))
+ ((null? a) b)
+ ((null? b) a)
+ (else (cons (o+ (car a) (car b)) (tup+ (cdr a) (cdr b)))))))
+
+(tup+ '(1 2 3 4 5) '(5 4)) ; (6 6 3 4 5)
+
+(define o>
+ (lambda (a b)
+ (cond
+ ((zero? a) #f)
+ ((zero? b) #t)
+ (else (o> (sub1 a) (sub1 b))))))
+
+(o> 5 6) ; #t
+(o> 7 7) ; #f
+
+(define length
+ (lambda (lat)
+ (cond
+ ((null? lat) 0)
+ (else (add1 (length (cdr lat)))))))
+(length '(a b c d)) ; 4
+(length (quote ())) ; 0
+
+(define pick
+ (lambda (n lat)
+ (cond
+ ((zero? (sub1 n)) (car lat))
+ (else (pick (sub1 n) (cdr lat))))))
+
+(define rempick
+ (lambda (n lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((zero? n) (cdr lat))
+ (else (cons (car lat) (rempick (sub1 n) (cdr lat)))))))
+
+(rempick 3 `(this sentance has like a billion words))
+
+(define no-nums
+ (lambda (lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((number? (car lat)) (no-nums (cdr lat)))
+ (else (cons (car lat) (no-nums (cdr lat)))))))
+
+(no-nums '(this 1 sentance has 56 other numbers 23 built-in))
+
+(define all-nums
+ (lambda (lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((number? (car lat)) (cons (car lat) (all-nums (cdr lat))))
+ (else (all-nums (cdr lat))))))
+
+(all-nums '(this 1 sentance has 56 other numbers 23 built-in))
+
+(define eqan?
+ (lambda (a b)
+ (cond
+ ((and (number? a) (number? b)) (= a b))
+ ((or (number? a) (number? b)) #f)
+ (else (eq? a b)))))
+
+(eq? 1 1) ; #t
+(eqan? 2 3) ; #f
+
+(define occur
+ (lambda (a lat)
+ (cond
+ ((null? lat) 0)
+ ((eq? a (car lat)) (add1 (occur a (cdr lat))))
+ (else (occur a (cdr lat))))))
+
+(occur 'n '(a n d that's all n folks!)) ; 2
+(occur 123 '(1 2 3 4)) ; 0
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 05: Oh My Gawd: It's full of Stars
+
+(define rember*
+ (lambda (a l)
+ (cond
+ ((null? l) (quote ()))
+ ((atom? (car l)) (cond
+ ((eq? a (car l)) (cdr l))
+ (else (cons (car l) (rember* a (cdr l))))))
+ (else (cons (rember* a (car l)) (rember* a (cdr l)))))))
+
+(rember* 'sauce '(((tomato sauce))
+ ((bean) sauce)
+ (and ((flying)) sauce)))
+
+(define insertR*
+ (lambda (new old l)
+ (cond
+ ((null? l) (quote ()))
+ ((atom? (car l)) (cond
+ ((eq? old (car l)) (cons (car l) (cons new (cdr l))))
+ (else (cons (car l) (insertR* new old (cdr l))))))
+ (else (cons (insertR* new old (car l)) (insertR* new old (cdr l)))))))
+
+(insertR* 'roast 'chuck '((how much (wood))
+ could
+ ((a (wood) chuck))
+ (((chuck)))
+ (if (a) ((wood chuck)))
+ could chuck wood))
+
+(define occur*
+ (lambda (a l)
+ (cond
+ ((null? l) 0)
+ ((atom? (car l)) (cond
+ ((eq? (car l) a) (add1 (occur* a (cdr l))))
+ (else (occur* a (cdr l)))))
+ (else (o+ (occur* a (car l)) (occur* a (cdr l)))))))
+
+(occur* 'banana '((banana)
+ (split ((((banana ice)))
+ (cream (banana))
+ sherbet))
+ (banana)
+ (bread)
+ (banana brandy)))
+
+(define subst*
+ (lambda (new old l)
+ (cond
+ ((null? l) (quote ()))
+ ((atom? (car l)) (cond
+ ((eq? old (car l)) (cons new (subst* new old (cdr l))))
+ (else (cons (car l) (subst* new old (cdr l))))))
+ (else (cons (subst* new old (car l)) (subst* new old (cdr l)))))))
+
+(subst* 'orange 'banana '((banana)
+ (split ((((banana ice)))
+ (cream (banana))
+ sherbet))
+ (banana)
+ (bread)
+ (banana brandy)))
+
+(define insertL*
+ (lambda (new old l)
+ (cond
+ ((null? l) (quote ()))
+ ((atom? (car l)) (cond
+ ((eq? old (car l))
+ (cons new (cons
+ (car l)
+ (insertL* new old (cdr l)))))
+ (else (cons (car l) (insertL* new old (cdr l))))))
+ (else (cons (insertL* new old (car l)) (insertL* new old (cdr l)))))))
+
+(insertL* 'pecker 'chuck '((how much (wood))
+ could
+ ((a (wood) chuck))
+ (((chuck)))
+ (id (a) ((wood chuck)))
+ could chuck wood))
+
+(define member*
+ (lambda (a l)
+ (cond
+ ((null? l) #f)
+ ((atom? (car l)) (cond
+ ((eq? a (car l)) #t)
+ (else (member* a (cdr l)))))
+ (else (or (member* a (car l)) (member* a (cdr l)))))))
+
+(member* 'chips '((potato (chips ((with) fish) (chips))))) ; #t
+(member* 'beef '(meat ((and potatoes)) (with brocolli))) ; #f
+
+; list must not contain null list!
+(define leftmost
+ (lambda (l)
+ (cond
+ ((null? l) (quote ()))
+ ((atom? (car l)) (car l))
+ (else (leftmost (car l))))))
+
+(leftmost '(((hot) (tuna (and))) cheese))
+
+(define eqlist?
+ (lambda (a b)
+ (cond
+ ((and (null? a) (null? b)) #t)
+ ((or (null? a) (null? b)) #f)
+ ((and (atom? (car a)) (atom? (car b)))
+ (and (eqan? (car a) (car b))
+ (and (eqlist? (cdr a) (cdr b)))))
+ ((or (atom? (car a)) (atom? (car b))) #f)
+ (else (and (eqlist? (car a) (car b)) (eqlist? (cdr a) (cdr b)))))))
+
+(eqlist?
+ '(beef ((sausage)) (and (soda)))
+ '(beef ((sausage)) (and (soda)))) ; #t
+
+(eqlist?
+ '(beef ((sausag)) (and (soda)))
+ '(beef ((sausage)) (and))) ; #f
+
+(eqlist? '(ff (1 2) (a)) '(ff (1 2) (b))) ; #f
+
+(eqan? 'sausag 'sausage) ; #f
+
+; new definition allows removal of S-expressions
+(define rember
+ (lambda (s l)
+ (cond
+ ((null? l) (quote ()))
+ ((equal? s (car l)) (cdr l))
+ (else (cons (car l) (rember s (cdr l)))))))
+
+; these next two I just copied after the fact, didn't think I would
+; need them at the time
+(define equal?
+ (lambda (a b)
+ (cond
+ ((and (atom? a) (atom? b)) (eqan? a b))
+ ((or (atom? a) (atom? b)) #f)
+ (else (eqlist? a b)))))
+
+(equal? '(this ((is more) complicated))
+ '(this ((is more) complicated))) ; #t
+(equal? '(this ((is more) complicated))
+ '(this ((is) complicated))) ; #f
+(equal? '4' '(4 5)) ; #f
+
+(define rember
+ (lambda (s l)
+ (cond
+ ((null? l) (quote ()))
+ ((equal? (car l) s) (cdr l))
+ (else (cons (car l) (rember s (cdr l)))))))
+
+(rember 'q '(a b e d q))
+(rember '4 '(1 2 3 (4 5) 8))
+(rember '(4 5) '(1 2 3 (4 5) 6 7 8))
+
+; {{ The Sixth Commandment }}
+; Simplify only after the function is correct.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 06: Shadows
+
+(define numbered?
+ (lambda (aexp)
+ (cond
+ ((null? aexp) #f)
+ ((atom? aexp) (number? aexp))
+ ((or (eq? (car (cdr aexp)) (quote +))
+ (eq? (car (cdr aexp)) (quote -))
+ (eq? (car (cdr aexp)) (quote ^)))
+ (and (numbered? (car aexp)) (numbered? (car (cdr (cdr aexp))))))
+ (else #f))))
+
+(numbered? '(1 + 3)) ; #t
+(numbered? '((4 ^ 3) - 4)) ; #t
+(numbered? '(a + 2 + (r ^ 2))) ; #f
+(numbered? '(1 _ 3 + 5 + Q)) ; #f
+(numbered? '(1 + 4 ^ 8 + r)) ; #t???? should only have two expressions
+(numbered? '((1 + 4) ^ (8 + r))) ; #f
+
+;book likes to make assumptions, namely that aexp is definately an algebraic
+;expression
+(define numbered?
+ (lambda (aexp)
+ (cond
+ ((atom? aexp) (number? aexp))
+ (else (and (numbered? (car aexp))
+ (numbered? (car (cdr (cdr aexp)))))))))
+
+(numbered? '1)
+(numbered? '(1 + 1))
+
+
+(define value
+ (lambda (aexp)
+ (cond
+ ((atom? aexp) aexp)
+ ((eq? (car (cdr aexp)) (quote +)) (+ (value (car aexp))
+ (value (car (cdr (cdr aexp))))))
+ ((eq? (car (cdr aexp)) (quote -)) (- (value (car aexp))
+ (value (car (cdr (cdr aexp))))))
+ ((eq? (car (cdr aexp)) (quote ^))
+ (expt (value (car aexp))
+ (value (car (cdr (cdr aexp)))))))))
+
+(value '(1 + 1))
+(value '(3 ^ 3))
+(value '(5 - (2 ^ 2)))
+
+(define 1st-sub-exp
+ (lambda (aexp)
+ (car aexp)))
+
+(define 2nd-sub-exp
+ (lambda (aexp)
+ (car (cdr (cdr aexp)))))
+
+(define operator
+ (lambda (aexp)
+ (car (cdr aexp))))
+
+; {{ The Seventh Commandment }}
+; Recur on the subpart that are of the same nature:
+; * on the sublists of a list.
+; * on the subexpressions of an arthmetic expression.
+
+; {{ The Eighth Commandment }}
+; Use help functions to abstract from representations.
+
+(define sero?
+ (lambda (n)
+ (null? n)))
+
+(sero? '()) ; #t
+(sero? '(() ())) ; #f
+
+(define edd1
+ (lambda (n)
+ (cons (quote ()) n)))
+
+(define zub1
+ (lambda (n)
+ (cdr n)))
+
+;(define o+
+; (lambda (n m)
+; (cond
+; ((sero? m) n)
+; (else (edd1 (o+ n (zub1 m)))))))
+
+;(o+ '(() ()) '(() () ())) ; (() () () () ())
+
+;(lat? (() () () () ())) ; error!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 07: Friends and Relations
+
+(define set?
+ (lambda (lat)
+ (cond
+ ((null? lat) #t)
+ ((member? (car lat) (cdr lat)) #f)
+ (else (set? (cdr lat))))))
+
+(set? '(this is a sentance with no repeats)) ; #t
+(set? '()) ; #t
+(set? '(this is a sentance with repeats, so this is not a set)); #f
+
+(define makeset
+ (lambda (lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((member? (car lat) (cdr lat)) (makeset (cdr lat)))
+ (else (cons (car lat) (makeset (cdr lat)))))))
+
+(makeset '(a b c b c c c d e f))
+
+; is every element of the first in the second?
+(define subset?
+ (lambda (a b)
+ (cond
+ ((null? a) #t)
+ ((member? (car a) b) (subset? (cdr a) b))
+ (else #f))))
+
+(subset? '() '(1 2 3)) ; #t
+(subset? '(a b c) '(1 4 b 6 c 1 a)) ; #t
+(subset? '(a b c) '(1 4 b 6 1 a)) ; #f
+
+(define eqset?
+ (lambda (a b)
+ (and (subset? a b) (subset? b a))))
+
+(eqset? '(1 2 3 4) '(3 4 1 2)) ; #t
+(eqset? '(1 2 3 4 5) '(3 4 1 2)) ; #f
+
+(define intersect?
+ (lambda (a b)
+ (cond
+ ((null? a) #f)
+ (else (or (member? (car a) b) (intersect? (cdr a) b))))))
+
+(intersect? '(a b c) '(1 2 3)) ; #f
+(intersect? '(a B c) '(1 2 3 B 5)) ; #t
+
+(define intersect
+ (lambda (a b)
+ (cond
+ ((null? a) (quote ()))
+ ((member? (car a) b) (cons (car a) (intersect (cdr a) b)))
+ (else (intersect (cdr a) b)))))
+
+(intersect '(a b c) '(1 2 3)) ; ()
+(intersect '(a b c) '(1 b c 4 5)) ; (b c)
+
+(define union
+ (lambda (a b)
+ (cond
+ ((null? a) b)
+ ((member? (car a) b) (union (cdr a) b))
+ (else (union (cdr a) (cons (car a) b))))))
+
+(union '(a b c) '(1 2 3))
+(union '(a b c) '(a b 3))
+
+(define intersectall
+ (lambda (l-set)
+ (cond
+ ((null? (cdr l-set)) (car l-set))
+ (else (intersect (car l-set) (intersectall (cdr l-set)))))))
+
+(intersectall '((a b c) (c a d e) (e f g h a b))) ; (a)
+
+(define a-pair?
+ (lambda (x)
+ (cond
+ ((null? x) #f)
+ ((atom? x) #f)
+ ((null? (cdr x)) #f)
+ ((null? (cdr (cdr x))) #t)
+ (else #f))))
+
+(define first
+ (lambda (p) (car p)))
+
+(define second
+ (lambda (p) (car (cdr p))))
+
+(define build
+ (lambda (a b) (cons a (cons b (quote ())))))
+
+(define third
+ (lambda (p) (car (cdr (cdr p)))))
+
+; a rel is a relation: a list of pairs
+
+(firsts '((a b) (c d) (e f))) ; # (a c e), from an earlier chapter
+
+(define fun?
+ (lambda (rel)
+ (set? (firsts rel))))
+
+(define revrel
+ (lambda (rel)
+ (cond
+ ((null? rel) (quote ()))
+ (else (cons (build (second (car rel)) (first (car rel)))
+ (revrel (cdr rel)))))))
+
+(revrel '((a b) (1 2) (here there)))
+
+(define revpair
+ (lambda (p)
+ (build (second p) (first p))))
+
+(define revrel
+ (lambda (rel)
+ (cond
+ ((null? rel) (quote ()))
+ (else (cons (revpair (car rel)) (revrel (cdr rel)))))))
+
+(define fullfun?
+ (lambda (fun)
+ (set? (seconds fun))))
+
+(define one-to-one?
+ (lambda (fun)
+ (fun? (revrel fun))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 08: Lambda the Ultimate
+
+(define rember-f
+ (lambda (test? a l)
+ (cond
+ ((null? l) (quote ()))
+ ((test? a (car l)) (rember-f test? a (cdr l)))
+ (else (cons (car l) (rember-f test? a (cdr l)))))))
+
+(rember-f equal? '(pop corn) '(lemonade (pop corn) and (cake)))
+
+; Currying: Moses Schonfinkel and Haskell Curry
+
+(define eq?-c
+ (lambda (a)
+ (lambda (x)
+ (eq? x a))))
+
+((eq?-c 'salad) 'salad) ; #t
+(define eq?-salad (eq?-c 'salad))
+(eq?-salad 'salad) ; #t
+
+(define rember-f
+ (lambda (test?)
+ (lambda (a l)
+ (cond
+ ((null? l) (quote ()))
+ ((test? a (car l)) ((rember-f test?) a (cdr l)))
+ (else (cons (car l) ((rember-f test?) a (cdr l))))))))
+
+(define rember-eq? (rember-f eq?))
+(rember-eq? 'tuna '(tuna salad is good))
+
+(define insertL-f
+ (lambda (test?)
+ (lambda (new old l)
+ (cond
+ ((null? l) (quote ()))
+ ((test? (car l) old)
+ (cons new (cons old (cdr l))))
+ (else (cons (car l)
+ ((insertL-f test?) new old (cdr l))))))))
+
+(define seqL
+ (lambda (new old l)
+ (cons new (cons old l))))
+
+(define seqR
+ (lambda (new old l)
+ (cons old (cons new l))))
+
+(define insert-g
+ (lambda (seq)
+ (lambda (new old l)
+ (cond
+ ((null? l) (quote ()))
+ ((eq? (car l) old) (seq new old (cdr l)))
+ (else (cons (car l) ((insert-g seq) new old (cdr l))))))))
+
+(define insertL (insert-g seqL))
+(define insertR (insert-g seqR))
+(define insertL (insert-g
+ (lambda (new old l)
+ (cons new (cons old l)))))
+
+(insertL 'BUT 'then '(where but for the end then))
+
+(define seqS
+ (lambda (new old l) (cons new l)))
+
+(define subst (insert-g seqS))
+
+(subst 'both 'and '(meat and potatoes))
+
+; {{ The Ninth Commandment }}
+; Abstract common patterns with a new function.
+
+(define atom-to-function
+ (lambda (x)
+ (cond
+ ((eq? x (quote +)) +)
+ ((eq? x (quote x)) ox)
+ (else expt))))
+
+(expt 4 4) ; 256
+(+ 4 4) ; 8
+(ox 4 4)
+(o+ 4 4)
+
+(atom-to-function (operator '(+ 5 3))) ; plus function
+
+(define value
+ (lambda (nexp)
+ (cond
+ ((atom? nexp) nexp)
+ (else
+ ((atom-to-function (operator nexp))
+ (value (1st-sub-exp nexp))
+ (value (2nd-sub-exp nexp)))))))
+
+(value '(4 + 2))
+
+(define multirember-f
+ (lambda (test?)
+ (lambda (a lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((test? a (car lat)) ((multirember-f test?) a (cdr lat)))
+ (else (cons (car lat) ((multirember-f test?) a (cdr lat))))))))
+
+((multirember-f eq?) 'tuna '(shrimp salad tuna salad and tuna))
+
+(define eq?-tuna (eq?-c (quote tuna)))
+(eq?-tuna (quote tuna)) ; #t
+
+(define multiremberT
+ (lambda (test? lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((test? (car lat)) (multiremberT test? (cdr lat)))
+ (else (cons (car lat) (multiremberT test? (cdr lat)))))))
+
+(multiremberT eq?-tuna '(shrimp salad tuna salad and tuna))
+
+(define a-friend
+ (lambda (x y)
+ (null? y)))
+
+; col is a collector
+
+(define multirember&co
+ (lambda (a lat col)
+ (cond
+ ((null? lat) (col (quote ()) (quote ())))
+ ((eq? (car lat) a) (multirember&co
+ a
+ (cdr lat)
+ (lambda (newlat seen)
+ (col newlat (cons (car lat) seen)))))
+ (else (multirember&co a (cdr lat)
+ (lambda (newlat seen)
+ (col (cons (car lat) newlat) seen)))))))
+
+(define new-friend
+ (lambda (newlat seen)
+ (a-friend newlat (cons (quote tuna) seen))))
+
+; {{ The Tenth Commandment }}
+; Build functions to collect more than one value at a time.
+
+(define multiinsertL
+ (lambda (new old lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? (car lat) old) (cons new
+ (multiinsertL new old (cdr lat))))
+ (else (cons (car lat) (multiinsertL new old (cdr lat)))))))
+
+(define multiinsertR
+ (lambda (new old lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? (car lat) old) (cons new
+ (multiinsertR new old (cdr lat))))
+ (else (cons (car lat) (multiinsertR new old (cdr lat)))))))
+
+(define multiinsertLR
+ (lambda (new oldL oldR lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? (car lat) oldL)
+ (cons new (cons oldL
+ (multiinsertLR new oldL oldR (cdr lat)))))
+ ((eq? (car lat) oldR)
+ (cons new (multiinsertLR new oldL oldR (cdr lat))))
+ (else (cons (car lat) (multiinsertLR new oldL oldR (cdr lat)))))))
+
+(define multiinsertLR&co
+ (lambda (new oldL oldR lat col)
+ (cond
+ ((null? lat) (col (quote ()) 0 0))
+ ((eq? (car lat) oldL)
+ (multiinsertLR&co new oldL oldR (cdr lat)
+ (lambda (newlat L R)
+ (col (cons new
+ (cons oldL newlat)) (add1 L) R))))
+ ((eq? (car lat) oldR)
+ (multiinsertLR&co new oldL oldR (cdr lat)
+ (lambda (newlat L R)
+ (col (cons oldR (cons new newlat)) L (add1 R)))))
+ (else (multiinsertLR&co new oldL oldR
+ (cdr lat)
+ (lambda (newlat L R)
+ (col (cons (car lat) newlat)
+ L R)))))))
+
+(multiinsertLR&co 'salty 'fish 'chips
+ '(chips and fish or fish and chips)
+ (lambda (lat L R)
+ R)) ; 2
+
+(multiinsertLR&co 'salty 'fish 'chips
+ '(chips and fish or fish and chips)
+ (lambda (lat L R)
+ lat))
+
+(define even?
+ (lambda (n)
+ (= (* (round (/ n 2)) 2) n)))
+
+(round 3/2) ; 2
+(= 1 1) ; #t
+(/ 4 2) ; 2
+(* 4 2) ; 8
+(even? 3) ; #f
+
+(define evens-only*
+ (lambda (l)
+ (cond
+ ((null? l) (quote ()))
+ ((atom? (car l)) (cond
+ ((even? (car l)) (cons (car l)
+ (evens-only* (cdr l))))
+ (else (evens-only* (cdr l)))))
+ (else (cons (evens-only* (car l)) (evens-only* (cdr l)))))))
+
+(evens-only* '((9 1 2 8) 3 10 ((9 9) 7 6) 2))
+; ((2 8) 10 (() 6) 2)
+
+(define col-odds
+ (lambda (l p s) l))
+
+(define col-p
+ (lambda (l p s) p))
+
+(define col-s
+ (lambda (l p s) s))
+
+(define evens-only*&co
+ (lambda (l col)
+ (cond
+ ((null? l) (col (quote ()) 1 0))
+ ((atom? (car l))
+ (cond
+ ((even? (car l)) (evens-only*&co (cdr l)
+ (lambda (newl p s)
+ (col (cons (car l) newl)
+ (* p (car l))
+ s))))
+ (else (evens-only*&co (cdr l)
+ (lambda (newl p s)
+ (col newl
+ p
+ (+ s (car l))))))))
+ (else
+ (evens-only*&co (car l)
+ (lambda (al ap as)
+ (evens-only*&co (cdr l)
+ (lambda (dl dp ds)
+ (col (cons al dl)
+ (* ap dp)
+ (+ as ds))))))))))
+
+(evens-only*&co '((9 1 2 8) 3 10 ((9 9) 7 6) 2)
+ (lambda (newl p s)
+ (cons s (cons p newl)))) ; (38 1920 (2 8) 10 (() 6) 2)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 09: ... and Again, and Again, and Again, ...
+
+(define looking
+ (lambda (a lat)
+ (keep-looking a (pick 1 lat) lat)))
+
+; sorn is a symbol or a number
+
+(define keep-looking
+ (lambda (a sorn lat)
+ (cond
+ ((number? sorn) (keep-looking a (pick sorn lat) lat))
+ (else (eq? sorn a)))))
+
+(looking 'caviar '(6 2 4 caviar 5 7 3)) ; #t
+(looking 'caviar '(6 2 grits caviar 5 7 3)) ; #f
+
+; total functions terminate for all finite inputs?
+; partial functions terminate for only some inputs?
+
+(define shift
+ (lambda (pair)
+ (build (first (first pair))
+ (build (second (first pair))
+ (second pair)))))
+
+(shift '((a b) c)); (a (b c))
+;(shift '(a (b c))); error
+
+; pora = pair or atom
+(define align
+ (lambda (pora)
+ (cond
+ ((atom? pora) pora)
+ ((a-pair? (first pora)) (align (shift pora)))
+ (else (build (first pora) (align (second pora)))))))
+
+(define length*
+ (lambda (pora)
+ (cond
+ ((atom? pora) l)
+ (else (length* (first pora)) (length* (second pora))))))
+
+(define weight*
+ (lambda (pora)
+ (cond
+ ((atom? pora) 1)
+ (else (+ (* 2 (weight* (first pora)))
+ (weight* (second pora)))))))
+
+(weight* '((a b) c)) ; 7
+(weight* '(a (b c))) ; 5
+
+(define shuffle
+ (lambda (pora)
+ (cond
+ ((atom? pora) pora)
+ ((a-pair? (first pora)) (shuffle (revpair pora)))
+ (else (build (first pora) (shuffle (second pora)))))))
+
+(shuffle '(a b)) ; (a b)
+; (shuffle '((a b) (c d))) ; infinite recursion
+
+; Collatz function?
+(define C
+ (lambda (n)
+ (cond
+ ((one? n) 1)
+ (else (cond
+ ((even? n) (C (/ n 2)))
+ (else (C (add1 (* 3 n)))))))))
+
+; (C 0) ; infinite recursion?
+(C 1) ; 1
+(C 2) ; 1
+(C 8) ; 1
+
+; Ackermann function
+(define A
+ (lambda (n m)
+ (cond
+ ((zero? n) (add1 m))
+ ((zero? m) (A (sub1 n) 1))
+ (else (A (sub1 n) (A n (sub1 m)))))))
+
+(A 1 0) ; 2
+(A 2 2) ; 7
+(A 3 3) ; 61
+(A 3 4) ; 125
+; (A 4 3) ; ocean boiling?
+
+(define eternity
+ (lambda (x) (eternity x)))
+
+; got lost here a bit...
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 10: What is the Value of All of This?
+
+(define new-entry build)
+
+(define lookup-in-entry
+ (lambda (name entry entry-f)
+ (lookup-in-entry-help name
+ (first entry)
+ (second entry)
+ entry-f)))
+
+(define lookup-in-entry-help
+ (lambda (name names values entry-f)
+ (cond
+ ((null? names) (entry-f name))
+ ((eq? (car names) name) (car values))
+ (else (lookup-in-entry-help name (cdr names) (cdr values) entry-f)))))
+
+(lookup-in-entry 'fish
+ '((teach a man to fish)
+ (1 2 3 4 5))
+ (lambda (x) x))
+
+(define extend-table cons)
+
+(define lookup-in-table
+ (lambda (name table table-f)
+ (cond
+ ((null? table) (table-f name))
+ (else (lookup-in-entry name
+ (car table)
+ (lambda (n)
+ (lookup-in-table n (cdr table) table-f)))))))
+
+(lookup-in-table 'fish
+ (extend-table '((teach a man to fish)
+ (1 2 3 4 5))
+ (quote ()))
+ (lambda (x) x))
+
+(define atom-to-action
+ (lambda (e)
+ (cond
+ ((number? e) *const)
+ ((eq? e #t) *const)
+ ((eq? e #f) *const)
+ ((eq? e (quote cons)) *const)
+ ((eq? e (quote car)) *const)
+ ((eq? e (quote cdr)) *const)
+ ((eq? e (quote null?)) *const)
+ ((eq? e (quote eq?)) *const)
+ ((eq? e (quote atom?)) *const)
+ ((eq? e (quote zero?)) *const)
+ ((eq? e (quote add1)) *const)
+ ((eq? e (quote sub1)) *const)
+ ((eq? e (quote number?)) *const)
+ (else *identifier))))
+
+(atom-to-action 'number?); *const
+
+(define list-to-action
+ (lambda (e)
+ (cond
+ ((atom? (car e)) (cond
+ ((eq? (car e) (quote quote)) *quote)
+ ((eq? (car e) (quote lambda)) *lambda)
+ ((eq? (car e) (quote cond)) *cond)
+ (else *application)))
+ (else *application))))
+
+(list-to-action '(lambda (x) x)) ; *lambda
+(list-to-action '(cond ((eq? 1 2) #f) (else #t))) ; *cond
+
+(define expression-to-action
+ (lambda (e)
+ (cond
+ ((atom? e) (atom-to-action e))
+ (else (list-to-action e)))))
+
+(expression-to-action '#f) ; *const
+(expression-to-action '(lambda (x) x)) ; *lambda
+
+(define value
+ (lambda (e)
+ (meaning e (quote ()))))
+
+(define meaning
+ (lambda (e table)
+ ((expression-to-action e) e table)))
+
+(define *const
+ (lambda (e table)
+ (cond
+ ((number? e) e)
+ ((eq? e #t) #t)
+ ((eq? e #f) #f)
+ (else (build (quote primitive) e)))))
+
+(*const 'asdf '()) ; (primitive asdf)
+
+(define *quote
+ (lambda (e table)
+ (text-of e)))
+
+(define text-of second)
+
+(*quote '(quote stuff) '()) ; stuff
+
+(define *identifier
+ (lambda (e table)
+ (lookup-in-table e table initial-table)))
+
+; this will pass an error if called
+(define initial-table
+ (lambda (name)
+ (car (quote ()))))
+
+;(*identifier 'asdf '()) ; error
+(*identifier 'a '( ((1 2 3 a b c) (first second third 1 2 3)))) ; 1
+
+(define *lambda
+ (lambda (e table)
+ (build (quote non-primitive) (cons table (cdr e)))))
+
+(*lambda '(lambda (a b) (cond ((eq? a b) b) (else a))) '( ((1 2 3) (a b c))))
+
+(meaning '(lambda (x) (cons x y)) '(((y z) ((8) 9))))
+; (non-primative ((((y z) ((8) 9)))) (x) (cons x y))
+
+(define table-of first)
+(define formals-of second)
+(define body-of third)
+(third '(a b c)) ; c
+
+(define evcon
+ (lambda (lines table)
+ (cond
+ ((else? (question-of (car lines)))
+ (meaning (answer-of (car lines)) table))
+ ((meaning (question-of (car lines)) table)
+ (meaning (answer-of (car lines)) table))
+ (else (evcon (cdr lines) table)))))
+
+(define else?
+ (lambda (x)
+ (cond
+ ((atom? x) (eq? x (quote else)))
+ (else #f))))
+
+(define question-of first)
+(define answer-of second)
+
+(define *cond
+ (lambda (e table)
+ (evcon (cond-lines-of e) table)))
+
+(define cond-lines-of cdr)
+
+(define evlis
+ (lambda (args table)
+ (cond
+ ((null? args) (quote ()))
+ (else (cons (meaning (car args) table)
+ (evlis (cdr args) table))))))
+
+(evlis '(cons #f 4) '()) ; ((primitive cons) #f 4)
+
+(define function-of car)
+(define arguments-of cdr)
+
+(define *application
+ (lambda (e table)
+ (apply
+ (meaning (function-of e) table)
+ (evlis (arguments-of e) table))))
+
+(define primitive?
+ (lambda (l)
+ (eq? (first l) (quote primitive))))
+
+(define non-primitive?
+ (lambda (l)
+ (eq? (first l) (quote non-primitive))))
+
+(define apply
+ (lambda (fun vals)
+ (cond
+ ((primitive? fun) (apply-primitive (second fun) vals))
+ ((non-primitive? fun) (apply-closure (second fun) vals)))))
+
+(define apply-primitive
+ (lambda (name vals)
+ (cond
+ ((eq? name (quote cons)) (cons (first vals) (second vals)))
+ ((eq? name (quote car)) (car (first vals)))
+ ((eq? name (quote cdr)) (cdr (first vals)))
+ ((eq? name (quote null?)) (null? (first vals)))
+ ((eq? name (quote eq?)) (eq? (first vals) (second vals)))
+ ((eq? name (quote atom?)) (:atom? (first vals)))
+ ((eq? name (quote zero?)) (zero? (first vals)))
+ ((eq? name (quote add1)) (add1 (first vals)))
+ ((eq? name (quote sub1)) (sub1 (first vals)))
+ ((eq? name (quote number?)) (number? (first vals))))))
+
+(first '(a b))
+(apply-primitive 'null? '(())) ; #t
+(*application '(null? 2) '()) ; #f
+(*application '(cdr (quote (a b))) '()) ; (b)
+(*application '(eq? 2 (add1 1)) '()) ; #t
+
+(define :atom?
+ (lambda (x)
+ (cond
+ ((atom? x) #t)
+ ((null? x) #f)
+ ((eq? (car x) (quote primitive)) #t)
+ ((eq? (car x) (quote non-primitive)) #t)
+ (else #f))))
+
+(define apply-closure
+ (lambda (closure vals)
+ (meaning (body-of closure)
+ (extend-table (new-entry (formals-of closure) vals)
+ (table-of closure)))))
+
+(value '(zero? 0))
+(value '(eq? 1 1))
+(value '#f) ; #f
+(value '(eq? 2 (add1 1))) ; #t
+
+(value '((lambda (a b) (a (add1 b))) (lambda (c) (add1 c)) 4)) ; 6
+
+(value '((lambda (x) x) 1)) ; 1
+
+;wheeee! \ No newline at end of file
diff --git a/seasoned_schemer.scm b/seasoned_schemer.scm
new file mode 100644
index 0000000..50d882d
--- /dev/null
+++ b/seasoned_schemer.scm
@@ -0,0 +1,640 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Play-along log to The Seasoned Schemer by Friedman and Felleisen
+; Jan 2008, bryan newbold
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Preface: define and test primative
+
+(define atom?
+ (lambda (x)
+ (and (not (pair? x)) (not (null? x)))))
+
+(atom? (quote ()))
+
+(define add1
+ (lambda (n)
+ (+ 1 n)))
+
+(add1 6) ; 7
+
+(define sub1
+ (lambda (n)
+ (- n 1)))
+
+(sub1 7) ; 6
+
+; kind of guessing here
+(define Y
+ (lambda (thing)
+ ((lambda (le)
+ ((lambda (f) (f f))
+ (lambda (f) (le (lambda (x) ((f f) x))))))
+ thing)))
+
+(define eqlist?
+ (lambda (a b)
+ (cond
+ ((and (null? a) (null? b)) #t)
+ ((or (null? a) (null? b)) #f)
+ ((and (atom? (car a)) (atom? (car b)))
+ (and (eqlist? (cdr a) (cdr b))))
+ ((or (atom? (car a)) (atom? (car b))) #f)
+ (else (and (eqlist? (car a) (car b)) (eqlist? (cdr a) (cdr b)))))))
+
+(eqlist? '(((this) is (a)) nontrivial (list))
+ '(((this) is (a)) nontrivial (list))) ; #t
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 01: Welsome Back to the Show
+
+(define member?
+ (lambda (a lat)
+ (cond
+ ((null? lat) #f)
+ (else (or (eq? a (car lat))
+ (member? a (cdr lat)))))))
+
+(member? 'a '(1 2 a b c)) ; #t
+
+(define two-in-a-row?
+ (lambda (lat)
+ (cond
+ ((null? lat) #f)
+ (else (is-first-b? (car lat) (cdr lat))))))
+
+(define is-first-b?
+ (lambda (a lat)
+ (cond
+ ((null? lat) #f)
+ (else (or (eq? a (car lat)) (two-in-a-row? lat))))))
+
+(is-first-b? 'a '(a b)) ; #t
+(two-in-a-row? '(this sentance doesn't have that)) ; #f
+(two-in-a-row? '(but this one does right right right)) ; #t
+
+(define two-in-a-row-b?
+ (lambda (a lat)
+ (cond
+ ((null? lat) #f)
+ (else (or (eq? a (car lat)) (two-in-a-row-b? (car lat) (cdr lat)))))))
+
+(define two-in-a-row?
+ (lambda (lat)
+ (cond
+ ((null? lat) #f)
+ (else (two-in-a-row-b? (car lat) (cdr lat))))))
+
+(define sum-of-prefixes-b
+ (lambda (sonssf tup)
+ (cond
+ ((null? tup) (quote ()))
+ (else (cons (+ sonssf (car tup))
+ (sum-of-prefixes-b (+ sonssf (car tup)) (cdr tup)))))))
+
+(define sum-of-prefixes
+ (lambda (tup)
+ (sum-of-prefixes-b 0 tup)))
+
+(sum-of-prefixes '(1 1 1 1)) ; (1 2 3 4)
+
+;;; {{ The Eleventh Commandment }}
+;;; Use additional arguments when a function needs to know what other
+;;; arguments to the function have been like so far.
+
+(define pick
+ (lambda (n lat)
+ (cond
+ ((one? n) (car lat))
+ (else (pick (sub1 n) (cdr lat))))))
+
+(pick 5 '(a b c d e f g h)) ; e
+
+(define scramble-b
+ (lambda (tup rev-pre)
+ (cond
+ ((null? tup) (quote ()))
+ (else
+ (cons (pick (car tup) (cons (car tup) rev-pre))
+ (scramble-b (cdr tup) (cons (car tup) rev-pre)))))))
+
+(define scramble
+ (lambda (tup)
+ (scramble-b tup (quote ()))))
+
+(scramble '(1 1 1 3 4 2 1 1 9 2)) ; (1 1 1 1 1 4 1 1 1 9)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 12: Take Cover
+
+(define multirember
+ (lambda (a lat)
+ ((Y (lambda (mr)
+ (lambda (lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? a (car lat)) (mr (cdr lat)))
+ (else (cons (car lat) (mr (cdr lat))))))))
+ lat)))
+
+(multirember 'pie '(apple pie other pie what kind of pi?))
+
+(define multirember
+ (lambda (a lat)
+ ((letrec
+ ((mr (lambda (lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? a (car lat))
+ (mr (cdr lat)))
+ (else (cons (car lat)
+ (mr (cdr lat))))))))
+ mr)
+ lat)))
+
+(define multirember
+ (lambda (a lat)
+ (letrec
+ ((mr (lambda (lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? a (car lat))
+ (mr (cdr lat)))
+ (else (cons (car lat)
+ (mr (cdr lat))))))))
+ (mr lat))))
+
+; {{ The Twelfth Commandment }}
+; Use (letrec ..) to remove arguments that do not change for
+; recursive applications.
+
+(define rember-f
+ (lambda (test?)
+ (lambda (a l)
+ (cond
+ ((null? l) (quote ()))
+ ((test? (car l) a) (cdr l))
+ (else (cons (car l)
+ ((rember-f test?) a (cdr l))))))))
+
+(define rember-eq? (rember-f eq?))
+
+(define multirember-f
+ (lambda (test?)
+ (letrec ((m-f (lambda (a lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((test? (car lat) a) (m-f a (cdr lat)))
+ (else (cons (car lat)
+ (m-f a (cdr lat))))))))
+ m-f)))
+
+(define member?
+ (lambda (a lat)
+ (letrec
+ ((yes? (lambda (l)
+ (cond
+ ((null? l) #f)
+ ((eq? (car l) a) #t)
+ (else (yes? (cdr l)))))))
+ (yes? lat))))
+
+(member? 'a '(1 2 3 a b)) ; #t
+(member? 'a '(1 2 3 b)) ; #f
+
+(define union
+ (lambda (a b)
+ (cond
+ ((null? b) a)
+ ((member? (car b) a) (union a (cdr b)))
+ (else (union (cons (car b) a) (cdr b))))))
+
+(union '(tomatoes and macaroni casserole) '(macaroni and cheese))
+
+(define union
+ (lambda (a b)
+ (letrec
+ ((U (lambda (s)
+ (cond
+ ((null? s) b)
+ ((member? (car s) b) (U (cdr s)))
+ (else (cons (car s) (U (cdr s))))))))
+ (U a))))
+
+; if member? had the order of its parameters swapped union would no longer work
+
+(define union
+ (lambda (a b)
+ (letrec
+ ((U (lambda (s)
+ (cond
+ ((null? s) b)
+ ((member? (car s) b) (U (cdr s)))
+ (else (cons (car s) (U (cdr s)))))))
+ (member? (lambda (a lat)
+ (cond
+ ((null? lat) #f)
+ ((eq? a (car lat)) #t)
+ (else (member? a (cdr lat)))))))
+ (U a))))
+
+; {{ The Thirteenth Commandment }}
+; Use (letrec ...) to hide and protect functions.
+
+(define union
+ (lambda (a b)
+ (letrec
+ ((U (lambda (s)
+ (cond
+ ((null? s) b)
+ ((M? (car s) b) (U (cdr s)))
+ (else (cons (car s) (U (cdr s)))))))
+ (M? (lambda (x y)
+ (letrec
+ ((N? (lambda (lat)
+ (cond
+ ((null? lat) #f)
+ ((eq? x (car lat)) #t)
+ (else (member? x (cdr lat)))))))
+ (N? y)))))
+ (U a))))
+
+(define two-in-a-row?
+ (letrec
+ ((W (lambda (a lat)
+ (cond
+ ((null? lat) #f)
+ (else (or (eq? (car lat) a)
+ (W (car lat)
+ (cdr lat))))))))
+ (lambda (lat)
+ (cond
+ ((null? lat) #f)
+ (else (W (car lat) (cdr lat)))))))
+
+(two-in-a-row? '(are there two in a row here)) ; #f
+(two-in-a-row? '(what about around around here)) ; #t
+(define sum-of-prefixes
+ (lambda (tup)
+ (letrec
+ ((B (lambda (sum t)
+ (cond
+ ((null? t) (quote ()))
+ (else (cons (+ (car t) sum) (B (+ (car t) sum) (cdr t))))))))
+ (B 0 tup))))
+
+(sum-of-prefixes '(1 1 1 1 1 1)) ; (1 2 3 4 5 6)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 13: Hop, Skip, and Jump
+
+(define intersect
+ (lambda (a b)
+ (cond
+ ((null? a) (quote ()))
+ ((member? (car a) b)
+ (cons (car a) (intersect (cdr a) b)))
+ (else (intersect (cdr a) b)))))
+
+(intersect '(1 2 3 4 a s d f) '(1 a b c d)) ; (1 a d)
+
+(define intersect
+ (lambda (a b)
+ (letrec
+ ((I (lambda (set)
+ (cond
+ ((null? set) (quote ()))
+ ((member (car set) b)
+ (cons (car set) (I (cdr set))))
+ (else (I (cdr set)))))))
+ (I a))))
+
+(define intersectall
+ (lambda (lset)
+ (letrec
+ ((A (lambda (lset)
+ (cond
+ ((null? (cdr lset)) (car lset))
+ (else (intersect (car lset) (A (cdr lset))))))))
+ (cond
+ ((null? lset) (quote ()))
+ (else (A lset))))))
+
+(intersectall '(() ()))
+(intersectall '( (a b c) (a s d f) (nice day for a walk))) ; (a)
+
+; (letcc hop ...) is the same as
+; (call-with-current-continuation (lambda (hop) ...))
+
+(define intersectall
+ (lambda (lset)
+ (call-with-current-continuation
+ (lambda (hop)
+ (letrec
+ ((A (lambda (lset)
+ (cond
+ ((null? (car lset)) (hop (quote ())))
+ ((null? (cdr lset)) (car lset))
+ (else (intersect (car lset) (A (cdr lset))))))))
+ (cond
+ ((null? lset) (quote ()))
+ (else (A lset))))))))
+
+
+;(define intersectall
+; (lambda (lset)
+; (letcc hop
+; (letrec
+; ((A (lambda (lset)
+; (cond
+; ((null? (car lset)) (hop (quote ())))
+; ((null? (cdr lset)) (car lset))
+; (else (intersect (car lset) (A (cdr lset))))))))
+; (cond
+; ((null? lset) (quote ()))
+; (else (A lset)))))))
+
+(intersectall '( (A B C) (A B D) (A B C))) ; (A B)
+
+; letcc ; not found
+
+(define intersectall
+ (lambda (lset)
+ (call-with-current-continuation
+ (lambda (hop)
+ (letrec
+ ((A (lambda (lset)
+ (cond
+ ((null? (car lset)) (hop (quote ())))
+ ((null? (cdr lset)) (car lset))
+ (else (intersect (car lset) (A (cdr lset)))))))
+ (I (lambda (a b)
+ (letrec
+ ((J (lambda (set)
+ (cond
+ ((null? set) (quote ()))
+ ((member? (car set) b) (J (cdr set)))
+ (else (cons (car set) (J (cdr set))))))))
+ (cond
+ ((null? b) (hop (quote ())))
+ (else (J a)))))))
+ (cond
+ ((null? lset) (quote ()))
+ (else (A lset))))))))
+
+(define rember
+ (lambda (a lat)
+ (letrec
+ ((R (lambda (lat)
+ (cond
+ ((null? lat) (quote ()))
+ ((eq? (car lat) a) (cdr lat))
+ (else (cons (car lat) (R (cdr lat))))))))
+ (R lat))))
+
+(rember 'k '(captain kangaroo k))
+
+(define rember-up-to-last
+ (lambda (a lat)
+ (call-with-current-continuation
+ (lambda (skip)
+ (letrec
+ ((R (lambda (set)
+ (cond
+ ((null? set) (quote ()))
+ ((eq? (car set) a) (skip (R (cdr set))))
+ (else (cons (car set) (R (cdr set))))))))
+ (R lat))))))
+
+(rember-up-to-last 'thing '(wait do we want this thing or that thing last))
+; (last)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 14: Let There be Names
+
+(define leftmost
+ (lambda (l)
+ (cond
+ ((atom? (car l)) (car l))
+ (else (leftmost (car l))))))
+
+(leftmost '((second level) first level)) ; second
+
+(define leftmost
+ (lambda (set)
+ (cond
+ ((null? set) (quote ()))
+ ((atom? (car set)) (car set))
+ (else
+ (cond
+ ((atom? (leftmost (car set))) (leftmost (car set)))
+ (else (leftmost (cdr set))))))))
+
+(leftmost '(((() a) ()))) ; a
+
+(define leftmost
+ (lambda (set)
+ (cond
+ ((null? set) (quote ()))
+ ((atom? (car set)) (car set))
+ (else
+ (let ((thing (leftmost (car set))))
+ (cond
+ ((atom? thing) thing)
+ (else (leftmost (cdr set)))))))))
+
+(define rember1*
+ (lambda (a l)
+ (cond
+ ((null? l) (quote ()))
+ ((atom? (car l)) (cond
+ ((eq? (car l) a) (cdr l))
+ (else (cons (car l) (rember1* a (cdr l))))))
+ (else
+ (let ((tried (rember1* a (car l))))
+ (cond
+ ((eqlist? tried (car l))
+ (cons (car l) (rember1* a (cdr l))))
+ (else (cons tried (cdr l)))))))))
+
+(rember1* 'meat '((pasta meat) pasta (noodles meat sauce) meat tomatoes))
+; ((pasta) pasta (noodles meat sauce) meat tomatoes)
+
+(define depth*
+ (lambda (l)
+ (cond
+ ((null? l) 1)
+ ((atom? (car l)) (depth* (cdr l)))
+ (else
+ (let
+ ((down (add1 (depth* (car l))))
+ (across (depth* (cdr l))))
+ (cond
+ ((> down across) down)
+ (else across)))))))
+
+(> 1 2) ; #f
+(depth* '(c (b (a b) a) a)) ; 3
+
+; this version is redundant!
+(define depth*
+ (lambda (l)
+ (cond
+ ((null? l) 1)
+ (else
+ (let
+ ((across (depth* (cdr l))))
+ (cond
+ ((atom? (car l)) across)
+ (else
+ (let
+ ((down (add1 (depth* (car l)))))
+ (cond
+ ((> down across) down)
+ (else across))))))))))
+
+(max 1 4) ; 4
+
+; {{ The Fifteenth Commandment }}
+; Use (let ...) to name the values of repeated expressions in a function
+; definition if they may be evaluated twice for one and same use of the
+; function. And use (let ...) to name the values of expressions (without
+; set!) that are re-evaluated every time a function is used.
+
+(define depth*
+ (lambda (l)
+ (cond
+ ((null? l) 1)
+ ((atom? (car l)) (depth* (cdr l)))
+ (else (max
+ (add1 (depth* (car l)))
+ (depth* (cdr l)))))))
+
+(depth* '(a (b (c d) (e (f g) 4) 4) 4 2 1)) ; 4
+
+(define leftmost
+ (lambda (l)
+ (call-with-current-continuation
+ (lambda (skip)
+ (lm l skip)))))
+
+(define lm
+ (lambda (l out)
+ (cond
+ ((null? l) (quote ()))
+ ((atom? (car l)) (out (car l)))
+ (else (let ()
+ (lm (car l) out)
+ (lm (cdr l) out))))))
+
+(leftmost '((() a) (b c))) ; a
+
+; could also use a (begin (...) (...) ...) statement instead of
+; (let () (...) (...) ...)
+
+(define leftmost
+ (lambda (l)
+ (call-with-current-continuation
+ (lambda (out)
+ (letrec ((L (lambda (l)
+ (cond
+ ((null? l) (quote ()))
+ ((atom? (car l)) (out (car l)))
+ (else (let ()
+ (L (car l))
+ (L (cdr l))))))))
+ (L l))))))
+
+; try is undefined
+
+;(define rember1*
+; (lambda (a l)
+; (try oh (rm a l oh) l)))
+
+(define rember1*
+ (lambda (a l)
+ (call-with-current-continuation
+ (lambda (success)
+ (begin
+ (call-with-current-continuation
+ (lambda (oh)
+ (success (rm a l oh))))
+ l)))))
+
+(define rm
+ (lambda (a l oh)
+ (cond
+ ((null? l) (oh (quote no)))
+ ((atom? (car l)) (if (eq? (car l) a)
+ (cdr l)
+ (cons (car l) (rm a (cdr l) oh))))
+ (else
+ (call-with-current-continuation
+ (lambda (success)
+ (begin
+ (call-with-current-continuation
+ (lambda (oh2)
+ (success (cons (rm a (car l) oh2) (cdr l)))))
+ (cons (car l) (rm a (cdr l) oh)))))))))
+
+(rember1* 'green '(jolly green giant)) ; (jolly giant)
+(rember1* 'blue '(((is the) (sky)) (ever so (blue da)))) ; good
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 15: The Difference Between Men and Boys...
+
+(define x-thing (cons 'chicago (cons 'pizza '())))
+
+(set! x-thing 'gone) ; returns (chicago pizza)
+(set! x-thing 'skins)
+
+(set! x-thing 'rings)
+
+(define gourmand
+ (lambda (food)
+ (set! x-thing food)
+ (cons food
+ (cons x-thing (quote ())))))
+
+(gourmand 'potato)
+
+(define omnivore
+ (let ((x-thing (quote soup)))
+ (lambda (food)
+ (set! x-thing food)
+ (cons food (cons x-thing '())))))
+
+(omnivore 'bread)
+x-thing ; potato
+
+; {{ The Sixteenth Commandment }}
+; Use (set! ...) only with names define in (let ...)s
+
+; {{ The Seventeenth Commandment }}
+; Use (set! x ...) for (let ((x ..)) ..)) only if there is at least one
+; (lambda .. between it and the (let ..), or if the new value for x is a
+; function that refers to x.
+
+(define nibbler
+ (lambda (food)
+ (let ((x-thing (quote donut)))
+ (set! x-thing food)
+ (cons food
+ (cons x-thing '())))))
+
+(nibbler 'boat)
+x-thing ; not boat
+
+(define foody (quote nothing))
+
+
+(define glutton
+ (lambda (x-thing)
+ (set! food x-thing)
+ (cons (quote more)
+ (cons x
+ (cons (quote more) (cons x (quote ())))))))
+
+(glutton 'garlic)
+
+
+