227 lines
7.1 KiB
Scheme
227 lines
7.1 KiB
Scheme
(load "shared/util.scm")
|
|
(load "shared/sicp-evaluator.scm")
|
|
|
|
(display "\nex-4.25 - factorial-unless\n")
|
|
|
|
(eval '(define (unless condition usual-value exceptional-value)
|
|
(if condition exceptional-value usual-value)) the-global-environment)
|
|
|
|
(eval '(define (factorial n)
|
|
(unless (= n 1)
|
|
(* n (factorial (- n 1)))
|
|
1)) the-global-environment)
|
|
|
|
; This implementation of factorial is not going to terminate in regular
|
|
; applicative-order Scheme because the recursive calls to factorial result in
|
|
; an endless-loop. The definition would work in a normal-order language.
|
|
|
|
; (factorial 5)
|
|
|
|
(display "[answered]\n")
|
|
|
|
|
|
(display "\nex-4.26 - special-form-unless\n")
|
|
|
|
(define (unless-condition exp) (cadr exp))
|
|
(define (unless-usual exp) (caddr exp))
|
|
(define (unless-exceptional exp) (cadddr exp))
|
|
|
|
(define (unless->combination exp)
|
|
(make-if (unless-condition exp)
|
|
(unless-exceptional exp)
|
|
(unless-usual exp)))
|
|
|
|
(assert (eval '(factorial 3) the-global-environment) 6)
|
|
|
|
(display "\nexample - lazy-evaluation\n")
|
|
|
|
(define (eval exp env)
|
|
(cond ((self-evaluating? exp) exp)
|
|
((variable? exp) (lookup-variable-value exp env))
|
|
((quoted? exp) (text-of-quotation exp))
|
|
((assignment? exp) (eval-assignment exp env))
|
|
((definition? exp) (eval-definition exp env))
|
|
((if? exp) (eval-if exp env))
|
|
((lambda? exp)
|
|
(make-procedure (lambda-parameters exp)
|
|
(lambda-body exp)
|
|
env))
|
|
((begin? exp)
|
|
(eval-sequence (begin-actions exp) env))
|
|
((cond? exp) (eval (cond->if exp) env))
|
|
((application? exp)
|
|
(apply (actual-value (operator exp) env)
|
|
(operands exp)
|
|
env))
|
|
(else
|
|
(error "Unknown expression type -- EVAL" exp))))
|
|
|
|
(define (actual-value exp env)
|
|
(force-it (eval exp env)))
|
|
|
|
(define (apply procedure arguments env)
|
|
(cond ((primitive-procedure? procedure)
|
|
(apply-primitive-procedure
|
|
procedure
|
|
(list-of-arg-values arguments env))) ; changed
|
|
((compound-procedure? procedure)
|
|
(eval-sequence
|
|
(procedure-body procedure)
|
|
(extend-environment
|
|
(procedure-parameters procedure)
|
|
(list-of-delayed-args arguments env) ; changed
|
|
(procedure-environment procedure))))
|
|
(else
|
|
(error
|
|
"Unknown procedure type -- APPLY" procedure))))
|
|
|
|
(define (list-of-arg-values exps env)
|
|
(if (no-operands? exps)
|
|
'()
|
|
(cons (actual-value (first-operand exps) env)
|
|
(list-of-arg-values (rest-operands exps)
|
|
env))))
|
|
(define (list-of-delayed-args exps env)
|
|
(if (no-operands? exps)
|
|
'()
|
|
(cons (delay-it (first-operand exps) env)
|
|
(list-of-delayed-args (rest-operands exps)
|
|
env))))
|
|
|
|
(define (eval-if exp env)
|
|
(if (true? (actual-value (if-predicate exp) env))
|
|
(eval (if-consequent exp) env)
|
|
(eval (if-alternative exp) env)))
|
|
|
|
(define (force-it obj)
|
|
(if (thunk? obj)
|
|
(actual-value (thunk-exp obj) (thunk-env obj))
|
|
obj))
|
|
|
|
(define (delay-it exp env)
|
|
(list 'thunk exp env))
|
|
|
|
(define (thunk? obj)
|
|
(tagged-list? obj 'thunk))
|
|
|
|
(define (thunk-exp thunk) (cadr thunk))
|
|
|
|
(define (thunk-env thunk) (caddr thunk))
|
|
|
|
(define (evaluated-thunk? obj)
|
|
(tagged-list? obj 'evaluated-thunk))
|
|
|
|
(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
|
|
|
|
(define (force-it obj)
|
|
(cond ((thunk? obj)
|
|
(let ((result (actual-value
|
|
(thunk-exp obj)
|
|
(thunk-env obj))))
|
|
(set-car! obj 'evaluated-thunk)
|
|
(set-car! (cdr obj) result) ; replace exp with its value
|
|
(set-cdr! (cdr obj) '()) ; forget unneeded env
|
|
result))
|
|
((evaluated-thunk? obj)
|
|
(thunk-value obj))
|
|
(else obj)))
|
|
|
|
(define the-global-environment (setup-environment))
|
|
|
|
(eval '(define (unless condition usual-value exceptional-value)
|
|
(if condition exceptional-value usual-value)) the-global-environment)
|
|
|
|
(eval '(define (factorial n)
|
|
(unless (= n 1)
|
|
(* n (factorial (- n 1)))
|
|
1)) the-global-environment)
|
|
|
|
(assert (eval-force '(factorial 5) the-global-environment) 120)
|
|
|
|
(display "\nex-4.27 - lazy-evaluator\n")
|
|
|
|
(eval '(define count 0) the-global-environment)
|
|
(eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
|
|
(eval '(define w (id (id 10))) the-global-environment)
|
|
|
|
; I expected count to be 0 here, but it is 1 in reality. I think when
|
|
; list-of-delayed-args is called in the first call of id the count gets
|
|
; incremented the first time. Hence, the value is 1.
|
|
(assert (eval 'count the-global-environment) 1)
|
|
|
|
; w is thunk and cannot be displayed. By getting the actual value it will show
|
|
; 10 as expected.
|
|
(assert (eval-force 'w the-global-environment) 10)
|
|
|
|
; After w is fully evaluated count is 2 as expected.
|
|
(assert (eval 'count the-global-environment) 2) ; count is 2
|
|
|
|
(display "\nex-4.28 - eval-actual-value\n")
|
|
|
|
; Replace actual-value with eval in line 53 and see how this fails: unknown
|
|
; procedure (thunk + ...).
|
|
(assert (eval '((lambda (op a b) (op a b)) + 1 2) the-global-environment) 3)
|
|
|
|
(display "\nex-4.29 - memoization\n")
|
|
|
|
; Calculating fibonacci numbers recursively will run much slow without
|
|
; memoization.
|
|
(define the-global-environment (setup-environment))
|
|
(eval '(define (fib n)
|
|
(if (< n 2)
|
|
1
|
|
(+ (fib (- n 2)) (fib (- n 1)))))
|
|
the-global-environment)
|
|
(eval '(define count 0) the-global-environment)
|
|
(eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
|
|
(eval '(define (square x) (* x x)) the-global-environment)
|
|
|
|
(assert (eval '(square (id 10)) the-global-environment) 100)
|
|
(assert (eval 'count the-global-environment) 1)
|
|
(assert (eval '(fib 10) the-global-environment) 89)
|
|
|
|
; If we implemented force-it without memoization count would be 2 because the
|
|
; id-procedure gets evaluated twice:
|
|
; (assert (eval 'count the-global-environment) 2)
|
|
|
|
(display "\nex-4.30 - eval-sequence\n")
|
|
|
|
; a. Ben is right because primitive procedures are executed right away.
|
|
|
|
; b.
|
|
|
|
(eval
|
|
'(define (p1 x)
|
|
(set! x (cons x '(2)))
|
|
x)
|
|
the-global-environment)
|
|
|
|
(eval
|
|
'(define (p2 x)
|
|
(define (p e)
|
|
e
|
|
x)
|
|
(p (set! x (cons x '(2)))))
|
|
the-global-environment)
|
|
|
|
; With the text implementation the result is (1 2) because set! gets evaluated
|
|
; right away. p2 defines another procedure which has the consequence that e is
|
|
; evaluated lazily. Hence, the intial value of e 1 is returned.
|
|
|
|
(assert (eval-force '(p1 1) the-global-environment) '(1 2))
|
|
(assert (eval-force '(p2 1) the-global-environment) 1)
|
|
|
|
; If we change the implementation of eval-sequence the behavior of p1 is the
|
|
; same. However, since e gets evaluated right away in p2 the result is the same
|
|
; as for p1.
|
|
|
|
; c. Evaluating the statements right away does not change the behavior, because
|
|
; force-it is called either way.
|
|
|
|
; d. I think the lazy implementation should be kept as it is. Primitive
|
|
; procedures work as expected and if we have a lazy language it is consistent
|
|
; to not force the evaluation of unused thunks.
|
|
|
|
(display "[done]\n")
|
|
|