From c9ff5c1f9a2e117e76eeedc6b0f252dcf61abc65 Mon Sep 17 00:00:00 2001 From: Nguyễn Gia Phong Date: Wed, 4 Jul 2018 14:33:43 +0700 Subject: [sicp] Finish section 4.1.6: First working evaluator --- sicp/chapter4.scm | 301 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 301 insertions(+) create mode 100644 sicp/chapter4.scm 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)))))) -- cgit 1.4.1