SICP/ex-4_25-xx.scm

(load "util.scm")
(load "misc/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 (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")