[sicp] Finish section 4.1.6: First working evaluator

1 files changed, 301 insertions, 0 deletions

diff --git a/sicp/chapter4.scm b/sicp/chapter4.scm
new file mode 100644
index 0000000..d3919ce
--- /dev/null
+++ b/sicp/chapter4.scm
@@ -0,0 +1,301 @@
+; Exercise 4.11
+(define (make-frame bindings) (cons '*frame* bindings))
+(define (lookup-within-frame var frame) (assoc var (cdr frame)))
+(define (add-binding-to-frame! var val frame)
+  (set-cdr! frame (cons (cons var val) (cdr frame))))
+
+(define the-empty-environment '())
+(define (extend-environment bindings base-env)
+  (cons (make-frame bindings) base-env))
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+
+(define (define-variable! var val env)
+  (let* ((frame (first-frame env))
+         (binding (lookup-within-frame var frame)))
+    (if binding
+        (set-cdr! binding val)
+        (add-binding-to-frame! var val frame))))
+; Exercise 4.12
+(define (lookup-binding variable environment)
+  (let loop ((env environment))
+    (if (eq? env the-empty-environment)
+        #f
+        (cond ((lookup-within-frame variable (first-frame env)))
+              (else (loop (enclosing-environment env)))))))
+(define (set-variable-value! var val env)
+  (cond ((lookup-binding var env) => (lambda (b) (set-cdr! b val)))
+        (else (error "Unbound variable: SET!" var))))
+; Exercise 4.16.a
+(define (lookup-variable-value var env)
+  (let ((value (cond ((lookup-binding var env) => cdr)
+                     (else '*unassigned*))))
+    (if (eq? value '*unassigned*)
+        (error "Unbound variable" var)
+        value)))
+
+; Exercise 4.3
+(define (make-table)
+  (let ((local-table (list '*table*)))
+    (define (lookup key)
+      (let ((record (assoc key (cdr local-table))))
+        (if record (cdr record) #f)))
+    (define (insert! key value)
+      (let ((record (assoc key (cdr local-table))))
+        (if record
+            (set-cdr! record value)
+            (set-cdr! (let tail ((table local-table))
+                        (if (null? (cdr table)) table (tail (cdr table))))
+                      (list (cons key value)))))
+      'ok)
+    (define (dispatch m)
+      (cond ((eq? m 'lookup-proc) lookup)
+            ((eq? m 'insert-proc!) insert!)
+            (else (error "Unknown operation: TABLE" m))))
+    dispatch))
+(define evaluation-table (make-table))
+(define (get-evaluator exp)
+  (if (pair? exp)
+      ((evaluation-table 'lookup-proc) (car exp))
+      #f))
+(define (evaluate exp env)
+  (cond ((get-evaluator exp) => (lambda (evaluator) (evaluator exp env)))
+        ((or (number? exp) (string? exp)) exp)
+        ((symbol? exp) (lookup-variable-value exp env))
+        ((pair? exp) (eval-application (cons 'call exp) env))
+        (else (error "Unknown expression type: EVAL" exp))))
+
+(define (begin-actions exp) (cdr exp))
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define (eval-sequence exps env)
+  (let ((first-value (evaluate (first-exp exps) env)))
+    (if (last-exp? exps)
+        first-value
+        (eval-sequence (rest-exps exps) env))))
+(define (eval-begin exp env) (eval-sequence (begin-actions exp) env))
+
+(define (primitive-procedure? p) (and (pair? p) (eq? (car p) 'primitive)))
+(define (primitive-implementation p) (cadr p))
+
+(define (make-procedure parameters body env)
+  (list 'procedure parameters body env))
+(define (compound-procedure? p) (and (pair? p) (eq? (car p) 'procedure)))
+(define (procedure-parameters p) (cadr p))
+; Exercise 4.16.c
+(define (procedure-body p) (scan-out-defines (caddr p)))
+(define (procedure-environment p) (cadddr p))
+
+(define (evaluator-apply procedure arguments)
+  (cond ((primitive-procedure? procedure)
+         (apply (primitive-implementation procedure) arguments))
+        ((compound-procedure? procedure)
+         (eval-sequence
+          (procedure-body procedure)
+          (extend-environment
+           (map cons (procedure-parameters procedure) arguments)
+           (procedure-environment procedure))))))
+
+(define (operator exp) (cadr exp))
+(define (operands exp) (cddr exp))
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+(define (list-of-values exps env)
+  (if (no-operands? exps)
+      '()
+      (cons (evaluate (first-operand exps) env)
+            (list-of-values (rest-operands exps) env))))
+(define (eval-application exp env)
+  (evaluator-apply (evaluate (operator exp) env)
+         (list-of-values (operands exp) env)))
+
+(define (eval-quote exp env) (cadr exp))
+
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+(define (eval-assignment exp env)
+  (set-variable-value! (assignment-variable exp)
+                       (evaluate (assignment-value exp) env)
+                       env)
+  'ok)
+
+(define (make-lambda parameters body)
+  (cons 'lambda (cons parameters body)))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+(define (eval-lambda exp env)
+  (make-procedure (lambda-parameters exp)
+                  (lambda-body exp)
+                  env))
+
+(define (definition-variable exp)
+  (if (symbol? (cadr exp))
+      (cadr exp)
+      (caadr exp)))
+(define (definition-value exp)
+  (if (symbol? (cadr exp))
+      (caddr exp)
+      (make-lambda (cdadr exp) (cddr exp))))
+(define (eval-definition exp env)
+  (define-variable! (definition-variable exp)
+                    (evaluate (definition-value exp) env)
+                    env)
+  'ok)
+
+; Exercise 4.16.b
+(define (scan-out-defines body)
+  (let* ((definitions (filter (lambda (exp) (eq? (car exp) 'define)) body))
+         (vars (map definition-variable definitions))
+         (vals (map definition-value definitions))
+         (assignments (map (lambda (var val) (list 'set! var val)) vars vals))
+         (rest (filter (lambda (exp) (not (eq? (car exp) 'define))) body))
+         (place-holders (let loop ((n (length vals)))
+                          (if (> n 0) (cons '*unassigned* (loop (1- n))) '()))))
+    (list (list* 'lambda vars (append assignments rest)) place-holders)))
+
+(define (false? x) (eq? x #f))
+(define (true? x) (not (false? x)))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+  (if (null? (cdddr exp))
+      'false
+      (cadddr exp)))
+(define (eval-if exp env)
+  (if (true? (evaluate (if-predicate exp) env))
+      (evaluate (if-consequent exp) env)
+      (evaluate (if-alternative exp) env)))
+
+; Exercise 4.5
+(define (cond-clauses exp) (cdr exp))
+(define (cond-predicate clause) (car clause))
+(define (cond-actions clause) (cdr clause))
+(define (eval-cond exp env)
+  (let loop ((clauses (cond-clauses exp)))
+    (if (null? clauses)
+        'false
+        (let* ((first (car clauses))
+               (rest (cdr clauses))
+               (pred (evaluate (cond-predicate first) env))
+               (actions (cond-actions first)))
+          (cond ((false? pred) (loop rest))
+                ((null? actions) pred)
+                ((eq? (car actions) '=>)
+                 (evaluator-apply (evaluate (cadr actions) env)
+                                  (list pred)))
+                (else (eval-sequence actions env)))))))
+
+; Exercise 4.4
+(define (eval-and exp env)
+  (let loop ((expressions (cdr exp)))
+    (cond ((null? expressions) 'true)
+          ((last-exp? expressions) (evaluate (car expressions) env))
+          ((evaluate (car expressions) env) (loop (cdr expressions)))
+          (else 'false))))
+(define (eval-or exp env) (eval-cond (map list exp) env))
+
+; Exercise 4.6
+(define (let->combination exp)
+  (let ((ad (cadr exp))
+        (dd (cddr exp)))
+    (if (list? ad)
+        (list* (list* 'lambda (map car ad) dd)
+               (map cadr ad))
+        ; Exercise 4.8
+        (list 'begin
+              (list* 'define (list* ad (map car (car dd))) (cdr dd))
+              (list* ad (map cadr (car dd)))))))
+(define (eval-let exp env) (evaluate (let->combination exp) env))
+
+; Exercise 4.7
+(define (let*->nested-lets exp)
+  (let ((body (cddr exp)))
+    (let loop ((bindings (cadr exp)))
+      (if (or (null? bindings) (last-exp? bindings))
+          (list* 'let bindings body)
+          (list 'let (list (car bindings)) (loop (cdr bindings)))))))
+(define (eval-let* exp env) (evaluate (let*->nested-lets exp) env))
+
+; Exercise 4.9
+(define (eval-while exp env) ; (while pred body)
+  (let ((pred (cadr exp))
+        (body (cddr exp)))
+    (let loop ((keep-going (evaluate pred env)))
+      (if (true? keep-going)
+          (begin (eval-sequence body env)
+                 (loop (evaluate pred env)))))))
+(define (eval-for exp env) ; (for init pred body)
+  (evaluate (list 'let (cadr exp)
+                  (list* 'while (caddr exp) (cdddr exp)))
+            env))
+
+; Exercise 4.2
+(define (add-evaluator! tag evaluator)
+  ((evaluation-table 'insert-proc!) tag evaluator))
+(add-evaluator! 'call eval-application)
+(add-evaluator! 'quote eval-quote)
+(add-evaluator! 'set! eval-assignment)
+(add-evaluator! 'define eval-definition)
+(add-evaluator! 'if eval-if)
+(add-evaluator! 'lambda eval-lambda)
+(add-evaluator! 'begin eval-begin)
+(add-evaluator! 'cond eval-cond)
+(add-evaluator! 'and eval-and)
+(add-evaluator! 'or eval-or)
+(add-evaluator! 'let eval-let)
+(add-evaluator! 'let* eval-let*)
+(add-evaluator! 'while eval-while)
+(add-evaluator! 'for eval-for)
+
+(define primitive-procedures
+  (let ((procedures (list (cons 'first car)
+                          (cons 'rest cdr)
+                          (cons 'cons cons)
+                          (cons 'null? null?)
+                          (cons 'assoc assoc)
+                          (cons 'display display)
+                          (cons 'newline newline)
+                          (cons '= =)
+                          (cons '< <)
+                          (cons '> >)
+                          (cons '+ +)
+                          (cons '- -)
+                          (cons '* *)
+                          (cons '/ /))))
+    (map (lambda (p) (cons (car p) (list 'primitive (cdr p)))) procedures)))
+(define (make-environment . environments)
+  (if (null? environments)
+      the-empty-environment
+      (extend-environment (car environments)
+                          (apply make-environment (cdr environments)))))
+
+(define (evaluator-loop)
+  (let loop ((environment (make-environment primitive-procedures
+                                            (list (cons 'false #f)
+                                                  (cons 'true #t)
+                                                  (cons 'else #t)))))
+    (display "> ")
+    (let ((input (read)))
+      (if (not (eq? input 'quit))
+          (let ((output (evaluate input environment)))
+            (display output)
+            (newline)
+            (loop environment))))))
+
+; Exercise 4.21
+(define (factorial n)
+  ((lambda (fact) (fact fact n))
+   (lambda (ft k) (if (= k 1) 1 (* k (ft ft (1- k)))))))
+(define (fibonacci n)
+  ((lambda (fib) (fib fib n))
+   (lambda (f k)
+     (if (or (= k 0) (= k 1))
+         k
+         (+ (f f (1- k))
+            (f f (- k 2)))))))
+(define (f x)
+  ((lambda (even? odd?) (even? even? odd? x))
+   (lambda (ev? od? n) (if (= n 0) #t (od? ev? od? (1- n))))
+   (lambda (ev? od? n) (if (= n 0) #f (ev? ev? od? (1- n))))))