#|

One more look at evaluation with "let", using pictures.

E0 =  o   -  the empty environment

E1 =  o
      |
    --------
   | x | 10 |     - extend environment, mapping x to 10 and
    --------        y to 12
   | y | 12 |
    --------

E2 =  o
      |
    --------
   | x | 10 |     - extends E1 with closure for f
    --------        
   | y | 12 |
    --------                            o
      |                                 |
    --------      ----------------     --------
   | f | *--|--->| z | +(z,y) | *-|-> | x | 10 |
    --------      ----------------     --------
                                      | y | 12 |
                                       --------

E0 at start >>>>>
                  let x = 10
                      y = 12
                   in
E1 for body >>>>> let f = proc(z)+(z,y)  << also E1 for evaluating
                      in                    the proc;
E2 for inner body >>>>>  (f 10)             produces a closure:
                                             ----------------
                                            | z | +(z,y) | *-|-> E1
                                             ----------------

So, when we evaluate "(f 10)", we look in E2 and find a binding for
f. The binding value is a closure, which has its own environment, E1,
for evaluating the closure body.

----------------------------------------------------------------------

Compare with letrec:

E0 at start >>>>>
                  let x = 10
                      y = 12
                   in
E1 for body >>>>> letrec f = proc(z)(f +(z,y))  << try to eval proc
                      in                           to get a closure:   
                        (f 10)             
                                             --------------------
                                            | z | (f +(z,y)) | *-|-> ??
                                             --------------------
                                                   doesn't work, 
                                                   because we don't yet
                                                   have an environment
                                                   with like E2.

In other words, we need something like E2 before we can create the
closure, and we need the closre before we can create something like
E2.

The solution is to create closure lazily:

E3 =  o
      |
    --------
   | x | 10 |     - extends E1 with closure for f
    --------        
   | y | 12 |
    --------            
      |                                
   ----------------------
  | -------- ----------- |  <<< double box means "create
  || f | z | (f +(z,y)) ||      closure on lookup"
  | -------------------- |
   ----------------------

Now, when we get to "(f 10)" an evaluate "f", the lookup process
creates a closure:


                                      o
                                      |
                                    --------
                                   | x | 10 |
                                    --------        
                                   | y | 12 |
                                    --------            
                                      |                                
   The closure:                    ----------------------
     --------------------         | -------- ----------- |
    | z | (f +(z,y)) | *-|----->  || f | z | (f +(z,y)) ||
     --------------------         | -------------------- |
                                   ----------------------

We can use this closure just like any other. When we apply it to an
argument, the environment in the closure includes the lazy binding for
f, which we'll need to evaluate "(f +(z,y))". In fact, the expression
above is an infinite loop, where we create a closure every time we
look up "f" in the environment.

This is the implementation stategy shown last Tuesday, and it's the
one to use for HW6.

----------------------------------------------------------------------

Look again at E2:

      o
      |
    --------
   | x | 10 |
    --------        
   | y | 12 |
    --------                            o
      |                                 |
    --------      ----------------     --------
   | f | *--|--->| z | +(z,y) | *-|-> | x | 10 |
    --------      ----------------     --------
                                      | y | 12 |
                                       --------

The envrionment in the closure looks like the environment extended
with an "f" binding because that was the environment active at the
time the proc was created. In fact, the picture might be more
accurately drawn as

E2'=  o
      |
    --------
   | x | 10 |
    --------        
   | y | 12 | <-------------------\
    --------                       \ 
      |                             \
    --------      ----------------   |
   | f | *--|--->| z | +(z,y) | *-|--/
    --------      ----------------  

which shows that the extended envionment and the one in the closure
really are the same.

If only we could create an environment that looks like

E3'=  o
      |
    --------
   | x | 10 |
    --------        
   | y | 12 |    /----------------\
    --------   /                   \ 
      |       /                     \
    -------- L    ----------------   |
   | f | *--|--->| z | +(z,y) | *-|--/
    --------      ----------------  

then we'd be able to implement lookup for letrec-bound function in the
same way as let functions. The difference between E2' and E3' is that
E2' is a DAG (direct acyclic graph), whereas E3' has cycles. There's
no way to create a graph with cycles if the nodes are created fully
and sequentially.

However, if we could modify the graph after it's nodes are created,
then we could create E3'. In other words, we might first create

      o
      |
    --------
   | x | 10 |
    --------        
   | y | 12 |    /----------------\
    --------   /                   \ 
      |       /                     \
    -------- L    ----------------   |
   | f | *  |    | z | +(z,y) | *-|--/
    -----|--      ----------------  
         v
        #f

