Answer till 4.27

README.md

@@ -10,7 +10,7 @@ You can use the Scheme implementation by the MIT to run these scripts. In Arch,
 execute `pacman -S mit-scheme` to install it. Then run the scripts via
 `mit-scheme --quiet < script.scm`.
 
-**This is currently (2020/12/16) work in progress.**
+**This is currently (2021/01/25) work in progress.**
 
 
 # Chapter 1
@@ -66,6 +66,12 @@ Finally, SICP introduces the evaluation model for stateless functions and
 concludes with some exercises that require second-order procedures: procedures
 that take other procedures as arguments.
 
+
 # Chapter 2
 
+![Corner Split](misc/corner-split-3.png)
+
+
+# Chapter 3
+
 

ex-4_25-xx.scm

@@ -1,7 +1,171 @@
 (load "util.scm")
-; (load "misc/evaluator.scm")
+(load "misc/evaluator.scm")
 
-(display "\nex-4.25\n")
+(display "\nex-4.25 - factorial-unless\n")
 
-(display "\nex-4.26\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 (assert a b)
+  (cond ((equal? a b) (display "[ok]"))
+    (else
+      (display "[error] ")
+      (display a)
+      (display " != ")
+      (display b)))
+  (newline)) the-global-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)
+
+(eval '(assert (factorial 5) 120) the-global-environment)
+
+(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 (actual-value '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\n")
+
+(display "\nex-4.29\n")
 

misc/evaluator.scm

@@ -4,6 +4,7 @@
         ((quoted? exp) (text-of-quotation exp))
         ((assignment? exp) (eval-assignment exp env))
         ((definition? exp) (eval-definition exp env))
+        ((unless? exp) (eval (unless->combination exp) env))
         ((if? exp) (eval-if exp env))
         ((lambda? exp)
          (make-procedure (lambda-parameters exp)
@@ -108,6 +109,7 @@
 (define (make-lambda parameters body)
   (cons 'lambda (cons parameters body)))
 
+(define (unless? exp) (tagged-list? exp 'unless))
 (define (if? exp) (tagged-list? exp 'if))
 (define (if-predicate exp) (cadr exp))
 (define (if-consequent exp) (caddr exp))
@@ -244,8 +246,12 @@
         (list 'cons cons)
         (list 'null? null?)
         (list 'display display)
+        (list 'equal? equal?)
+        (list 'newline newline)
         (list '= =)
         (list '+ +)
+        (list '* *)
+        (list '/ /)
         (list '- -)
         (list '< <)
         ;;<more primitives>
@@ -299,6 +305,12 @@
                      '<procedure-env>))
       (display object)))
 
+(define (eval-verbose exp env)
+  (let ((output (eval exp env)))
+      (user-print output) (newline)
+      output))
+
+
 (define the-global-environment (setup-environment))
 
 ;(driver-loop)