diff options
Diffstat (limited to 'little_schemer.scm')
| -rw-r--r-- | little_schemer.scm | 1335 |
1 files changed, 1335 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 |