aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--other/seasoned_schemer.scm426
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))))