(define top-level-eval
  (lambda (form)
    (cases expression form
	   [define-exp (sym val)
	     (extend-global-env sym (eval-expression val (empty-env)))]
	   [begin-exp (bodies)
		      (if (not (null? bodies))
			  (cases expression (car bodies)
				 [define-exp (sym val)
				   (extend-global-env sym (eval-expression val (empty-env)))
				   (top-level-eval (begin-exp (cdr bodies)))]
				 [else (eval-expression form (empty-env))]))]
	   [else (eval-expression form (empty-env))])))


(define eval-expression
  (lambda (exp env)
    (cases expression exp
           [var-exp (id) (apply-env env id)]
	   [set-exp (sym val) (change-env env sym (eval-expression val env))]
	   [lit-exp (val) val]
	   [begin-exp (bodies)
		      (if (not (null? bodies))
			  (eval-bodies bodies env))]
;			  (let loop ([bodies bodies])
;			    (if (null? (cdr bodies))
;				(eval-expression (car bodies) env)
;				(begin (eval-expression (car bodies) env)
;				       (loop (cdr bodies))))))]
;	   [or-exp (exps)
;		   (cond [(null? exps) #f]
;			 [else (or (eval-expression (car exps) env)
;				   (eval-expression (or-exp (cdr exps)) env))])]
;	   [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))))))]
	   [letrec-exp (ids vals bodies)
		       (let* ([evaluated-vals (eval-expressions vals env)]
			      [extended-env (extend-env-recur ids evaluated-vals env)])
			 (eval-bodies bodies extended-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-then-exp (test-exp true-exp)
			(if (eval-expression test-exp env)
			    (eval-expression true-exp env))]
	   [if-else-exp (test-exp true-exp false-exp)
			(if (eval-expression test-exp env)
			    (eval-expression true-exp env)
			    (eval-expression false-exp env))]
	   [lambda-exp (ids bodies)
		       (closure ids bodies env)]
	   [lambda-exp-list (id bodies)
			    (list-closure id bodies env)]
	   [lambda-exp-dotted-list (ids bodies)
				   (dotted-closure ids bodies env)]
	   [app-exp (operator operands)
		    (let ([procedure (eval-expression operator env)])
			  (cases proc procedure
				 [closure (ids body closure-env)
					  (let* ([args (eval-operands ids operands env)]
						 [new-ids (map (lambda (x) (if (pair? x)
									       (cadr x)
									       x))
							       ids)]
						 [new-closure (closure new-ids body closure-env)])
					    (apply-proc new-closure args))]
				 [else (apply-proc procedure (eval-expressions operands env))]))]
	   [else (eopl:error 'evalexpression
			     "~s" exp)])))