and then redirect the pointer to #f to point to the closure, giving
E3'.

That strategy is implemented below. For many programs, it performs
better than last Tuesdya's implementation, because it creates each
letrec-bound closure only once, and environment lookup is exactly the
same as for a language with just `let'. It has the slight disadvantage
that closures are created when they might not be needed (of the
associated variable is never referenced).

|#

;; Slightly cleaned up from the previous interpreter, before
;; changing the environment representation to use the
;; graph-patching technique instead of the lazy-closure technique.

;; A expval is
;;   * number, or
;;   * boolean, or
;;   * proc

;; A denval is an expval

;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) 
                skip)
    (id (letter (arbno (or letter digit "?")))
        make-symbol)
    (number ((or "" "-" "+") digit (arbno digit))
            make-number)))

(define the-grammar
  '((program (expression) a-program)

    (expression (number) lit-exp)
    (expression (id) var-exp)
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression ("true") true-exp)
    (expression ("false") false-exp)
    (expression ("let"
                 (arbno id "=" expression)
                 "in"
                 expression)
                let-exp)
    (expression ("proc"
                 "(" (separated-list id ",") ")"
                 expression)
                proc-exp)
    (expression ("(" expression (arbno expression) ")")
                app-exp)
    (expression ("if" expression
                 "then" expression
                 "else" expression)
                if-exp)
    (expression ("letrec"
                 (arbno
                  id "=" 
                  "proc" "(" (separated-list id ",") ")"
                  expression)
                 "in" expression)
                letrec-exp)
    
    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive ("or")    or-prim)))

(sllgen:make-define-datatypes the-lexical-spec
                              the-grammar)

(define-datatype
 proc proc?
 (closure (ids (list-of symbol?))
          (body-exp expression?)
          (env environment?)))

;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

; eval-program : program -> expval
(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (eval-expression body (init-env))))))

; eval-expression : expression env -> expval
(define eval-expression 
  (lambda (exp env)
    (cases expression exp
      (lit-exp (datum) datum)
      (var-exp (id) (apply-env env id))
      (primapp-exp (prim rands)
        (let ((args (eval-rands rands env)))
          (apply-primitive prim args)))
      (true-exp () #t)
      (false-exp () #f)
      (proc-exp (ids body-exp)
                (closure ids body-exp env))
      (app-exp (rator rands)
               (let ([func (eval-expression rator env)]
                     [args (eval-rands rands env)])
                 (apply-proc func args)))
      (if-exp (test then else)
              (if (zero? (eval-expression test env))
                  (eval-expression else env)
                  (eval-expression then env)))
      (let-exp (ids exps body-exp) 
               (eval-expression
                body-exp ;; expression
                (extend-env
                 ids ;; list-of-sym
                 (eval-rands exps env)
                 env)))
      ;; This is essentially unmodified from the previous
      ;; interpreter
      (letrec-exp (func-ids arg-idss func-exps body-exp)
                  (eval-expression
                   body-exp
                   (recursively-extend-env
                    func-ids
                    arg-idss
                    func-exps
                    env))))))

; apply-proc : proc list-of-expval -> expval
(define (apply-proc func args)
  (cases proc func
         (closure (ids body-exp env)
                  (eval-expression
                   body-exp
                   (extend-env
                    ids
                    args
                    env)))))

; eval-rands : list-of-expression env -> list-of-expval
(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

; eval-rand : expression env -> expval
(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

; apply-primitive : primitive list-of-expval -> expval
;  (apply-prim (add-prim) '(0 3)) = 3
;  (apply-prim (sub-prim) '(1 2)) = -1
(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim  () (+ (car args) (cadr args)))
      (subtract-prim () (- (car args) (cadr args)))
      (mult-prim  () (* (car args) (cadr args)))
      (incr-prim  () (+ (car args) 1))
      (decr-prim  () (- (car args) 1))
      (or-prim () (or (car args) (cadr args))))))

; init-env :  -> env
(define init-env
  (lambda () (empty-env)))

;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;

;; Abstract envrionment datatype implemenation.

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record
    (syms (list-of symbol?))
    (vec vector?)    ; can use this for anything.
    (env environment?)))

; empty-env : -> env
(define empty-env
  (lambda ()
    (empty-env-record)))

; extend-env : list-of-sym list-of-denval env -> env 
(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms (list->vector vals) env)))

; recursively-extend-env
; Example: letrec f = proc(x) +(x,(g 2))
;                 g = proc(y) +(y,(f 1))
;            in (g 12)
(define recursively-extend-env
  (lambda (func-ids arg-idss func-exps old-env)
    ;; Example:
    ;;  func-ids = (list 'f 'g)
    ;;  arg-idss = (list (list 'x) (list 'y))
    ;;  func-exps = (list [+(x,(g 2))] [+(y,(f 1))])
    ;;  old-env = [some env]
    (let ([vec (make-vector (length func-ids) #f)])
      ;; vec = #(#f #f) initially, 
      ;; becomes #((closure '(x) [...] result)
      ;;           (closure '(y) [...] result))
      (let ([result (extended-env-record
                     func-ids vec old-env)])
        ;; result = (extended-env-record
        ;;           '(f g) vec [some env])
        (letrec ([install-closures!
                  (lambda (pos arg-idss func-exps)
                    ;; pos = 1
                    ;; arg-idss = '((y))
                    ;; func-exps = '([...])
                    (cond
                      [(null? args-idss) 'done]
                      [else 
		       ;; This vector-set! ties the
		       ;; recursive know between `vec'
		       ;; and `result':
		       (vector-set! 
			vec pos
			(closure (car arg-idss)
				 (car func-exps)
				 result))
		       (install-closures!
			(+ pos 1)
			(cdr arg-idss)
			(cdr func-exps))]))])
          (install-closures! 0 arg-idss func-exps)
          result)))))
                              
    
; apply-env : env sym -> denval
(define apply-env
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env "No binding for ~s" sym))
      (extended-env-record (syms vals env)
        (let ((position (env-find-position sym syms)))
          (if (number? position)
              (vector-ref vals position)
              (apply-env env sym))))
      ; Example: letrec f = proc(x) +(x,(g 2))
      ;                 g = proc(y) +(y,(f 1))
      ;            in (g 12)
      )))

;; Environment helper functions

; env-find-position : sym list-of-symbols -> num-or-#f
(define env-find-position 
  (lambda (sym los)
    (list-find-position sym los)))

; list-find-position : sym list-of-symbols -> num-or-#f
(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

; list-index : pred list-of-symbols -> num-or-#f
(define list-index
  (lambda (pred ls)
    (cond
      ((null? ls) #f)
      ((pred (car ls)) 0)
      (else (let ((list-index-r 
                   (list-index pred (cdr ls))))
              (if (number? list-index-r)
                (+ list-index-r 1)
                #f))))))

;;;;;;;;;;;;;;;; top level ;;;;;;;;;;;;;;;;

; read-eval-print : -> [loops forever]
(define read-eval-print
  (lambda ()
    ((sllgen:make-rep-loop "-->"
			   eval-program
                           (sllgen:make-stream-parser
                            the-lexical-spec
                            the-grammar)))))

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec
                             the-grammar))

(define (run string)
  (eval-program (scan&parse string)))

#|

----------------------------------------------------------------------

Another way to look at the above implementation is that it's roughly
like the following transformation on Scheme programs:

(letrec ([f (lambda (x) (+ x (g 2)))]
         [g (lambda (y) (+ y (f 1)))])
  (f 10))

=>

(let ([f #f]
      [g #f])
  (set! f (lambda (x) (+ x (g 2))))
  (set! g (lambda (y) (+ y (f 1))))
  (f 10))

More examples with "set!":

> (let ([x #f])
    (set! x 10)
    x)
10
> (let ([x 0])
    (let ([f (lambda ()
               (set! x (+ x 1))
               x)])
      (f)))
1
> (let ([x 0])
    (let ([f (lambda ()
               (set! x (+ x 1))
               x)])
      (f)
      (f)))
2
> (let ([f (lambda ()
             (let ([x 0])
               (set! x (+ x 1))
               x))])
    (f)
    (f))
1
> (let ([mk-f (lambda ()
                (let ([x 0])
                  (lambda ()
                    (set! x (+ x 1))
                    x)))])
    (let ([f1 (mk-f)]
          [f2 (mk-f)])
      (f1)
      (f1)))
2
> (let ([mk-f (lambda ()
                (let ([x 0])
                  (lambda ()
                    (set! x (+ x 1))
                    x)))])
    (let ([f1 (mk-f)]
          [f2 (mk-f)])
      (f1)
      (f2)))
1
> (let ([mk-f (lambda ()
                (let ([x 0])
                  (lambda ()
                    (set! x (+ x 1))
                    x)))])
    (let ([f1 (mk-f)]
          [f2 (mk-f)])
      (f1)
      (f2)
      (f2)))
2
> 

|#