Finished seasoned schemer!

Signed-off-by: Bryan Newbold <bnewbold@eta.mit.edu>

1 files changed, 635 insertions, 3 deletions

diff --git a/other/seasoned_schemer.scm b/other/seasoned_schemer.scm
index e81f07d..bcbad30 100644
--- a/other/seasoned_schemer.scm
+++ b/other/seasoned_schemer.scm
@@ -44,6 +44,14 @@
 (eqlist? '(((this) is (a)) nontrivial (list))
 	 '(((this) is (a)) nontrivial (list))) ; #t
 
+; needed in not-mechanics
+(define one?
+  (lambda (x)
+    (zero? (sub1 x))))
+
+(one? 2) ; #f
+(one? 1) ; #t
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; Chapter 01: Welsome Back to the Show
 
@@ -931,7 +939,8 @@ Ns ; (12 11 10 9 5 2 1 4)
       (S 1000)
       (counter))))
 
-(supercounter deep) ; 1233002, b/c I ran with something else first
+; takes a long time to run
+;(supercounter deep) ; 1233002, b/c I ran with something else first
 
 (define counter)
 (define set-counter)
@@ -947,7 +956,8 @@ Ns ; (12 11 10 9 5 2 1 4)
 
 (set-counter 0)
 
-(supercounter deep) ; 500500
+; takes a long time to run
+;(supercounter deep) ; 500500
 (set-counter 0)
 (define deepM
   (let ((Rs (quote ()))
@@ -963,7 +973,8 @@ Ns ; (12 11 10 9 5 2 1 4)
 	      result)
 	    exists)))))
 
-(supercounter deepM) ; 1000
+;this takes a long time to run
+;(supercounter deepM) ; 1000
 
 ; "A LISP programmer knows the value of everything but the cost of nothing"
 
@@ -1054,3 +1065,624 @@ Ns ; (12 11 10 9 5 2 1 4)
   (lambda (c)
     (c (lambda (s a d) d))))
 
