;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;  The IMPLICIT-REFS language (based on LETREC)

; A trick to make DrScheme show the full details of data created using
; constructors created using define-datatype
(require (only mzscheme print-struct))
(print-struct #t)

;; Utility function from EOPL Chapter 1

(define every?
  (lambda (pred lst)
    (cond
      ((null? lst) #t)
      ((pred (car lst)) (every? pred (cdr lst)))
      (else #f))))

;;;;;;;;;;;;;;;; references and the store ;;;;;;;;;;;;;;;;

;; empty-store : () -> store

(define empty-store
  (lambda ()
    '()))

;; store? :: scheme-value -> boolean

(define store?
  (lambda (v)
    (and (list? v) (every? expval? v))))

;; reference? : scheme-value -> boolean

(define reference?
  (lambda (v)
    (and (integer? v)
         (>= v 0))))

;; newref : expval * store -> reference * store

(define newref
  (lambda (val store)
    (cond
      ((not (expval? val))
       (eopl:error 'newref "~s is not a value" val))
      ((not (store? store))
       (eopl:error 'newref "~s is not a store" store))
      (else
       (list (length store) (append store (list val)))))))

;; deref : reference * store -> expval

(define deref
  (lambda (ref store)
    (list-ref store ref)))

;; setref :: reference * expval * store -> store

(define setref
  (lambda (ref val store)
    (cond
      ((not (reference? ref))
       (eopl:error 'setref "~s is not a reference" ref))
      ((not (expval? val))
       (eopl:error 'setref "~s is not a value" val))
      ((not (store? store))
       (eopl:error 'setref "~s is not a store" store))
      ((null? store)
       (eopl:error 'setref "The reference ~s is out of range for the store ~s"
                   ref store))
      ((zero? ref)
       (cons val (cdr store)))
      (else
       (cons (car store) (setref (- ref 1) val (cdr store)))))))

;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;

; The following code implements a procedural representation of procedures.

(define proc? procedure?)

(define procedure
  (lambda (x e env)
    (lambda (v store)
      (let ((rs (newref v store)))
        (value-of e (extend-env x (car rs) env) (cadr rs))))))

(define apply-procedure
  (lambda (p v store)
    (p v store)))

; The following code implements a data-structure representation of procedures.
; It can be obtained by defunctionalizing the procedural representation above.
; Both of these implementations provide the functions proc?, procedure, and
; apply-procedure, but the second implementation overwrites the first one.

(define-datatype proc proc?
  (procedure
   (x symbol?)
   (e expression?)
   (env environment?)))

(define apply-procedure
  (lambda (p v store)
    (cases proc p
      (procedure (x e env)
        (let ((rs (newref v store)))
          (value-of e (extend-env x (car rs) env) (cadr rs)))))))

;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;

;;; an expressed value is either a number, a boolean, or a procedure.

(define-datatype expval expval?
  (num-val
    (value number?))
  (bool-val
    (boolean boolean?))
  (proc-val
    (p proc?))
  )

;;; extractors:

(define expval->num
  (lambda (v)
    (cases expval v
      (num-val (num) num)
      (else (expval-extractor-error 'num v)))))

(define expval->bool
  (lambda (v)
    (cases expval v
      (bool-val (bool) bool)
      (else (expval-extractor-error 'bool v)))))

(define expval->proc
  (lambda (v)
    (cases expval v
      (proc-val (p) p)
      (else (expval-extractor-error 'proc v)))))

(define expval-extractor-error
  (lambda (variant value)
    (eopl:error 'expval-extractors "Looking for a ~s, found ~s"
      variant value)))

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

;;; example of a data type built without define-datatype

; Any implementation of environments, as shown in Section 2.2, will do.
; For example, we could have used define-datatype and cases instead:
;
; (define-datatype environment environment?
;   (empty-env)
;   (extend-env
;     (saved-sym symbol?)
;     (saved-val reference?)
;     (saved-env environment?))
;
; (define apply-env
;   (lambda (env sym)
;     (cases environment env
;       (empty-env ()
;        (eopl:error 'apply-env "No binding for ~s" sym))
;       (extend-env (saved-sym saved-val saved-env)
;         (if (eq? sym saved-sym)
;           saved-val
;           (apply-env saved-env sym)))
;       )))

(define empty-env
  (lambda ()
    '()))

(define extend-env
  (lambda (saved-sym saved-val saved-env)
    (cond
      ((not (symbol? saved-sym))
       (eopl:error 'extend-env "~s is not a symbol" saved-sym))
      ((not (reference? saved-val))
       (eopl:error 'extend-env "~s is not a reference" saved-val))
      ((not (environment? saved-env))
       (eopl:error 'extend-env "~s is not an environment" saved-env))
      (else
       (cons (list saved-sym saved-val) saved-env)))))

;; extend-env-recursively :
;; symbol * symbol * expression * environment * store -> environment * store

(define extend-env-recursively
  (lambda (p x e saved-env store)
    (cond
      ((not (symbol? p))
       (eopl:error 'extend-env-recursively "~s is not a symbol" p))
      ((not (symbol? x))
       (eopl:error 'extend-env-recursively "~s is not a symbol" x))
      ((not (expression? e))
       (eopl:error 'extend-env-recursively "~s is not an expression" e))
      ((not (environment? saved-env))
       (eopl:error 'extend-env "~s is not an environment" saved-env))
      (else
       ; Create a new location containing a dummy value for the recursive
       ; procedure to be defined
       (let ((rs (newref (num-val 37) store)))
         (let ((ref (car rs))
               (new-store (cadr rs)))
           ; Extend the environment with a reference to the new location
           (let ((env (extend-env p ref saved-env)))
             ; Replace the dummy value in the new location
             ; by a new procedure in the extended environment
             (list env
                   (setref ref (proc-val (procedure x e env)) new-store)))))))))

(define environment?
  (lambda (x)
    (or (null? x)
        (and (pair? x)
             (list? (car x))
             (= 2 (length (car x)))
             (symbol? (car (car x)))
             (reference? (car (cdr (car x))))
             (environment? (cdr x))))))

(define apply-env
  (lambda (env sym)
    (cond
      ((null? env)
       (eopl:error 'apply-env "No binding for ~s" sym))
      ((eq? sym (car (car env)))
       (car (cdr (car env))))
      (else
       (apply-env (cdr env) sym)))))

;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;

;; init-env : store -> environment * store

;; (init-env) builds an environment and store in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.

(define init-env
  (lambda (store)
    (let ((is (newref (num-val 1) store)))
      (let ((vs (newref (num-val 5) (cadr is))))
        (let ((xs (newref (num-val 10) (cadr vs))))
          (list
            (extend-env
              'i (car is)
              (extend-env
                'v (car vs)
                (extend-env
                  'x (car xs)
                  (empty-env))))
            (cadr xs)))))))

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

(define the-lexical-spec
  '((whitespace (whitespace) skip)
    (comment ("%" (arbno (not #\newline))) skip)
    (identifier
     (letter (arbno (or letter digit "_" "-" "?")))
     symbol)
    (number (digit (arbno digit)) number)
    (number ("-" digit (arbno digit)) number)
    ))

;;; Use show-the-datatypes (defined below) to show the define-datatype
;;; automatically generated from this grammar.

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

    (expression (number) const-exp)

    (expression (identifier) var-exp)

    (expression
     ("-" "(" expression "," expression ")")
     diff-exp)

    (expression
     ("zero?" "(" expression ")")
     zero?-exp)

    (expression
     ("if" expression "then" expression "else" expression)
     if-exp)

    (expression
     ("let" identifier "=" expression "in" expression)
     let-exp)

    (expression
     ("proc" "(" identifier ")" expression)
     proc-exp)

    (expression
     ("(" expression expression ")")
     call-exp)

    (expression
     ("letrec" identifier "(" identifier ")" "=" expression "in" expression)
     letrec-exp)

    (expression
     ("set" identifier "=" expression)
     set-exp)

    ))

;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;

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

(define show-the-datatypes
  (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))

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

(define just-scan
  (sllgen:make-string-scanner the-lexical-spec the-grammar))

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

;; value-of-program : program -> expval

(define value-of-program
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (let ((es (init-env (empty-store))))
          (car (value-of body (car es) (cadr es))))))))

;; value-of : expression * environment * store -> expval * store

(define value-of
  (lambda (exp env store)
    (cases expression exp

      (const-exp (n) (list (num-val n) store))

      (var-exp (x) (list (deref (apply-env env x) store) store))

      (diff-exp (e1 e2)
        (let ((vs1 (value-of e1 env store)))
          (let ((n1 (expval->num (car vs1))))
            (let ((vs2 (value-of e2 env (cadr vs1))))
              (let ((n2 (expval->num (car vs2))))
                (list (num-val (- n1 n2)) (cadr vs2)))))))

      (zero?-exp (e1)
        (let ((vs1 (value-of e1 env store)))
          (let ((n1 (expval->num (car vs1))))
            (list (if (zero? n1)
                    (bool-val #t)
                    (bool-val #f))
                  (cadr vs1)))))

      (if-exp (e1 e2 e3)
        (let ((vs1 (value-of e1 env store)))
          (if (expval->bool (car vs1))
            (value-of e2 env (cadr vs1))
            (value-of e3 env (cadr vs1)))))

      (let-exp (x e1 e2)
        (let ((vs1 (value-of e1 env store)))
          (let ((rs1 (newref (car vs1) (cadr vs1))))
            (value-of e2
              (extend-env x (car rs1) env)
              (cadr rs1)))))

      (proc-exp (x e)
        (list (proc-val (procedure x e env)) store))

      (call-exp (e1 e2)
        (let ((vs1 (value-of e1 env store)))
          (let ((p (expval->proc (car vs1))))
            (let ((vs2 (value-of e2 env (cadr vs1))))
              (apply-procedure p (car vs2) (cadr vs2))))))

      (letrec-exp (p x e1 e2)
        (let ((es (extend-env-recursively p x e1 env store)))
          (value-of e2 (car es) (cadr es))))

      (set-exp (var e1)
        (let ((ref (apply-env env var))
              (vs1 (value-of e1 env store)))
          (list (num-val 14)
                (setref ref (car vs1) (cadr vs1)))))

      )))

;;;;;;;;;;;;;;;; testing ;;;;;;;;;;;;;;;;

;; run : string -> expval

(define run
  (lambda (string)
    (value-of-program (scan&parse string))))

; A test is a list with three elements: the name of the test (a symbol),
; the program to test (a string), and the desired result (a number or a
; boolean).  The desired result may also be the symbol error, but for
; now we just skip those tests.

(define test->name
  (lambda (test)
    (car test)))

(define test->program
  (lambda (test)
    (car (cdr test))))

(define test->result
  (lambda (test)
    (car (cdr (cdr test)))))

(define result->expval
  (lambda (result)
    (cond
      ((number? result)
       (num-val result))
      ((boolean? result)
       (bool-val result))
      (else
       (eopl:error 'result->expval "Can't convert ~s to expval" result)))))

;; test-one : test -> boolean
; The test-one function returns whether the test succeeded.

(define test-one
  (lambda (test)
    (let ((result (test->result test)))
      (or (eq? result 'error)
          (equal? (run (test->program test))
                  (result->expval result))))))

;; test-list : (list-of test) -> (list-of sym)
; The test-list function returns the names of the tests that failed.

(define test-list
  (lambda (tests)
    (cond
      ((null? tests)
       '())
      ((test-one (car tests))
       (test-list (cdr tests)))
      (else
       (cons (test->name (car tests))
             (test-list (cdr tests)))))))

;; test : () -> (list-of sym)

(define test
  (lambda ()
    (test-list
      '(

        ;; simple arithmetic
        (positive-const "11" 11)
        (negative-const "-33" -33)
        (simple-arith-1 "-(44,33)" 11)

        ;; nested arithmetic
        (nested-arith-left "-(-(44,33),22)" -11)
        (nested-arith-right "-(55, -(22,11))" 44)

        ;; simple variables
        (test-var-1 "x" 10)
        (test-var-2 "-(x,1)" 9)
        (test-var-3 "-(1,x)" -9)

        ;; simple unbound variables
        (test-unbound-var-1 "foo" error)
        (test-unbound-var-2 "-(x,foo)" error)

        ;; simple conditionals
        (if-true "if zero?(0) then 3 else 4" 3)
        (if-false "if zero?(1) then 3 else 4" 4)

        ;; test dynamic typechecking
        (no-bool-to-diff-1 "-(zero?(0),1)" error)
        (no-bool-to-diff-2 "-(1,zero?(0))" error)
        (no-int-to-if "if 1 then 2 else 3" error)

        ;; make sure that the test and both arms get evaluated
        ;; properly.
        (if-eval-test-true "if zero?(-(11,11)) then 3 else 4" 3)
        (if-eval-test-false "if zero?(-(11, 12)) then 3 else 4" 4)

        ;; and make sure the other arm doesn't get evaluated.
        (if-eval-test-true-2 "if zero?(-(11, 11)) then 3 else foo" 3)
        (if-eval-test-false-2 "if zero?(-(11,12)) then foo else 4" 4)

        ;; simple let
        (simple-let-1 "let x = 3 in x" 3)

        ;; make sure the body and rhs get evaluated
        (eval-let-body "let x = 3 in -(x,1)" 2)
        (eval-let-rhs "let x = -(4,1) in -(x,1)" 2)

        ;; check nested let and shadowing
        (simple-nested-let "let x = 3 in let y = 4 in -(x,y)" -1)
        (check-shadowing-in-body "let x = 3 in let x = 4 in x" 4)
        (check-shadowing-in-rhs "let x = 3 in let x = -(x,1) in x" 2)

        ;; test procedures
        (plus "let plus = proc (x) proc (y) -(x,-(0,y)) in ((plus 3) 4)" 7)
        (shadow "let i = 3
                 in let add-i = proc (j) -(i,-(0,j))
                    in let i = 8
                       in (add-i i)"
                11)
        (lexical-scope-1 "let i = 3
                          in let add-i = proc (j) -(i,-(0,j))
                             in let i = 8
                                in (add-i 0)"
                         3)
        (lexical-scope-2 "let plus = proc (x) proc (y) -(x,-(0,y))
                          in let x = (plus 3)
                             in (x 4)"
                         7)

        ;; test recursive procedures
        (letrec "letrec parity(x) = if zero?(x)
                                    then 0
                                    else -(1,(parity -(x,1)))
                 in (parity 13)"
                1)

      ;; simple applications
      (apply-proc-in-rator-pos "(proc(x) -(x,1)  30)" 29)
      (apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
      (let-to-proc-1 "(proc(f)(f 30)  proc(x)-(x,1))" 29)


      (nested-procs "((proc (x) proc (y) -(x,y)  5) 6)" -1)
      (nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
        -1)

       (y-combinator-1 "
let fix =  proc (f)
            let d = proc (x) proc (z) ((f (x x)) z)
            in proc (n) ((f (d d)) n)
in let
    t4m = proc (f) proc(x) if zero?(x) then 0 else -((f -(x,1)),-4)
in let times4 = (fix t4m)
   in (times4 3)" 12)

       ;; simple letrecs
      (simple-letrec-1 "letrec f(x) = -(x,1) in (f 33)" 32)
      (simple-letrec-2
        "letrec f(x) = if zero?(x)  then 0 else -((f -(x,1)), -2) in (f 4)"
        8)

      (simple-letrec-3
        "let m = -5
 in letrec f(x) = if zero?(x) then 0 else -((f -(x,1)), m) in (f 4)"
        20)

;      (fact-of-6  "letrec
;  fact(x) = if zero?(x) then 1 else *(x, (fact sub1(x)))
;in (fact 6)"
;                  720)

      (HO-nested-letrecs
"letrec even(odd)  = proc(x) if zero?(x) then 1 else (odd -(x,1))
   in letrec  odd(x)  = if zero?(x) then 0 else ((even odd) -(x,1))
   in (odd 13)" 1)


      ;; extremely primitive testing for mutable variables

      (assignment-test-1 "let x = 17
                          in let garbage = set x = 27 in x"
        27)


      (gensym-test
"let g = let count = 0 in proc(d)
                        let d = set count = -(count,-1)
                        in count
in -((g 11), (g 22))"
-1)

      (example-for-book-1 "
let f = proc (x) proc (y)
                  let garbage = set x = -(x,-1) in -(x,y)
in ((f 44) 33)"
        12)

        ))))