aboutsummaryrefslogtreecommitdiffstats
path: root/other
diff options
context:
space:
mode:
Diffstat (limited to 'other')
-rw-r--r--other/seasoned_schemer.scm638
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.
+
+