SICP/ex-4_11-21.scm

(load "shared/util.scm")
(load "shared/sicp-evaluator.scm")

(display "\nex-4.11 - alternative-frame-implementation\n")

; Test implementation from book.
(define env-0 the-empty-environment)
(define env-1 (extend-environment '(a b) '(1 2) env-0))
(define env-2 (extend-environment '(c d) '(3 4) env-1))

(assert (lookup-variable-value 'b env-2) 2)
(set-variable-value! 'b 42 env-2)
(assert (lookup-variable-value 'b env-2) 42)
(define-variable! 'e 5 env-2)
(assert (lookup-variable-value 'e env-2) 5)

(define (make-frame variables values)
  (map cons variables values))
(define (frame-variables frame) (map car frame))
(define (frame-values frame) (map cdr frame))
(define (add-binding-to-frame! var val frame)
  (if (null? (cdr frame))
    (set-cdr! frame (cons (cons var val) '()))
    (add-binding-to-frame! var val (cdr frame))))

(define frame-var car)
(define frame-val cdr)

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (car vals))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan frame)
      (cond ((null? frame)
             (env-loop (enclosing-environment env)))
            ((eq? var (frame-var (car frame)))
             (set-cdr! (car frame) val))
            (else (scan (cdr frame)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan frame))))
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan frame)
      (cond ((null? frame)
             (add-binding-to-frame! var val (first-frame env)))
            ((eq? var (frame-var (car frame)))
             (set-cdr! (car frame) val))
            (else (scan (cdr frame)))))
    (scan frame)))

(define env-0 the-empty-environment)
(define env-1 (extend-environment '(a b) '(1 2) env-0))
(define env-2 (extend-environment '(c d) '(3 4) env-1))

(assert (lookup-variable-value 'b env-2) 2)
(set-variable-value! 'b 42 env-2)
(assert (lookup-variable-value 'b env-2) 42)
(define-variable! 'e 5 env-2)
(assert (lookup-variable-value 'e env-2) 5)

(display "\nex-4.12 - abstract-traversal\n")

(define (find-pair-frame var frame)
  (assoc var frame))

(define (find-pair-env var env)
  (define (env-loop env)
    (if (eq? env the-empty-environment)
      #f
      (let ((pair (assoc var (first-frame env))))
        (if (pair? pair)
          pair
          (env-loop (enclosing-environment env))))))
  (env-loop env))

(define (lookup-variable-value var env)
  (let ((pair (find-pair-env var env)))
    (if (eq? pair #f)
      (error "Unbound variable" var)
      (frame-val pair))))

(define (set-variable-value! var val env)
  (let ((pair (find-pair-env var env)))
    (if (pair? pair)
      (set-cdr! pair val)
      '())))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (let ((pair (assoc var frame)))
      (if (pair? pair)
        (set-cdr! pair val)
        (add-binding-to-frame! var val frame)))))

(define env-0 the-empty-environment)
(define env-1 (extend-environment '(a b) '(1 2) env-0))
(define env-2 (extend-environment '(c d) '(3 4) env-1))

(assert (find-pair-env 'd env-2) (cons 'd 4))
(assert (lookup-variable-value 'b env-2) 2)
(set-variable-value! 'b 42 env-2)
(assert (lookup-variable-value 'b env-2) 42)
(define-variable! 'e 5 env-2)
(assert (lookup-variable-value 'e env-2) 5)

(display "\nex-4.13 - make-unbound!\n")

; It seems like the reason for removing a binding is when one wants get access
; to the same symbol in an outer environment. Therefore, we implement
; make-unbound! so that it only deletes the symbol from the first frame in
; which it is defined.

(define (frame-without-var var frame)
  (cond
    ((null? frame) '())
    ((eq? var (frame-var (car frame))) (cdr frame))
    (else (cons (car frame) (frame-without-var var (cdr frame))))))

(define (make-unbound-first! var env)
  (let ((len (length (first-frame env))))
    (set-car! env (frame-without-var var (first-frame env)))
    (if (= len (length (first-frame env)))
      #f
      #t)))

(assert (make-unbound-first! 'd env-2) #t)
(assert (make-unbound-first! 'e env-2) #t)
(assert (make-unbound-first! 'b env-2) #f)
(assert (make-unbound-first! 'c env-2) #t)
(assert (first-frame env-2) '())

(define (make-unbound! var env)
  (define (loop env)
    (if (eq? env the-empty-environment)
      #f
      (if (make-unbound-first! var env)
        #t
        (loop (enclosing-environment env)))))
  (loop env))

(define env-0 the-empty-environment)
(define env-1 (extend-environment '(a b) '(1 2) env-0))
(define env-2 (extend-environment '(c d) '(3 4) env-1))
(define env-3 (extend-environment '(a b) '(3 6) env-2))

(assert (lookup-variable-value 'b env-3) 6)
(assert (make-unbound! 'b env-3) #t)
(assert (lookup-variable-value 'b env-3) 2)
(assert (make-unbound! 'b env-3) #t)
(assert (make-unbound! 'b env-3) #f)

(display "\nex-4.14 - map\n")

; Louis's implementation of map will not work because the evaluator will
; evaluate the lambda expression into a procedure list. The Scheme interpreter
; does not know how to evaluate that list. Hence, the operation fails.

(display "[answered]\n")

(display "\nex-4.15 - halts?\n")

(define (run-forever) (run-forever))

(define (try p)
  (if (halts? p p)
      (run-forever)
      'halted))

; Suppose (try try) runs forever then halts? evaluates to wrong and try returns
; halt. That is a contradiction. Suppose (try try) halts. Then halts? evaluates
; to true and try runs forever; again a contradiction. Therefore, a general
; procedure halts? cannot exist.

(display "[answered]\n")

(display "\nex-4.16 - scan-out-defines\n")

(define (lookup-variable-value var env)
  (let ((pair (find-pair-env var env)))
    (if (eq? pair #f)
      (error "Unbound variable" var)
      (let ((value (frame-val pair)))
        (if (eq? value '*unassigned*)
          (error "Unassigned variable" var)
          value)))))

(define (scan-out-defines body)
  (define (get-defines body)
    (cond
      ((null? body) '())
      ((definition? (car body)) (cons (car body) (get-defines (cdr body))))
      (else (get-defines (cdr body)))))
  (define (expression->new-expression exp)
    (if (definition? exp)
      (define->set exp)
      exp))
  (define (define->let-assignment def)
    (list (definition-variable def) '*unassigned*))
  (define (define->set def)
    (list 'set! (definition-variable def) (definition-value def)))
  (let* ((defines (get-defines body))
         (let-assignments (map define->let-assignment defines))
         (let-expression (list 'let let-assignments))
         (expressions (map expression->new-expression body)))
    (append let-expression expressions)))

(define body
  '((define x 3)
    (if #t 1 2)
    (define b 2)
    (display "hello")))

(define body-transformed
  '(let ((x *unassigned*)
         (b *unassigned*))
     (set! x 3)
     (if #t 1 2)
     (set! b 2)
     (display "hello")))

(assert (scan-out-defines body) body-transformed)

; I would install scan-out-defines into make-procedure. We might run into a
; situation where we update the body of a procedure and call procedure-body
; twice.

(define (make-procedure parameters body env)
  (list 'procedure parameters (scan-out-defines body) env))

(display "\nex-4.17 - extra-frame\n")

; Why is there an extra frame in the transformed program? We have implemented
; let via an additional transformation. Therefore, there is another
; lambda-expression that results in an extra frame.

; Explain why this difference in environment structure can never make a
; difference in the behavior of a correct program? The transformation keeps the
; order of the assignments. Hence, the behavior will not change.

; Design a way to make the interpreter implement the ``simultaneous'' scope
; rule for internal definitions without constructing the extra frame? We could
; simply add a list of (define symbol *unassigned*) at the beginning of the
; body and get the same behavior without an extra frame.

(display "[answered]\n")

(display "\nex-4.18 - alternative-scan-out\n")

(define (solve f y0 dt)
  (define y (integral (delay dy) y0 dt))
  (define dy (stream-map f y))
  y)

; Transformation from text:
(lambda (f y0 dt)
  (let ((y '*unassigned*)
        (dy '*unassigned*))
    (set! y (integral (delay dy) y0 dt))
    (set! dy (stream-map f y))
    y))

; Transformation from this exercise:
(lambda (f y0 dt)
  (let ((y '*unassigned*)
        (dy '*unassigned*))
    (let ((a (integral (delay dy) y0 dt))
          (b (stream-map f y)))
      (set! y a)
      (set! dy b)
      y)))

; The second transformation will not work because when b is evaluated y is not
; yet assigned. The first transformation works because y was already set when
; dy is set.

(display "[answered]\n")

(display "\nex-4.19 - ambiguous-expression\n")

; (let ((a 1))
;   (define (f x)
;     (define b (+ a x))
;     (define a 5)
;     (+ a b))
;   (f 10))

; Ben: 16
; Alyssa: error
; Eva: 20

; To implement Eva's suggested behavior one could reorder the defines so that
; defines with self-evaluating expressions are interpreted first.

(display "[answered]\n")

(display "\nex-4.20 - letrec\n")

(letrec ((fact
          (lambda (n)
            (if (= n 1)
                1
                (* n (fact (- n 1)))))))
  (assert (fact 10) 3628800))

(define letrec-before
  '(letrec ((a 3) (b 2))
     (+ a b)))

(define letrec-after
  '(let ((a *unassigned*) (b *unassigned*))
     (set! a 3)
     (set! b 2)
     (+ a b)))

(define (letrec? exp) (tagged-list exp 'letrec))
(define (letrec-bindings exp) (cadr exp))
(define (letrec-body exp) (cddr exp))
(define (letrec-binding-var binding) (car binding))
(define (letrec-binding-exp binding) (cadr binding))
(define (letrec-vars exp) (map let-binding-var (let-bindings exp)))
(define (letrec-exps exp) (map let-binding-exp (let-bindings exp)))

(define (letrec->combination exp)
  (define (binding->unassigned binding)
    (list (letrec-binding-var binding) '*unassigned*))
  (define (binding->set binding)
    (list 'set! (letrec-binding-var binding) (letrec-binding-exp binding)))
  (let* ((bindings (letrec-bindings exp))
         (bindings-unassigned (map binding->unassigned bindings))
         (let-unassigned (list 'let bindings-unassigned))
         (set-exps (map binding->set bindings))
         (body (letrec-body exp)))
    (append
      (append let-unassigned set-exps)
      body)))

(assert (letrec->combination letrec-before) letrec-after)

; b. With the let implementation the procedures odd? and even? cannot see and
; therefore not call each other.

(display "\nex-4.21 - recursive-without-define/letrec\n")

; factorial
(assert
((lambda (n)
   ((lambda (fact)
      (fact fact n))
    (lambda (ft k)
      (if (= k 1)
          1
          (* k (ft ft (- k 1)))))))
 10)
3628800)

; a. Fibonacci
(define (fibo n)
  (cond
    ((= n 0) 0)
    ((< n 3) 1)
    (else (+ (fibo (- n 2)) (fibo (- n 1))))))

(assert
((lambda (n)
   ((lambda (fib)
      (fib fib n))
    (lambda (f k)
      (cond
        ((= k 0) 0)
        ((< k 3) 1)
        (else (+ (f f (- k 2)) (f f (- k 1))))))))
 11)
(fibo 11))

; b. odd?/even?
(define (f x)
  ((lambda (even? odd?)
     (even? even? odd? x))
   (lambda (ev? od? n)
     (if (= n 0) true (od? ev? od? (- n 1))))
   (lambda (ev? od? n)
     (if (= n 0) false (ev? ev? od? (- n 1))))))

(assert (f 31) false)
(assert (f 42) true)