;;; Subramaniam
;;; C311/S96 Assignment 5
;;; Interpreters - continued

(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 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) '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 env)
    (variant-case exp
      (lit (datum) datum)
      (varref (var) (apply-env env var))
      (if (test conseq alt)
	  (if (true-value? (eval-exp test env))
	      (eval-exp conseq env)
	      (eval-exp alt env)))
      (proc (formals body)
	(make-closure formals body env))
      (begin (exp1 exp2)
	(let ((throw-away (eval-exp exp1 env)))
	  (eval-exp exp2 env)))
      (varassign (var exp)
	(mutate-env! env var (eval-exp exp env)))
      (define (var exp)
	(init-env-set! var (eval-exp exp env)))
      (app (rator rands)
	(let ((proc (eval-exp rator env))
	      (args (eval-rands rands env)))
	  (apply-proc proc args))))))

(define eval-rands
  (lambda (rands env)
    (map (lambda (exp) (eval-exp exp env)) rands)))

(define apply-proc
  (lambda (proc args)
    (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))))))

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