;;; Interpreter for lambda calculus expressions

(define eval-one-exp
  (lambda (exp)
    (top-level-eval (parse-expression exp))))


(define rep
  (lambda ()
    (display ">> ")
    (let ([input (read)])
      (if (equal? input '(exit))
	  (printf "Bye...~%")
	  (let* ([parse-tree (parse-expression input)]
		 [response (top-level-eval parse-tree)])
	    (pretty-print response)
	    (rep))))))


(define top-level-eval
  (lambda (form)
    (eval-expression form (empty-env))))


(define eval-expression
  (lambda (exp env)
    (cases expression exp
	   [var-exp (id) (apply-env env id)]
	   [lit-exp (val) val]
;;;	   [assignment-exp (id val)
;;;			   (change-env env id (eval-expression val env))]
	   [begin-exp (bodies)
		      (let loop ([bodies bodies])
			(if (null? (cdr bodies))
			    (eval-expression (car bodies) env)
			    (begin (eval-expression (car bodies) env)
				   (loop (cdr bodies)))))]
	   [let-exp (ids vals bodies)
		    (let* ([evaluated-vals (eval-expressions vals env)]
			   [extended-env (extend-env ids evaluated-vals env)])
		      (let loop ([bodies bodies])
			(if (null? (cdr bodies))
			    (eval-expression (car bodies) extended-env)
			    (begin (eval-expression (car bodies) extended-env)
				   (loop (cdr bodies))))))]
	   [if-exp (test-exp true-exp false-exp)
		   (if (eval-expression test-exp env)
		       (eval-expression true-exp env)
		       (eval-expression false-exp env))]
	   [cond-exp (exps)
		     (if (null? exps)
			 '()
			 (if (eq? (caar exps) 'else)
			     (eval-expression (cadar exps) env)
			     (if (eval-expression (caar exps) env)
				 (eval-expression (cadar exps) env)
				 (eval-expression (cond-exp (cdr exp)) env))))]
					  
	   [lambda-exp (ids bodies)
		       (make-closure ids bodies env)]
	   [app-exp (operator operands)
		    (let ([procedure (eval-expression operator env)]
			  [args (eval-expressions operands env)])
		      (apply-proc procedure args env))])))


(define eval-expressions
  (lambda (exps env)
    (if (null? exps)
	'()
	(cons (eval-expression (car exps) env)
	      (eval-expressions (cdr exps) env)))))

(define eval-bodies
  (lambda (exps env)
    (if (null? (cdr exps))
	(eval-expression (car exps) env)
	(cons (eval-expression (car exps) env)
	      (eval-bodies (cdr exps) env)))))


(define apply-proc
  (lambda (procedure args env)
    (cases proc procedure
	   [closure (ids bodies env)
		    (eval-bodies bodies (extend-env ids args env))]
	   [primitive (name)
		      (apply-primitive-procedure name args)])))


(define make-closure
  (lambda (ids body env)
    (closure ids body env)))

(define-datatype proc proc?
  [closure
   (ids (list-of symbol?))
   (bodies (list-of expression?))
   (env pair?)]
  [primitive
   (name symbol?)])


(define apply-primitive-procedure
  (lambda (name args)
    (let ([1st (if (null? args)
		   '()
		   (car args))]
	  [2nd (if (null? args)
		   '()
		   (if (null? (cdr args))
		       '()
		       (cadr args)))])
      (case name
	[(+) (apply + args)]
	[(*) (* 1st 2nd)]
	[(/) (/ 1st 2nd)]
	[(-) (if (null? (cdr args))
		 (- 1st)
		 (- 1st 2nd))]
	[(cdr) (cdr 1st)]
	[(car) (car 1st)]
	[(zero?) (zero? 1st)]
	[(=) (= 1st 2nd)]
	[(<) (< 1st 2nd)]
	[(>) (> 1st 2nd)]
	[(<=) (<= 1st 2nd)]
	[(>=) (>= 1st 2nd)]
	[(cons) (cons 1st 2nd)]
	[(list) args]
	[(null?) (null? 1st)]
	[(eq?) (eq? 1st 2nd)]
	[(display) (display 1st)]
	[(newline) (newline)]
	[(exit) 'need-to-exit]))))

(define primitive-procedure-names '(+ - * / zero? = < <= => > cons car
				      cdr list null? eq?  exit display newline))


(define global-env
  (map (lambda (name)
	 (cons name (primitive name)))
       primitive-procedure-names))