+(define kons
+  (lambda (a d)
+    (let ((c (bons a)))
+      (set-kdr c d)
+      c)))
+
+(define kounter)
+(define set-kounter)
+(define konsC
+  (let ((N 0))
+    (set! kounter (lambda () N))
+    (set! set-kounter (lambda (x) (set! N x)))
+    (lambda (a b)
+      (set! N (add1 N))
+      (kons a b))))
+
+(set-kounter 33)
+(kounter) ; 33
+(set-kounter 0)
+
+(define add-at-end
+  (lambda (l)
+    (cond
+     ((null? (kdr l))
+      (konsC (kar l)
+	     (kons (quote egg) (quote ()))))
+     (else (konsC (kar l)
+		  (add-at-end (kdr l)))))))
+
+(add-at-end (lots 3))
+(kounter) ; 3
+
+(define add-at-end-too
+  (lambda (l)
+    (letrec
+	((A (lambda (ls)
+	      (cond
+	       ((null? (kdr ls)) 
+		(set-kdr ls (konsC (quote egg) (quote ()))))))))
+      (A l)
+      l)))
+
+(define set-kdr
+  (lambda (c x)
+    ((c (lambda (s a d) s)) x)))
+
+(define lots
+  (lambda (m)
+    (cond
+     ((zero? m) (quote ()))
+     (else (kons (quote egg)
+		 (lots (sub1 m)))))))
+
+(define lenkth
+  (lambda (l)
+    (cond 
+     ((null? l) 0)
+     (else (add1 (lenkth (kdr l)))))))
+
+(lots 8) ; [procedure]
+(lenkth (lots 9)) ; 9
+
+(set-kounter 0)
+(define dozen (lots 12))
+(kounter) ; 0
+
+(define bakers-dozen
+  (add-at-end dozen))
+
+(kounter) ; 12
+
+(lenkth bakers-dozen) ; 13
+
+(define bakers-dozen-too (add-at-end-too dozen))
+
+(kounter)
+
+(define eklist?
+  (lambda (ls1 ls2)
+    (cond
+     ((null? ls1) (null? ls2))
+     ((null? ls2) #f)
+     (else (and (eq? (kar ls1) (kar ls2))
+		(eklist? (kdr ls1) (kdr ls2)))))))
+
+(define same?
+  (lambda (c1 c2)
+    (let ((t1 (kdr c1))
+	  (t2 (kdr c2)))
+      (set-kdr c1 1)
+      (set-kdr c2 2)
+      (let ((v (= (kdr c1) (kdr c2))))
+	(set-kdr c1 t1)
+	(set-kdr c2 t2)
+	v))))
+
+(same? bakers-dozen bakers-dozen-too) ; #f .... hmmm
+
+(define last-kons
+  (lambda (ls)
+    (cond
+     ((null? (kdr ls)) ls)
+     (else (last-kons (kdr ls))))))
+
+(define long (lots 12))
+
+(set-kdr (last-kons long) long)
+
+;(lenkth long) ; haha! looped around!
+
+(define finite-lenkth
+  (lambda (p)
+    (call-with-current-continuation
+     (lambda (infinite)
+       (letrec
+	   ((C (lambda (p q)
+		 (cond
+		  ((same? p q) (infinite #f))
+		  ((null? q) 0)
+		  ((null? (kdr q)) 1)
+		  (else (+ (C (sl p) (qk q)) 2)))))
+	    (qk (lambda (x) (kdr (kdr x))))
+	    (sl (lambda (x) (kdr x))))
+	 (cond
+	  ((null? p) 0)
+	  (else (add1 (C p (kdr p))))))))))
+
+(finite-lenkth long) ; #f yay!
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 19: Absconding with the Jewels
+
+; {{ The Twentieth Commandment }}
+; When thinking about a value created with (letcc ...), write down the
+; function that is equivalent but does not forget. Then, when you use it,
+; remember to forget.
+
+(define deep&co
+  (lambda (m k)
+    (cond
+     ((zero? m) (k (quote pizza)))
+     (else
+      (deep&co (sub1 m) (lambda (x)
+			  (k (cons x (quote ())))))))))
+
+(deep&co 0 (lambda (x) x)) ; pizza
+(deep&co 6 (lambda (x) x)) ; ((((((pizza))))))
+
+(define two-layers
+  (lambda (p)
+    (cons
+     (cons p (quote ()))
+     (quote ()))))
+
+(define deep&coB
+  (lambda (m k)
+    (cond
+     ((zero? m)
+      (let ()
+	(set! toppings k)
+	(k (quote pizza))))
+     (else
+      (deep&coB (sub1 m)
+		(lambda (x)
+		  (k (cons x (quote ())))))))))
+
+(define two-in-a-row?
+  (letrec
+      ((W (lambda (a lat)
+	    (cond
+	     ((null? lat) #f)
+	     (else
+	      (let ((nxt (car lat)))
+		(or (eq? nxt a)
+		    (W nxt (cdr lat)))))))))
+    (lambda (lat)
+      (cond ((null? lat) #f)
+	    (else (W (car lat) (cdr lat)))))))
+
+; it's not two-in-a-row*?
+(two-in-a-row? '(((tomato) paste (tastes)) so (so great))) ; #f 
+(two-in-a-row? '(a a)) ; #t
+
+(define leave)
+
+(define walk
+  (lambda (l)
+    (cond
+     ((null? l) (quote ()))
+     ((atom? (car l)) (leave (car l)))
+     (else
+      (let ()
+	(walk (car l))
+	(walk (cdr l)))))))
+
+(define start-it
+  (lambda (l)
+    (call-with-current-continuation
+     (lambda (here)
+       (set! leave here)
+       (walk l)))))
+
+(define fill)
+
+(define waddle
+  (lambda (l)
+    (cond
+     ((null? l) (quote ()))
+     ((atom? (car l))
+      (let ()
+	(call-with-current-continuation
+	 (lambda (rest)
+	   (set! fill rest)
+	   (leave (car l))))
+	(waddle (cdr l)))
+      (else (let ()
+	      (waddle (car l))
+	      (waddle (cdr l))))))))
+
+(define start-it2
+  (lambda (l)
+    (call-with-current-continuation
+     (lambda (here)
+       (set! leave here)
+       (waddle l)))))
+
+(define get-next
+  (lambda (x)
+    (call-with-current-continuation
+     (lambda (here-again)
+       (set! leave here-again)
+       (fill (quote go))))))
+
+(define get-first
+  (lambda (l)
+    (call-with-current-continuation
+     (lambda (here)
+       (set! leave here)
+       (waddle l)
+       (leave (quote ()))))))
+
+
+(start-it2 '((donuts) cheerios (cheerios (spaghettios)) donuts))
+(get-first '(a b c d e f g h i)) ; a
+(get-first '(a)) ; a
+;(get-next (quote go)) ; error... maybe do many defines
+(get-first '((fish) and (chips (chips))))
+;(get-next 'go)
+
+; i think there might be an error with waddle given
+; call-with-current-continuation works... i should try to fix it?
+
+; well, it works below here, so probably just confused above somwhere
+
+(define two-in-a-row*?
+  (letrec
+      ((T? (lambda (a)
+	     (let ((n (get-next 0)))
+	       (if (atom? n)
+		   (or (eq? n a) (T? n))
+		   #f))))
+       (get-next (lambda (x)
+		   (call-with-current-continuation
+		    (lambda (here-again)
+		      (set! leave here-again)
+		      (fill (quote go))))))
+       (fill (lambda (x) x))
+       (waddle
+	(lambda (l)
+	  (cond
+	   ((null? l) (quote ()))
+	   ((atom? (car l)) (let ()
+			      (call-with-current-continuation
+			       (lambda (rest)
+				 (set! fill rest)
+				 (leave (car l))))
+			      (waddle (cdr l))))
+	   (else (let ()
+		   (waddle (car l))
+		   (waddle (cdr l)))))))
+       (leave (lambda (x) x)))
+    (lambda (l)
+      (let ((fst (call-with-current-continuation
+		  (lambda (here)
+		    (set! leave here)
+		    (waddle l)
+		    (leave (quote ()))))))
+	(if (atom? fst) (T? fst) #f)))))
+
+(two-in-a-row*? '(a b c c)) ; #t
+(two-in-a-row*? '(((fish) and (chips are) (well) well) what)) ; #t
+(two-in-a-row*? '(((fish) and (chips are) (well)) what)) ; #f
+
+; sweet
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; Chapter 20: What's in Store?
+
+; lots of definitions, just going to throw them out in whatever order
+
+(define lookup
+  (lambda (table name)
+    (table name)))
+
+; so if the passed value is equal to our name give our value, otherwise
+; pass to next in line
+(define extend
+  (lambda (name1 value table)
+    (lambda (name2)
+      (cond
+       ((eq? name2 name1) value)
+       (else (table name2))))))
+
+(define define?
+  (lambda (e)
+    (cond
+     ((atom? e) #f)
+     ((atom? (car e)) (eq? (car e) (quote define)))
+     (else #f))))
+
+(define *define
+  (lambda (e)
+    (set! global-table (extend (name-of e) 
+			       (box (The-Meaning (right-side-of e)))
+			       global-table))))
+
+(define box
+  (lambda (it)
+    (lambda (sel)
+      (sel it (lambda (new) (set! it new))))))
+
+(define setbox
+  (lambda (box new)
+    (box (lambda (it set) (set new)))))
+
+(define unbox
+  (lambda (box)
+    (box (lambda (it set) it))))
+
+(define The-Meaning
+  (lambda (e)
+    (meaning e lookup-in-global-table)))
+
+(define lookup-in-global-table
+  (lambda (name)
+    (lookup global-table name)))
+
+(define meaning
+  (lambda (e table)
+    ((expression-to-action e)
+     e table)))
+
+(define *quote
+  (lambda (e table)
+    (text-of e)))
+
+(define *identifier
+  (lambda (e table)
+    (unbox (lookup table e))))
+
+(define *set
+  (lambda (e table)
+    (setbox
+     (lookup table (name-of e))
+     (meaning (right-side-of e) table))))
+
+(define *lambda
+  (lambda (e table)
+    (lambda (args)
+      (beglis (body-of e)
+	      (multi-extend (formals-of e) (box-all args) table)))))
+
+(define beglis
+  (lambda (es table)
+    (cond
+     ((null? (cdr es))
+      (meaning (car es) table))
+     (else ((lambda (val)
+	      (beglis (cdr es) table))
+	    (meaning (car es) table))))))
+
+(define box-all
+  (lambda (vals)
+    (cond
+     ((null? vals) (quote ()))
+     (else (cons (box (car vals))
+		 (box-all (cdr vals)))))))
+
+(define multi-extend
+  (lambda (names values table)
+    (cond
+     ((null? names) table)
+     (else
+      (extend (car names) 
+	      (car values)
+	      (multi-extend (cdr names) (cdr values) table))))))
+
+(define *application
+  (lambda (e table)
+    ((meaning (function-of e) table)
+     (evlis (arguments-of e) table))))
+
+(define evlis
+  (lambda (args table)
+    (cond
+     ((null? args) (quote ()))
+     (else
+      ((lambda (val)
+	 (cons val (evlis (cdr args) table)))
+       (meaning (car args) table))))))
+
+(define :car
+  (lambda (args-in-a-list)
+    (car (car args-in-a-list))))
+
+(define a-prim
+  (lambda (p)
+    (lambda (args-in-a-list)
+      (p (car args-in-a-list)))))
+
+(define b-prim
+  (lambda (p)
+    (lambda (args-in-a-list)
+      (p (car args-in-a-list) (car (cdr args-in-a-list))))))
+
+(define *const
+  (lambda (e table)
+    (cond
+     ((number? e) e)
+     ((eq? e #t) #t)
+     ((eq? e #f) #f)
+     ((eq? e (quote cons)) (b-prim cons))
+     ((eq? e (quote car)) (a-prim car))
+     ((eq? e (quote cdr)) (a-prim cdr))
+     ((eq? e (quote eq?)) (b-prim eq?))
+     ((eq? e (quote atom?)) (a-prim atom?))
+     ((eq? e (quote null?)) (a-prim null?))
+     ((eq? e (quote zero?)) (a-prim zero?))
+     ((eq? e (quote add1)) (a-prim add1))
+     ((eq? e (quote sub1)) (a-prim sub1))
+     ((eq? e (quote number?)) (a-prim number?)))))
+
+; whew!
+
+; crap, don't want to have to do a-prim/b-prim every time but 
+; also avoiding (let ...) for whatever reason
+
+(define *const
+  ((lambda (:cons :car :cdr :null? :eq? :atom? :zero? :add1 :sub1 :number?)
+     (lambda (e table)
+       (cond
+	((number? e) e)
+	((eq? e #t) #t)
+	((eq? e #f) #f)
+	((eq? e (quote cons)) :cons)
+	((eq? e (quote car)) :car)
+	((eq? e (quote cdr)) :cdr)
+	((eq? e (quote eq?)) :eq?)
+	((eq? e (quote atom?)) :atom?)
+	((eq? e (quote null?)) :null?)
+	((eq? e (quote zero?)) :zero?)
+	((eq? e (quote add1)) :add1)
+	((eq? e (quote sub1)) :sub1)
+	((eq? e (quote number?)) :number?))))
+   (b-prim cons)
+   (a-prim car)
+   (a-prim cdr)
+   (a-prim null?)
+   (b-prim eq?)
+   (a-prim atom?)
+   (a-prim zero?)
+   (a-prim add1)
+   (a-prim sub1)
+   (a-prim number?)))
+
+; double whew!
+
+(define *cond
+  (lambda (e table)
+    (evcon (cond-lines-of e) table)))
+
+(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 *letcc
+  (lambda (e table)
+    (call-with-current-continuation
+     (lambda (skip)
+       (beglis (ccbody-of e) (extend (name-of e)
+				     (box (a-prim skip))
+				     table))))))
+
+(define abort)
+(define value
+  (lambda (e)
+    (call-with-current-continuation
+     (lambda (the-end)
+       (set! abort the-end)
+       (cond
+	((define? e) (*define e))
+	(else (The-Meaning e)))))))
+
+; is there any language/interpreter which, when it runs into an undefined
+; value, lets you define it on the spot? would be great for learners
+
+(define the-empty-table
+  (lambda (name)
+    (abort (cons (quote no-answer) (cons name (quote ()))))))
+
+(define expression-to-action
+  (lambda (e)
+    (cond
+     ((atom? e) (atom-to-action e))
+     (else (list-to-action e)))))
+
+(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))))
+
+(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 letcc)) *letcc)
+       ((eq? (car e) (quote set!)) *set)
+       ((eq? (car e) (quote cond)) *cond)
+       (else *application)))
+     (else *application))))
+
+;leftovers...
+(define text-of
+  (lambda (x)
+    (car (cdr x))))
+(define formals-of
+  (lambda (x)
+    (car (cdr x))))
+(define body-of
+  (lambda (x)
+    (cdr (cdr x))))
+(define ccbody-of
+  (lambda (x)
+    (cdr (cdr x))))
+(define name-of
+  (lambda (x)
+    (car (cdr x))))
+(define right-side-of
+  (lambda (x)
+    (cond
+     ((null? (cdr (cdr x))) 0)
+     (else (car (cdr (cdr x)))))))
+(define cond-lines-of
+  (lambda (x)
+    (cdr x)))
+(define question-of
+  (lambda (x)
+    (car x)))
+(define answer-of
+  (lambda (x)
+    (car (cdr x))))
+(define function-of
+  (lambda (x)
+    (car x)))
+(define arguments-of
+  (lambda (x)
+    (cdr x)))
+
+; the right-side-of part is for things like (define stub)
+(define global-table the-empty-table)
+
+(value '(value 1))
+(value '(add1 4)) ; 5
+(value '(define x 7))
+(value 'x) ; 7
+(value '(define even?
+	  (lambda (x)
+	    (cond
+	     ((zero? x) #t)
+	     (else (odd? (sub1 x)))))))
+(value '(define odd?
+	  (lambda (x)
+	    (cond
+	     ((zero? x) #f)
+	     (else (even? (sub1 x)))))))
+(value '(odd? 3)) ; #t
+(value '(odd? 32)) ; slow... but #f!
+
+; i'm kind of miffed that the (letcc ...) definition basically just uses
+; letcc, because magic North Pole compasses seem like the most interesting 
+; part.
+
+