Permalink
Browse files

little schemer chapter 10

  • Loading branch information...
1 parent c9f27f1 commit f016787032c284b78673c6b6523d0e30df9ba7db @jaz303 committed Apr 15, 2012
Showing with 219 additions and 0 deletions.
  1. +219 −0 little-schemer/little-schemer.rkt
View
219 little-schemer/little-schemer.rkt
@@ -583,7 +583,226 @@
(lambda (newl p s)
(col (cons al newl) (* p ap) (+ s as))))))))))
+ ; Chapter 9 - ...and Again, and Again, and Again,....
+
+ (define keep-looking
+ (lambda (a sorn lat)
+ (cond
+ ((number? sorn) (keep-looking a (pick sorn lat) lat))
+ (else (eq? sorn a)))))
+
+ (define eternity
+ (lambda (x)
+ (eternity x)))
+
+ (define shift
+ (lambda (pair)
+ (build (first (first pair))
+ (build (second (first pair))
+ (second pair)))))
+
+ (define align
+ (lambda (pora)
+ (cond
+ ((atom? pora) pora)
+ ((a-pair? (first pora))
+ (align (shift pora)))
+ (else (build (first pora) (align (second pora)))))))
+
+ ((lambda (mk-length)
+ (mk-length eternity))
+ (lambda (length)
+ (lambda (l)
+ (cond
+ ((null? l) 0)
+ (else (add1 (length (cdr l))))))))
+
+
+ ; Chapter 10
+
+ (define new-entry build)
+
+ (define lookup-in-entry-help
+ (lambda (name names values entry-f)
+ (cond
+ ((null? names) (entry-f name))
+ ((eq? (car names) name) (car values))
+ (else
+ (lookup-in-entry-help name (cdr names) (cdr values) entry-f)))))
+
+ (define lookup-in-entry
+ (lambda (name entry entry-f)
+ (lookup-in-entry-help name (first entry) (second entry) entry-f)))
+
+ (define extend-table cons)
+
+ (define lookup-in-table
+ (lambda (name table table-f)
+ (cond
+ ((null? table) (table-f name))
+ (else
+ (lookup-in-entry name (car table)
+ (lambda (name2)
+ (lookup-in-table name2 (cdr table) table-f)))))))
+
+ (define expression-to-action
+ (lambda (e)
+ (cond
+ ((atom? e) (atom-to-action e))
+ (else (list-to-action e)))))
+
+ (define atom-to-action
+ (lambda (a)
+ (cond
+ ((number? a) *const)
+ ((eq? a #t) *const)
+ ((eq? a #f) *const)
+ ((eq? a 'cons) *const)
+ ((eq? a 'car) *const)
+ ((eq? a 'cdr) *const)
+ ((eq? a 'atom?) *const)
+ ((eq? a 'null?) *const)
+ ((eq? a 'eq?) *const)
+ ((eq? a 'zero?) *const)
+ ((eq? a 'add1) *const)
+ ((eq? a 'sub1) *const)
+ ((eq? a 'number) *const)
+ (else *identifier))))
+
+ (define list-to-action
+ (lambda (l)
+ (cond
+ ((atom? (car l))
+ (cond
+ ((eq? 'quote (car e)) *quote)
+ ((eq? 'lambda (car e)) *lambda)
+ ((eq? 'cond (car e)) *cond)
+ (else *application)))
+ (else *application))))
+
+ (define value
+ (lambda (e)
+ (meaning e '())))
+
+ (define meaning
+ (lambda (e table)
+ ((expression-to-action e) e table)))
+
+ (define *const
+ (lambda (e table)
+ (cond
+ ((number? e) e)
+ ((eq? e #t) #t)
+ ((eq? e #f) #f)
+ (else (build 'primitive e)))))
+
+ (define *quote
+ (lambda (e table)
+ (text-of e)))
+
+ (define text-of second)
+
+ (define *identifier
+ (lambda (e table)
+ (lookup-in-table e table initial-table)))
+
+ (define initial-table
+ (lambda (name)
+ (car '())))
+
+ (define *lambda
+ (lambda (e table)
+ (build 'non-primitive (cons table (cdr e)))))
+
+ (define table-of first)
+ (define formals-of second)
+ (define body-of third)
+
+ (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 'else))
+ (else #f))))
+
+ (define question-of first)
+ (define answer-of second)
+
+ (define *cond
+ (lambda (e table)
+ (evcon (cond-lines-of e) table)))
+
+ (define cond-lines-of cdr)
+
+ (define evlis
+ (lambda (args table)
+ (cond
+ ((null? args) '())
+ (else (cons (meaning (car args) table) (evlis (cdr args) table))))))
+
+ (define *application
+ (lambda (e table)
+ (apply1
+ (meaning (function-of e) table)
+ (evlis (arguments-of e) table))))
+
+ (define function-of car)
+ (define arguments-of cdr)
+
+ (define primitive?
+ (lambda (l)
+ (eq? (first l) 'primitive)))
+
+ (define non-primitive?
+ (lambda (l)
+ (eq? (first l) 'non-primitive)))
+
+ (define apply1
+ (lambda (fun vals)
+ (cond
+ ((primitive? fun)
+ (apply-primitive (second fun) vals))
+ ((non-primitive? fun)
+ (apply-closure (second fun) vals)))))
+
+ (define apply-primitive
+ (lambda (name vals)
+ (cond
+ ((eq? name 'cons) (cons (first vals) (second vals)))
+ ((eq? name 'car) (car (first vals)))
+ ((eq? name 'cdr) (cdr (first vals)))
+ ((eq? name 'null?) (null? (first vals)))
+ ((eq? name 'eq?) (eq? (first vals) (second vals)))
+ ((eq? name 'atom?) (:atom? (first vals)))
+ ((eq? name 'zero?) (zero? (first vals)))
+ ((eq? name 'add1) (add1 (first vals)))
+ ((eq? name 'sub1) (sub1 (first vals)))
+ ((eq? name 'number?) (number? (first vals))))))
+
+ (define :atom?
+ (lambda (e)
+ (cond
+ ((atom? e) #t)
+ ((null? e) #f)
+ ((eq? (car x) 'primitive) #t)
+ ((eq? (car x) 'non-primitive) #t)
+ (else #f))))
+
+ (define apply-closure
+ (lambda (closure vals)
+ (meaning (body-of closure) (extend-table
+ (new-entry
+ (formals-of closure)
+ vals)
+ (table-of closure)))))
)
+

0 comments on commit f016787

Please sign in to comment.