;;; Subramaniam
;;; C311/S96 Assignment 4
;;; Interpreters

(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 parse
  (lambda (exp)
    (cond
      [(symbol? exp) (make-varref exp)]
      [(number? exp) (make-lit exp)]
      [(and (list? exp) (eq? (car exp) 'if) (= 4 (length exp)))
       (make-if
	 (parse (cadr exp))
	 (parse (caddr exp))
	 (parse (cadddr exp)))]
      [else
	(make-app
	  (parse (car exp))
	  (map parse (cdr exp)))])))

(define eval-exp
  (lambda (exp)
    (variant-case exp
      (lit (datum) datum)
      (varref (var) (apply-env init-env var))
      (if (test conseq alt)
	  (if (true-value? (eval-exp test env))
	      (eval-exp conseq)
	      (eval-exp alt)))
      (app (rator rands)
	(let ((proc (eval-exp rator))
	      (args (eval-rands rands)))
	  (apply-proc proc args))))))

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

(define apply-proc
  (lambda (proc args)
    (variant-case proc
      (prim-proc (prim-op) (apply-prim-op prim-op args)))))

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

;;; An extremely naive environment model.
(define init-env
  (list
    (cons 'equal (make-prim-proc 'equal))
    (cons 'zero (make-prim-proc 'zero))
    (cons 'less (make-prim-proc 'less))
    (cons 'greater (make-prim-proc 'greater))
    (cons '+ (make-prim-proc '+))
    (cons '- (make-prim-proc '-))
    (cons '* (make-prim-proc '*))
    (cons 'add1 (make-prim-proc 'add1))
    (cons 'sub1 (make-prim-proc 'sub1))
    (cons 'minus (make-prim-proc 'minus))))
 
(define apply-env
  (lambda (env v)
    (cond
      [(null? env) (error 'apply-env "Variable ~s unbound~n" v)]
      [(eq? (caar env) v) (cdar env)]
      [else (apply-env (cdr env) v)])))
      
(define run
  (lambda (exp)
    (eval-exp (parse exp))))