;; Simple interpreter of section 3.6 -- 
;; based on online code 3-6*.scm
;; recursive procedures

;;;;;;;;;;;;;;;; top level and tests ;;;;;;;;;;;;;;;;

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

;;;;;;;;;;;;;;;; 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)))

(define the-grammar
  '((program (expression) a-program)
    (expression (number) lit-exp)
    (expression (identifier) var-exp)   
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression
      ("if" expression "then" expression "else" expression)
      if-exp)
    (expression
      ("let" (arbno  identifier "=" expression) "in" expression)
      let-exp)
    (expression
     ("proc" "(" (separated-list identifier ",") ")" expression)
     proc-exp)
    (expression
     ("(" expression (arbno expression) ")")
     app-exp)
    (expression                         ; new for 3-6
      ("letrec"
        (arbno identifier "(" (separated-list identifier ",") ")"
          "=" expression)
        "in" expression)
      letrec-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive ("zero?") zero-test-prim)

    ))

(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))

(define read-eval-print 
  (sllgen:make-rep-loop  "--> "
    (lambda (pgm) (eval-program pgm))   ; wrapped to avoid load
                                        ; dependency 
    (sllgen:make-stream-parser 
      the-lexical-spec
      the-grammar)))

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

(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (eval-expression body (init-env))))))

(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)))
      (if-exp (test-exp true-exp false-exp) 
        (if (true-value? (eval-expression test-exp env))
          (eval-expression true-exp env)
          (eval-expression false-exp env)))
      (let-exp (ids rands body)  
          (eval-expression body (extend-env ids (eval-rands rands env) env)))
      (proc-exp (ids body)
          (closure ids body env))
      (app-exp (rator rands)
          (apply-procval (eval-expression rator env)
                                (eval-rands rands env)))
      (letrec-exp (proc-names idss bodies letrec-body) 
        (eval-expression letrec-body
          (extend-env-recursively proc-names idss bodies env)))
      )))

(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

;; alternative definition:  (cvarela 2003/09/25)

(define eval-rand eval-expression)


(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))
      (zero-test-prim () (if (zero? (car args)) 1 0))
      )))

;; alternative definition allowing a variable number of arguments for
;; primitive operators +,-,*:  (gunduz 2003/09/29)

(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim  () (apply + args))
      (subtract-prim () (apply - args))
      (mult-prim  () (apply * args))
      (incr-prim  () (+ (car args) 1))
      (decr-prim  () (- (car args) 1))
      (zero-test-prim () (if (zero? (car args)) 1 0))
      )))

(define init-env 
  (lambda ()
    (extend-env
      '(i v x)
      '(1 5 10)
      (empty-env))))
               
;;;;;;;;;;;;;;;; booleans ;;;;;;;;;;;;;;;;
;;;;;;;;; Number representation;;;;

(define true-value?
  (lambda (x)
    (not (zero? x))))

;;;;;;;;;;;;;;;;;;;;; Procedure Values ;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;; Procedural Representation ;;;;;;;;;;;;;;;;;

(define closure
  (lambda (ids body env)
    (lambda (args)
      (eval-expression body (extend-env ids args env)))))

(define apply-procval
  (lambda (proc args)
    (if (not (procedure? proc))
	(eopl:error 'apply-procval 
		    "Attempt to apply non-procedure ~s" proc)
	(proc args))))

;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; procedural representation ;;;;;;

(define environment? procedure?)

(define apply-env
  (lambda (env sym)
    (env sym)))

(define empty-env
  (lambda ()
    (lambda (sym)
      (eopl:error 'empty-env "No binding for: ~s" sym))))

(define extend-env
  (lambda (ids vals env)
    (lambda (sym)
      (let ((pos (rib-find-position sym ids)))
        (if (number? pos)
          (list-ref vals pos)
          (apply-env env sym))))))

(define extend-env-recursively
  (lambda (proc-names idss bodies old-env)
    (letrec
      ((rec-env
         (lambda (sym)
           (let ((pos (rib-find-position sym proc-names)))
             (if (number? pos)
               (closure
                 (list-ref idss pos)
                 (list-ref bodies pos)
                 rec-env)
               (apply-env old-env sym))))))
      rec-env)))

(define rib-find-position 
  (lambda (sym los)
    (list-find-position sym los)))

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

; or simply:

(define rib-find-position list-find-position)

(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))))))


;; e.g., in defined language:

(run
"
  (proc (x,y) +(x,y) 2 5)
")

(run
"
  let f = proc (y,z) +(y,-(z,5))
  in  (f 2 28)
")

(run
"
  let curry = proc (f) proc (x) proc (y) (f x y)
       plus = proc (x,y) +(x,y)
  in (((curry plus) 2) 3)
")

(run
"
  let a = 3
  in let p = proc (x) +(x,a)
          a = 5
      in *(a,(p 2))
")

(run
"
  let makemult = proc (maker,x)
                            if x
                            then +(4,(maker maker sub1(x)))
                            else 0
  in let times4 = proc (x) (makemult makemult x)
      in (times4 3)
")

;; Exercise 3.21

(run
"
let fact = proc (maker,x)
                            if  x
                            then *(x,(maker maker sub1(x)))
                            else 1
  in let factorial = proc (x) (fact fact x)
      in (factorial 3)
")

;; Exercise 3.22

(run
"
let evenR = proc(even1,odd1,x)
                  if x
                  then (odd1 odd1 even1 sub1(x))
                  else 1
     oddR = proc(odd1,even1,x)
                  if x
                  then (even1 even1 odd1 sub1(x))
                  else 0
in let even =proc(x) (evenR evenR oddR x)
        odd = proc(x) (oddR oddR evenR x)
    in (even 6)
")

;; Using letrec:

(run
"
  letrec
    fact(x) = if zero?(x) then 1 else *(x,(fact sub1(x)))
  in (fact 6)
")

(run
"
  letrec
    even(x) = if zero?(x) then 1 else (odd sub1(x))
    odd(x)  = if zero?(x) then 0 else (even sub1(x))
  in (odd 6)
")