(define eval-operands
  (lambda (ids operands env)
    (cond [(null? ids) '()]
	  [(symbol? (car ids))
	   (cons (eval-expression (car operands) env)
		 (eval-operands (cdr ids) (cdr operands) env))]
			  ;;; Need to check that this is a var-exp or var-ref
	  [else (cons (list 'ref (cadar operands) env)
		      (eval-operands (cdr ids) (cdr operands) 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)
    (let* ([split-exps (extract-define-exps exps '())]
	   [new-env (if (null? (car split-exps))
			env
			(eval-defines (car split-exps) env '() '()))])
      (eval-bodies-without-define (cadr split-exps) new-env))))
      


(define eval-defines
  (lambda (exps env syms vals)
    (if (null? exps)
	(extend-env-recur syms vals env)
	(cases expression (car exps)
	       [define-exp (sym val) 
		 (eval-defines (cdr exps) env (cons sym syms) (cons (eval-expression val env) vals))]
	       [else (extend-env-recur syms vald env)]))))


(define extract-define-exps
  (lambda (exps accu)
    (if (null? exps)
	(list (reverse accu))
	(cases expression (car exps)
	       [define-exp (sym val) (extract-define-exps (cdr exps) (cons (car exps) accu))]
	       [else (list (reverse accu) exps)]))))
		 

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


(define apply-proc
  (lambda (procedure args)
    (cases proc procedure
	   [closure (ids bodies env)
		    (eval-bodies bodies (extend-env ids args env))]
	   [list-closure (id bodies env)
		    (eval-bodies bodies (extend-env (list id) (list args) env))]
	   [dotted-closure (ids bodies env)
			   (let ([result (make-args-vals ids args)])
			     (eval-bodies bodies (extend-env (car result) (cadr result) env)))]
	   [primitive (name)
		      (apply-primitive-procedure name args )])))



(define make-args-vals
  (lambda (args vals)
    (if (symbol? args)
        (cons (list args) (list (list vals)))
        (let ([result (make-args-vals (cdr args) (cdr vals))])
          (list (cons (car args) (car result))
                (cons (car vals) (cadr result)))))))	   


(define-datatype proc proc?
  [closure
   (ids (list-of parameter?))
   (bodies (list-of expression?))
   (env scheme-value?)]
  [list-closure
   (id symbol?)
   (bodies (list-of expression?))
   (env scheme-value?)] 
  [dotted-closure
   (ids scheme-value?)
   (bodies (list-of expression?))
   (env scheme-value?)]
  [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)];(error 'apply-primitive-procedure "~s ~s\n" name args)] ;(apply + args)]
	[(*) (apply * args)]
	[(/) (/ 1st 2nd)]
	[(-) (if (null? (cdr args))
		 (- 1st)
		 (- 1st 2nd))]
	[(cdr) (cdr 1st)]
	[(car) (car 1st)]
	[(caar) (caar 1st)]
	[(cadr) (cadr 1st)]
	[(cdar) (cdar 1st)]
	[(cddr) (cddr 1st)]
	[(caaar) (caaar 1st)]
	[(caadr) (caadr 1st)]
	[(caddr) (caddr 1st)]
	[(cadar) (cadar 1st)]
	[(cdaar) (cdaar 1st)]
	[(cddar) (cddar 1st)]
	[(cdadr) (cdadr 1st)]
	[(cdddr) (cdddr 1st)]
	[(procedure?) (proc? 1st)]
	[(zero?) (zero? 1st)]
	[(set-car!) (set-car! 1st 2nd)]
	[(map) (letrec ([loop (lambda (ls)
				(if (null? ls) 
				    '()
				     (cons (apply-proc 1st (list (car ls)))
					   (loop (cdr ls)))))])
		 (loop 2nd))]
	[(apply) (letrec ([loop (lambda (ls)
				  (if (null? ls) 
				      (apply-proc 1st '())
				      (apply-proc 1st (list (car ls)
							    (loop (cdr ls))))))])
		   (loop 2nd))]
	[(=) (= 1st 2nd)]
	[(<) (< 1st 2nd)]
	[(>) (> 1st 2nd)]
	[(<=) (<= 1st 2nd)]
	[(>=) (>= 1st 2nd)]
	[(not) (not 1st)]
;	[(or) (or 1st 2nd)]
	[(cons) (cons 1st 2nd)]
	[(append) (append 1st 2nd)]
	[(assq) (assq 1st 2nd)] 
	[(assv) (assv 1st 2nd)] 
	[(list) args]
	[(max) (apply max args)]
	[(vector) (apply vector args)]
	[(vector?) (vector? 1st)]
	[(null?) (null? 1st)]
	[(number?) (number? 1st)]
	[(pair?) (pair? 1st)]
	[(eq?) (eq? 1st 2nd)]
	[(display) (display 1st)]
	[(newline) (newline)]
	[(exit) 'need-to-exit]))))

(define primitive-procedure-names '(+ - * / zero? = < <= >= > cons
max assq assv append apply map car set-car! cdr caar cadr cdar cddr
procedure? pair?  list null? eq?  exit display newline vector vector?
not caaar caadr caddr cadar cdaar cddar cdadr cdddr number?))


;(define global-env
;  (lambda ()
;    (extend-env primitive-procedure-names
;		       (map primitive primitive-procedure-names)
;		       (empty-env))))


(define make-init-env
  (lambda ()
    (cons (cons 'else #t)
	  (map (lambda (name)
		 (cons name (primitive name)))
	       primitive-procedure-names))))

(define global-env
  (make-init-env))

(define reset-global-env
  (lambda () (set! global-env (make-init-env))))