diff options
| -rw-r--r-- | other/seasoned_schemer.scm | 638 |
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. + + |