diff options
| -rw-r--r-- | other/seasoned_schemer.scm | 426 |
1 files changed, 421 insertions, 5 deletions
diff --git a/other/seasoned_schemer.scm b/other/seasoned_schemer.scm index 50d882d..e81f07d 100644 --- a/other/seasoned_schemer.scm +++ b/other/seasoned_schemer.scm @@ -624,17 +624,433 @@ x-thing ; potato (nibbler 'boat) x-thing ; not boat -(define foody (quote nothing)) - +(define food (quote nothing)) (define glutton (lambda (x-thing) (set! food x-thing) (cons (quote more) - (cons x - (cons (quote more) (cons x (quote ()))))))) + (cons x-thing + (cons (quote more) (cons x-thing (quote ()))))))) + +(glutton 'garlic); (more garlic more garlic) + +(define chez-nous + (lambda () + (let ((a food)) + (set! food x-thing) + (set! x-thing a)))) + +food ; garlic +x-thing ; potato +(chez-nous) +food ; potato +x-thing ; garlic + +; {{ The Eighteenth Commandment }} +; Use (set! x ...) only when the value that x refers to is no longer needed. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Chapter 16: Ready, Set, Bang! + +(define sweet-tooth + (lambda (food) + (cons food (cons (quote cake) (quote ()))))) + +(define last (quote angelfood)) + +(sweet-tooth last) ; (angelfood cake) + +(define sweet-toothL + (lambda (food) + (set! last food) + (cons food (cons (quote cake) (quote ()))))) + +(sweet-toothL (quote chocolate)) ; (chocolate cake) +last ; chocolate -(glutton 'garlic) +(define ingredients (quote ())) +(define sweet-toothR + (lambda (food) + (set! ingredients (cons food ingredients)) + (cons food (cons (quote cake) (quote ()))))) + +(sweet-toothR 'chocolate) +(sweet-toothR 'fruit) +(sweet-toothR 'cheese) +ingredients ; (cheese fruit chocolate) + +(define deep + (lambda (m) + (cond + ((zero? m) (quote pizza)) + (else (cons (deep (sub1 m)) (quote ())))))) + +(deep 4) ; ((((pizza)))) + +(define Rs (quote ())) +(define Ns (quote ())) + +(define deepR + (lambda (n) + (let ((result (deep n))) + (set! Ns (cons n Ns)) + (set! Rs (cons result Rs)) + result))) + +(deepR 4) +(deepR 1) +(deepR 2) +Rs +Ns ; (2 1 4) + +; {{ The Nineteenth Commandment }} +; Use (set! ...) to remember valuable things between two distinct uses of a +; function. + +(define find + (lambda (n Ns Rs) + (letrec + ((A (lambda (ns rs) + (cond + ((= (car ns) n) (car rs)) + (else (A (cdr ns) (cdr rs))))))) + (A Ns Rs)))) +(find 4 Ns Rs) + +(define deepM + (lambda (n) + (if (member? n Ns) + (find n Ns Rs) + (deepR n)))) +(deepM 4) ; ((((pizza)))) +(deepM 5) ; (((((pizza))))) +Ns ; (5 2 1 4) + +(define deepM + (lambda (n) + (if (member? n Ns) + (find n Ns Rs) + (let ((result (deep n))) + (set! Rs (cons result Rs)) + (set! Ns (cons n Ns)) + result)))) + +(deepM 9) +Ns ; (9 5 2 1 4) + +(define deep + (lambda (m) + (cond + ((zero? m) (quote pizza)) + (else (cons (deepM (sub1 m)) (quote ())))))) + +(deepM 12) +Ns ; (12 11 10 9 5 2 1 4) + +(define deepM + (let ((Rs (quote ())) + (Ns (quote ()))) + (lambda (n) + (if (member? n Ns) + (find n Ns Rs) + (let ((result (deep n))) + (set! Rs (cons result Rs)) + (set! Ns (cons n Ns)) + result))))) + +(deepM 16) + +(define find + (lambda (n Ns Rs) + (letrec + ((A (lambda (ns rs) + (cond + ((null? ns) #f) + ((= (car ns) n) (car rs)) + (else (A (cdr ns) (cdr rs))))))) + (A Ns Rs)))) + +(define deepM + (let ((Rs (quote ())) + (Ns (quote ()))) + (lambda (n) + (let ((exists (find n Ns Rs))) + (if (atom? exists) + (let ((result (deep n))) + (set! Rs (cons result Rs)) + (set! Ns (cons n Ns)) + result) + exits))))) + +(deepM 15) + +(length '(a b c d)) + +(define length + (let ((h (lambda (l) 0))) + (set! h + (lambda (l) + (cond + ((null? l) 0) + (else (add1 (h (cdr l))))))) + h)) + +(define L + (lambda (length) + (lambda (l) + (cond + ((null? l) 0) + (else (add1 (length (cdr l)))))))) + +(define length + (let ((h (lambda (l) 0))) + (set! h (L (lambda (arg) (h arg)))) + h)) + +(length '(1 2 3)) ; 3 + +(define Y-bang + (lambda (f) + (letrec + ((h (f (lambda (arg) (h arg))))) + h))) + +(define length (Y-bang L)) + +; Y-bang is the "applicative-order imperative Y combinator." + +(define D + (lambda (depth*) + (lambda (s) + (cond + ((null? s) 1) + ((atom? (car s)) (depth* (cdr s))) + (else + (max + (add1 (depth* (car s))) + (depth* (cdr s)))))))) + +(define depth* (Y-bang D)) + +(depth* '(((asdf d)) (d (a)))) ; 3 + +(define bizarre + (let ((x 0)) + (lambda (f) + (set! x (add1 x)) + (lambda (a) + (if (= a x) + 0 + (f a)))))) + +;((Y-bang bizarre) 3) ; infinite recurse +((Y bizarre) 3) ; 0 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Chapter 17: We Change, Therefore We Are! + +(define deep + (lambda (m) + (if (zero? m) + (quote pizza) + (cons (deep (sub1 m)) + (quote ()))))) + +(define deepM + (let ((Rs (quote ())) + (Ns (quote ()))) + (letrec + ((D (lambda (m) + (if (zero? m) + (quote pizza) + (cons (deepM (sub1 m)) (quote ())))))) + (lambda (n) + (let ((exists (find n Ns Rs))) + (if (atom? exists) + (let ((result (D n))) + (set! Rs (cons result Rs)) + (set! Ns (cons n Ns)) + result) + exists)))))) + +(define deepM + (let ((Rs (quote ())) + (Ns (quote ()))) + (lambda (n) + (let ((exists (find n Ns Rs))) + (if (atom? exists) + (let ((result (if (zero? n) + (quote pizza) + (cons (deepM (sub1 n)) (quote ()))))) + (set! Rs (cons result Rs)) + (set! Ns (cons n Ns)) + result) + exists))))) + +(deepM 30) ; good + +(define consC + (let ((N 0)) + (lambda (x y) + (set! N (add1 N)) + (cons x y)))) + +; but then can't get the internal N! + +(define counter) +(define consC + (let ((N 0)) + (set! counter (lambda () N)) + (lambda (x y) + (set! N (add1 N)) + (cons x y)))) + +(counter) ; 0 + +(define deep + (lambda (m) + (if (zero? m) + (quote pizza) + (consC (deep (sub1 m)) (quote ()))))) + +(deep 5) +(counter) ; 5 + +(define supercounter + (lambda (f) + (letrec + ((S (lambda (n) + (if (zero? n) + (f n) + (let () + (f n) + (S (sub1 n))))))) + (S 1000) + (counter)))) + +(supercounter deep) ; 1233002, b/c I ran with something else first + +(define counter) +(define set-counter) +(define consC + (let ((N 0)) + (set! counter (lambda () N)) + (set! set-counter + (lambda (x) + (set! N x))) + (lambda (x y) + (set! N (add1 N)) + (cons x y)))) + +(set-counter 0) + +(supercounter deep) ; 500500 +(set-counter 0) +(define deepM + (let ((Rs (quote ())) + (Ns (quote ()))) + (lambda (n) + (let ((exists (find n Ns Rs))) + (if (atom? exists) + (let ((result (if (zero? n) + (quote pizza) + (consC (deepM (sub1 n)) (quote ()))))) + (set! Rs (cons result Rs)) + (set! Ns (cons n Ns)) + result) + exists))))) + +(supercounter deepM) ; 1000 + +; "A LISP programmer knows the value of everything but the cost of nothing" + +;(pp rember1*) ; refers to oh etc + + +(define rember1*C + (lambda (a l) + (letrec + ((R (lambda (l oh) + (cond + ((null? l) (oh (quote no))) + ((atom? (car l)) (if (eq? (car l) a) + (cdr l) + (consC (car l) (R (cdr l) oh)))) + (else + (let ((new-car + (call-with-current-continuation + (lambda (oh) + (R (car l) oh))))) + (if (atom? new-car) + (consC (car l) + (R (cdr l) oh)) + (consC new-car (cdr l))))))))) + (let ((new-l (call-with-current-continuation + (lambda (oh) (R l oh))))) + (if (atom? new-l) + l + new-l))))) + +(rember1*C 'noodles '((food) more (food))) ; ((food) more (food)) +(rember1*C 'noodles '((food) more (noodles food))) ; ((food) more (food)) + +(define rember1*C2 + (lambda (a l) + (letrec + ((R (lambda (l) + (cond + ((null? l) (quote ())) + ((atom? (car l)) (if (eq? (car l) a) + (cdr l) + (consC (car l) (R (cdr l))))) + (else + (let ((av (R (car l)))) + (if (eqlist? (car l) av) + (consC (car l) (R (cdr l))) + (consC av (cdr l))))))))) + (R l)))) + +(set-counter 0) +(rember1*C 'noodles '((food) more (food))) +(counter) ; 0 +(rember1*C2 'noodles '((food) more (food))) +(counter) ; 5 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Chapter 18: We Change, Therefore We Are the Same! + +(cons (quote ()) (quote ())) ; (()) + +(define kons + (lambda (kar kdr) + (lambda (selector) + (selector kar kdr)))) + +(define kar + (lambda (c) + (c (lambda (a d) a)))) + +(define kdr + (lambda (c) + (c (lambda (a d) d)))) + +(define bons + (lambda (kar) + (let ((kdr (quote ()))) + (lambda (selector) + (selector + (lambda (x) (set! kdr x)) + kar + kdr))))) + +(define kar + (lambda (c) + (c (lambda (s a d) a)))) + +(define kdr + (lambda (c) + (c (lambda (s a d) d)))) |