;;; Subramaniam/Hilsdale
;;; C311/S96 Assignment 6
;;; Interpreters - continued with letrec and dynlet

; expanding this with letrec was fairly straightforward.  Adding
; dynlet necessitated adding another environment into eval-exp.

(load "record.ss")

(define-record  varref (var))
(define-record  lit (datum))
(define-record  app (rator rands))
(define-record  if (test conseq alt))
(define-record  prim-proc (prim-op))
(define-record  proc (formals body))
(define-record  closure (formals body env))
(define-record  varassign (var exp))
(define-record  begin (exp1 exp2))
(define-record  define (var exp))
(define-record  dynlet (vars exps body))
(define-record  dyn (var))		
(define-record  letrec (vars exps body))

(define parse
  (lambda (exp)
    (cond
      [(symbol? exp) (make-varref exp)]
      [(number? exp) (make-lit exp)]
      [(and (pair? exp) (eq? (car exp) 'if) (= 4 (length exp)))
       (make-if
	 (parse (cadr exp))
	 (parse (caddr exp))
	 (parse (cadddr exp)))]
      [(and (pair? exp) (eq? (car exp) 'lambda))
       (make-proc (cadr exp) (parse (cons 'begin (cddr exp))))]
      [(and (pair? exp) (eq? (car exp) 'let))
       (make-app
	 (make-proc (map car (cadr exp)) (parse (cons 'begin (cddr exp))))
	 (map parse (map cadr (cadr exp))))]
      [(and (pair? exp) (eq? (car exp) 'dynlet))
       (make-dynlet
	 (map car (cadr exp))
	 (map parse (map cadr (cadr exp)))
	 (parse (cons 'begin (cddr exp))))]
      [(and (pair? exp) (eq? (car exp) 'letrec))
       (make-letrec
	 (map car (cadr exp))
	 (map parse (map cadr (cadr exp)))
	 (parse (cons 'begin (cddr exp))))]
      [(and (pair? exp) (eq? (car exp) 'dyn))
       (make-dyn (cadr exp))]
      [(and (pair? exp) (eq? (car exp) 'begin))
       (if (= (length (cdr exp)) 1)
	   (parse (cadr exp))
	   (make-begin (parse (cadr exp)) (parse (cons 'begin (cddr exp)))))]
      [(and (pair? exp) (eq? (car exp) 'set!))
       (make-varassign (cadr exp) (parse (caddr exp)))]
      [(and (pair? exp) (eq? (car exp) 'define))
       (make-define (cadr exp) (parse (caddr exp)))]
      [else
	(make-app
	  (parse (car exp))
	  (map parse (cdr exp)))])))

(define eval-exp
  (lambda (exp senv denv)
    (variant-case exp
      (lit (datum) datum)
      (varref (var) (apply-env senv var))
      (dyn (var) (apply-env denv var))
      (dynlet (vars exps body)
	(let ((vals (eval-rands exps senv denv)))
	  (eval-exp body senv
	    (extend-env* vars vals denv))))
      (letrec (vars exps body)
	(let ((new-senv (extend-env* vars (make-temps vars) senv)))
	  (let ((vals (eval-rands exps new-senv denv)))
	    (for-each
	      (lambda (var val)
		(mutate-env! new-senv var val))
	      vars vals)
	    (eval-exp body new-senv denv))))
      (if (test conseq alt)
	  (if (true-value? (eval-exp test senv denv))
	      (eval-exp conseq senv denv)
	      (eval-exp alt senv denv)))
      (proc (formals body)
	(make-closure formals body senv))
      (begin (exp1 exp2)
	(let ((throw-away (eval-exp exp1 senv denv)))
	  (eval-exp exp2 senv denv)))
      (varassign (var exp)
	(mutate-env! senv var (eval-exp exp senv denv)))
      (define (var exp)
	(init-env-set! var (eval-exp exp senv denv)))
      (app (rator rands)
	(let ((proc (eval-exp rator senv denv))
	      (args (eval-rands rands senv denv)))
	  (apply-proc proc args denv))))))

(define make-temps
  (lambda (vars)
    (if (null? vars)
	'()
	(cons 0 (make-temps (cdr vars))))))

(define eval-rands
  (lambda (rands senv denv)
    (map (lambda (exp) (eval-exp exp senv denv)) rands)))

(define apply-proc
  (lambda (proc args denv)
    (variant-case proc
      (prim-proc (prim-op) (apply-prim-op prim-op args))
      (closure (formals body env)
	(eval-exp body (extend-env* formals args env) denv)))))

(define apply-prim-op
  (lambda (prim-op args)
    (case prim-op
      ((equal) (if (and (number? (car args))
			(number? (cadr args))
			(= (car args) (cadr args)))
		   1
		   0))
      ((zero) (if (zero? (car args)) 1 0))
      ((less) (if (and (number? (car args))
		       (number? (cadr args))
		       (< (car args) (cadr args)))
		  1
		  0))
      ((greater) (if (and (number? (car args))
			  (number? (cadr args))
			  (> (car args) (cadr args)))
		     1
		     0))
      ((+) (+ (car args) (cadr args)))
      ((-) (- (car args) (cadr args)))
      ((*) (* (car args) (cadr args)))
      ((add1) (+ (car args) 1))
      ((sub1) (- (car args) 1))
      ((minus) (* -1 (car args))))))
    
(define true-value?
  (lambda (x)
    (cond
      ((number? x) (not (zero? x)))
      (else #t))))


(define empty-env '())

(define init-env
  (let ((prim-ls
	  (list 'equal 'zero 'less 'greater '+ '- '* 'add1 'sub1 'minus)))
    (cons
      prim-ls
      (list->vector (map (lambda (x) (make-prim-proc x)) prim-ls)))))

(define init-env-set!
  (lambda (var val)
    (let ((names (car init-env))
	  (vals (cdr init-env)))
      (let ((find-result (member var names)))
	(if find-result
	    (vector-set! vals (- (length names) (length find-result)) val)
	    (let ((names (cons var names))
		  (vals (list->vector (cons val (vector->list vals)))))
	      (set! init-env (cons names vals))))))))

(define apply-init-env
  (lambda (v)
    (let ((names (car init-env))
	  (vals (cdr init-env)))
      (let ((find-result (member v names)))
	(if find-result
	    (vector-ref vals (- (length names) (length find-result)))
	    (error 'apply-env "Variable ~s unbound" v))))))

(define extend-env*
  (lambda (vars vals env)
    (cons (cons vars (list->vector vals)) env)))

(define apply-env
  (lambda (env v)
    (if (null? env)
	(apply-init-env v)
	(let ((names (caar env))
	      (vals (cdar env)))
	  (let ((find-result (member v names)))
	    (if find-result
		(vector-ref vals (- (length names) (length find-result)))
		(apply-env (cdr env) v)))))))

(define mutate-env!
  (lambda (env v val)
    (if (null? env)
	  (init-env-set! v val)
	  (let ((names (caar env))
		(vals (cdar env)))
	    (let ((find-result (member v names)))
	      (if find-result
		  (vector-set! vals
		    (- (length names) (length find-result)) val)
		  (mutate-env! (cdr env) v val)))))))

(define run
  (lambda (exp)
    (eval-exp (parse exp) empty-env empty-env)))