diff options
Diffstat (limited to 'other/seasoned_schemer.scm')
| -rw-r--r-- | other/seasoned_schemer.scm | 640 |
1 files changed, 640 insertions, 0 deletions
diff --git a/other/seasoned_schemer.scm b/other/seasoned_schemer.scm new file mode 100644 index 0000000..50d882d --- /dev/null +++ b/other/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) + + + |