sicp-4-1-6-internal-definitions

#lang racket

(require "3-5-streams.rkt"
         "4-1-4-repl-program.rkt")

;;;;;;;;;;
;; 4.16 ;;
;;;;;;;;;;

(define (lookup-variable-value var env)
  (define b (find-binding-in-env var env))
  (cond [(not b) (error "Unbound variable" var)]
        [else
          (define val (binding-value b))
          (if (eq? val '*unassigned*)
            (error "Unassigned variable" var)
            val)]))

(define (scan-out-defines body)
  (define defines (filter definition? body))
  (cond [(empty? defines) body]
        [else
          (define rest-of-body (filter-not definition? body))
          (define vars (map definition-variable defines))
          (define vals (map definition-value defines))
          (define bindings
            (for/list ([v vars])
                      (list v '*unassigned*)))
          (define assigns
            (for/list ([v vars]
                       [e vals])
                      (list 'set! v e)))
          (make-let
            bindings
            (append assigns rest-of-body))]))

;; test

(scan-out-defines '((define a 1)
                    (define b 2)
                    (define (f x) (+ x 5))
                    (set! a 3)
                    (f (* a b))))
;; '(let ((a *unassigned*) (b *unassigned*) (f *unassigned*))
   ;; (set! a 1)
   ;; (set! b 2)
   ;; (set! f (lambda (x) (+ x 5)))
   ;; (set! a 3)
   ;; (f (* a b)))

;; The test file ran fine with scan-out-defines installed in either make-procedure or
;; procedure-body.  I would prefer to put it in procedure-body though because
;; scan-out-defines is a syntactic transformation used to aid evaluation, and not a
;; syntactic form we are trying to enforce on all procedures.  So I think it belongs
;; with the selectors rather than the constructors.

;;;;;;;;;;
;; 4.17 ;;
;;;;;;;;;;

;; (lambda <vars>
  ;; (define u <e1>)
  ;; (define v <e2>)
  ;; <e3>)

;; (lambda <vars>
  ;; (let ((u '*unassigned*)
        ;; (v '*unassigned*))
    ;; (set! u <e1>)
    ;; (set! v <e2>)
    ;; <e3>))

#|
Calling the top lambda creates a binding frame below its enclosing environment
where vars are bound.  Then the body is evaluated in that binding frame, which
adds u and v to the frame, binding them to e1 and e2, respectively, then
evaluating e3.

Calling the bottom lambda creates a binding frame where vars are bound, just like
above.  Then the let statement is evaluated in that binding frame.  The let is
treated as a procedure application, so its evaluation creates a new binding frame,
below the one just created, where u and v are bound to '*unassigned*.  Then the
body of the let statement is evaluated in this subframe, setting u and v to e1 and
e2, respectively, and then evaluating e3.

The effect is the same as if vars, u and v, were all defined in the same frame.
We have, in effect, taken a frame that is a leaf node in the environment graph and
split it in two, while requiring the body to be evaluated in the new lower frame.
The body will have access to the same set of bindings as before.  The only
difference is that lookup-variable-value may have to recurse one extra time to
find the value of a variable left in the upper frame.

One way to get rid of the extra frame is to have the interpreter scan lambdas for
internal defines, add any definition-variables to the lambda parameters, curried
to take the value '*unassigned*, and add the set! statements to the beginning of
the body.
|#

;;;;;;;;;;
;; 4.18 ;;
;;;;;;;;;;

(define (integral delayed-integrand initial-value dt)
  (cons-stream initial-value
               (let ([integrand (force delayed-integrand)])
                 (if (stream-null? integrand)
                   the-empty-stream
                   (integral (delay (stream-cdr integrand))
                             (+ (* dt (stream-car integrand))
                                initial-value)
                             dt)))))

;; The define statement involving a let with mutually recursive bindings is rejected
;; by the Racket reader:

;; (define (solve f y0 dt)
  ;; (let ([y (integral (delay dy) y0 dt)]
        ;; [dy (my-stream-map f y)])
    ;; y))
;; ;; . dy: unbound identifier in module in: dy

;; In contrast, the '*unassigned* strategy works:

(define (solve2 f y0 dt)
  (let ([y '*unassigned*]
        [dy '*unassigned*])
    (set! y (integral (delay dy) y0 dt))
    (set! dy (my-stream-map f y))
    y))

(my-stream-ref (solve2 (lambda (y) y) 1 0.001) 1000)
;; 2.716923932235896

;; The alternative strategy does not work.  The Racket reader accepts the layered
;; lets that hide the mutual recursion, but evaluating the inner let expressions
;; produces errors because y and dy are still bound to '*unassigned* when passed to
;; integral and my-stream-map.

(define (solve3 f y0 dt)
  (let ([y '*unassigned*]
        [dy '*unassigned*])
    (let ([a (integral (delay dy) y0 dt)]
          [b (my-stream-map f y)])
      (set! y a)
      (set! dy b)
      y)))

;; (my-stream-ref (solve3 (lambda (y) y) 1 0.001) 1000)
;; ;; . . car: contract violation
  ;; ;; expected: pair?
  ;; ;; given: '*unassigned*

;; Scheme also provides letrec, recursive let, that implements 'simultaneous
;; defines'.  Using internal defines is equivalent to letrec.  The Racket style guide
;; prefers internal defines over any of the let forms.

(define (solve4 f y0 dt)
  (letrec ([y (integral (delay dy) y0 dt)]
           [dy (my-stream-map f y)])
    y))

(my-stream-ref (solve4 (lambda (y) y) 1 0.001) 1000)
;; 2.716923932235896

;;;;;;;;;;
;; 4.19 ;;
;;;;;;;;;;

;; Racket follows Alyssa's view and produces an 'a undefined' error.

;; (let ([a 1])
  ;; (define (f x)
    ;; (define b (+ a x))
    ;; (define a 5)
    ;; (+ a b))
  ;; (f 10))
;; ;; . . a: undefined;
 ;; ;; cannot use before initialization

;; However, this only produces an error because of the (define a ...) statement in
;; the body of f.  Remove that and the a from the environment is used:

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

;; So Racket is implementing something like our scan-out-defines behind the scenes.

;; I don't see an easy way to implement Eva's preferred behavior.  I think
;; scan-out-defines would have to create a graph of dependencies for the
;; definition-variables, and then place values in their locations in an order
;; compatible with their dependencies.

;;;;;;;;;;
;; 4.20 ;;
;;;;;;;;;;

;; ;; Add this clause to my-eval:
    ;; [(letrec? expr) (my-eval (letrec->simultaneous-lets expr) env)]

(define (letrec? expr) (tagged-list? expr 'letrec))
(define (letrec-bindings expr) (second expr))
(define (letrec-body expr) (drop expr 2))

(define (letrec->simultaneous-lets expr)
  (define bindings (letrec-bindings expr))
  (cond [(empty? bindings)
         (letrec-body expr)]
        [else
          (define vars (map first bindings))
          (define vals (map second bindings))
          (define new-bindings
            (for/list ([v vars])
                      (list v '*unassigned*)))
          (define assigns
            (for/list ([v vars]
                       [e vals])
                      (list 'set! v e)))
          (make-let
            new-bindings
            (append assigns (letrec-body expr)))]))

(letrec->simultaneous-lets
  '(letrec () (+ 1 2)))
;; '(+ 1 2)

(letrec->simultaneous-lets
  '(letrec ((even? (lambda (n) (if (zero? n) true (odd? (sub1 n)))))
            (odd? (lambda (n) (if (zero? n) false (even? (sub1 n))))))
     (even? 12)))
;; '(let ((even? *unassigned*) (odd? *unassigned*))
   ;; (set! even? (lambda (n) (if (zero? n) true (odd? (sub1 n)))))
   ;; (set! odd? (lambda (n) (if (zero? n) false (even? (sub1 n)))))
   ;; (even? 12))

(letrec->simultaneous-lets
  '(letrec ((even? (lambda (n) (if (zero? n) true (odd? (sub1 n)))))
            (odd? (lambda (n) (if (zero? n) false (even? (sub1 n))))))
     'side-effect
     (even? 12)))
;; '(let ((even? *unassigned*) (odd? *unassigned*))
   ;; (set! even? (lambda (n) (if (zero? n) true (odd? (sub1 n)))))
   ;; (set! odd? (lambda (n) (if (zero? n) false (even? (sub1 n)))))
   ;; 'side-effect
   ;; (even? 12))

(define (f x)
  (letrec ([even? (lambda (n) (if (zero? n) true (odd? (sub1 n))))]
           [odd? (lambda (n) (if (zero? n) false (even? (sub1 n))))])
    'rest-of-body))

;; The environment diagram for the letrec is just what you would expect.  The letrec
;; is transformed into a let, with even? and odd? initially bound to dummy values,
;; and then set! to their real lambda values.  set!, which evaluates its argument,
;; can do this because each variable, even? and odd?, have assigned locations in
;; memory due to having already been bound to the dummy values.  So neither is a free
;; variable in the definition of the other, and no error is raised.  In effect, even?
;; and odd? are bound simultaneously in the one binding frame, with each value
;; depending on the other.

;; Using let instead of letrec is a non-starter.  The interpreter creates a binding
;; frame for the let statement where it tries to bind even? and odd? to the values
;; their definitions reduce to.  But whichever definition it tries to evaluate first,
;; it will always encounter the other, still undefined, raising an error.

;;;;;;;;;;
;; 4.21 ;;
;;;;;;;;;;

((lambda (n)
   ((lambda (fact)
      (fact fact n))
    (lambda (ft k)
      (if (= k 1)
        1
        (* k (ft ft (sub1 k)))))))
 10)
;; 3628800 ; this is 10!

((lambda (n)
   ((lambda (fib)
      (fib fib n))
    (lambda (ft k)
      (if (< k 2)
        k
        (+ (ft ft (sub1 k))
           (ft ft (- k 2)))))))
 10)
;; 55 ; this is fib(10)

(define (f2 x)
  ((lambda (my-even? my-odd?)
     (my-even? my-even? my-odd? x))
   (lambda (ev? od? n)
     (if (zero? n)
       true
       (od? od? ev? (sub1 n))))
   (lambda (od? ev? n)
     (if (zero? n)
       false
       (ev? ev? od? (sub1 n))))))

(f2 11)
;; #f
(f2 12)
;; #t

;; I know this is the y-combinator which is a special function from the lambda
;; calculus that computes fixed points, and that when applied to a function of two
;; variables can be used to implement recursion, and that when applied to a function
;; of three variables can be used to implement mutual recursion.  But I don't
;; understand how it works.