(cs441-load "sets.scm")
(cs441-load "parser.scm")

;
; new records for representing MicroScheme values
;
(define-record Prim (name))
(define-record Closure (formals body env))

;
; finite functions
;
(define make-empty
  (lambda ()
    (lambda (x) #f)))

(define extend
  (lambda (f d r)
    (lambda (x)
      (if (eq? x d)
          r
          (f x)))))

(define lookup
  (lambda (f x)
    (f x)))

(define extend-list
  (lambda (env doms rans)
    (if (null? doms)
        env
        (extend-list
          (extend env (car doms) (car rans))
          (cdr doms) 
          (cdr rans)))))

;
; general purpose helpers
;
(define firsts
  (lambda (lst)
    (map car lst)))

(define seconds
  (lambda (lst)
    (map cadr lst)))

(define last 
  (lambda (lst)
    (cond ((null? lst) '())
          ((null? (cdr lst)) (car lst))
          (else (last (cdr lst))))))

;; Scheme's map does not guarantee what order it walks the list
(define mapLR
  (lambda (f l)
    (if (null? l)
        '()
        (let ((x (f (car l))))
          (cons x (mapLR f (cdr l))))))) 

;
; box related functions
;
(define-record Boxrep (unbox set-box!))

(define make-box 
  (lambda (v)
    (make-Boxrep
      (lambda () v)
      (lambda (new) (set! v new)))))

(define unbox
  (lambda (b)
    ((Boxrep->unbox b))))

(define set-box!
  (lambda (b v)
    ((Boxrep->set-box! b) v)))    

(define swap-boxes
  (lambda (a b)
    (if (null? a) #f
         (let ((temp (unbox (car b))))
               (set-box! (car b) (unbox (car a)))
               (set-box! (car a) temp)
               (swap-boxes (cdr a) (cdr b))))))

;
; meta-circular interpreter 
;
(define env_1 
  (extend-list (make-empty) 
     (list 'not 'symbol? 'number? 'pair? 'car 'cdr 'eq? '= 'cons '+ '* '- '/)
     (list (lambda (x) (not x))
	   (lambda (x) (symbol? x))
	   (lambda (x) (number? x))
	   (lambda (x) (pair? x))
	   (lambda (x) (car x))
	   (lambda (x) (cdr x))
	   (lambda (x y) (eq? x y))
	   (lambda (x y) (= x y))
	   (lambda (x y) (cons x y))
	   (lambda x (apply + x))
	   (lambda x (apply * x))
	   (lambda x (apply - x))
	   (lambda x (apply / x)))))

(define eval1
  (lambda (sexp)
    (eval_1 (parse sexp) env_1)))

(define eval_1
  (lambda (e env)
    (variant-case e
      (Const (value)
        value)
      (Var (name) (lookup env name))
      (Beg (exprs)
           (last (mapLR (lambda (x) (eval_1 x env)) exprs)))
      (If (test then else)
          (if (eval_1 test env)
              (eval_1 then env)
              (eval_1 else env))) 
      (Let (bindings body)
        (let ((vars (firsts bindings))
              (exps (mapLR (lambda (x) (eval_1 x env)) (seconds bindings))))
          (eval_1 body (extend-list env vars exps))))
      (Let* (bindings body)
        (if (null? bindings)
            (eval_1 body env)
            (let ((x (car (car bindings)))
                  (e (cadr (car bindings)))
                  (rest (cdr bindings)))
              (eval_1 (make-Let* rest body)
                (extend env x (eval_1 e env))))))
      (Lam (formals body) 
           (lambda args
             (if (= (length args) (length formals))
                 (eval_1 body (extend-list env formals args))
                 (error "wrong number of args to lambda"))))
      (Ap (fun args)
          (let* ((vfun (eval_1 fun env))
                 (vargs (mapLR (lambda (x) (eval_1 x env)) args)))
            (if (procedure? vfun)
                (apply vfun vargs)
                (error "not a procedure: " vfun)))))))

;
; FOT interpreter
;
(define eval2
  (lambda (sexp)
    (eval_2 (parse sexp) (make-empty))))
     
(define eval_2
  (lambda (e env)
    (variant-case e
      (Const (value) value)
      (Var (name) (or (lookup env name) (make-Prim name)))
      (Lam (formals body) (make-Closure formals body env))
      (Beg (exprs) (last (mapLR (lambda (x) (eval_2 x env)) exprs))) 
      (If (test then else)
          (if (eval_2 test env)
              (eval_2 then env)
              (eval_2 else env))) 
      (Let (bindings body)
        (let ((vars (firsts bindings))
              (exps (mapLR (lambda (x) (eval_2 x env)) (seconds bindings))))
          (eval_2 body (extend-list env vars exps))))
      (Let* (bindings body)
        (if (null? bindings)
            (eval_2 body env)
            (let ((x (car (car bindings)))
                  (e (cadr (car bindings)))
                  (rest (cdr bindings)))
              (eval_2 (make-Let* rest body)
                (extend env x (eval_2 e env))))))
      (Ap (fun args) 
          (let* ((vfun (eval_2 fun env))
                 (vargs (mapLR (lambda (x) (eval_2 x env)) args)))
            (variant-case vfun
              (Closure (formals body env)
                (if (= (length formals) (length vargs))
                    (eval_2 body (extend-list env formals vargs))
                    (error "wrong number of args to lambda")))
              (Prim (name) 
                    (cond ((eq? name 'not) (apply not vargs))
                          ((eq? name 'symbol?) (apply symbol? vargs))
                          ((eq? name 'number?) (apply number? vargs))
                          ((eq? name 'pair?) (apply pair? vargs))
                          ((eq? name 'car) (apply car vargs))
                          ((eq? name 'cdr) (apply cdr vargs))
                          ((eq? name 'eq?) (apply eq? vargs))
                          ((eq? name '=) (apply = vargs))
                          ((eq? name 'cons)  (apply cons vargs))
                          ((eq? name '+) (apply + vargs))
                          ((eq? name '*) (apply * vargs))
                          ((eq? name '-) (apply - vargs))
                          ((eq? name '/) (apply / vargs))
                          (else (error "unknown primitive"))))              
              (else
                (error "not a procedure: " vfun))))))))

;
; FOT with letrec and set!
;
(define eval3
  (lambda (sexp)
    (eval_3 (parse sexp) (make-empty))))

(define eval_3
  (lambda (e env)
    (variant-case e
      (Const (value) value)
      (Var (name) 
           (let ((b (lookup env name)))
             (if b (unbox b) (make-Prim name))))
      (Lam (formals body) (make-Closure formals body env))
      (Beg (exprs) (last (mapLR (lambda (x) (eval_3 x env)) exprs))) 
      (If (test then else)
          (if (eval_3 test env) (eval_3 then env) (eval_3 else env))) 
      (Let (bindings body)
        (let ((vars (firsts bindings))
              (exps (mapLR (lambda (x) (eval_3 x env)) (seconds bindings))))
          (eval_3 body (extend-list env vars (map make-box exps)))))
      (Let* (bindings body)
        (if (null? bindings)
            (eval_3 body env)
            (let ((x (car (car bindings)))
                  (e (cadr (car bindings)))
                  (rest (cdr bindings)))
              (eval_3 (make-Let* rest body)
                (extend env x (make-box (eval_3 e env)))))))
      (Letrec (bindings body)
        (let* ((b (map make-box (firsts bindings)))
               (newenv (extend-list env (firsts bindings) b))
               (v (mapLR (lambda (x) (eval_3 x newenv)) (seconds bindings))))
          (map set-box! b v)
          (eval_3 body newenv)))
      (Dlet (bindings body)
	(let ((boxes (mapLR (lambda (x) (lookup env x)) (firsts bindings)))
              (t (mapLR make-box (mapLR (lambda (x) (eval_3 x env)) 
					(seconds bindings)))))
          (swap-boxes boxes t)
          (let ((result (eval_3 body env)))
            (swap-boxes boxes t)
            result)))
      (Set! (name body)
        (begin
          (set-box! (lookup env name) (eval_3 body env))
          #f))
      (Ap (fun args) 
          (let* ((vfun (eval_3 fun env))
                 (vargs (mapLR (lambda (x) (eval_3 x env)) args)))
            (variant-case vfun
              (Closure (formals body env) 
                (if (= (length formals) (length vargs))
                    (eval_3 body (extend-list env formals (map make-box vargs)))
                    (error "wrong number of args to lambda")))
              (Prim (name) 
                    (cond ((eq? name 'not) (apply not vargs))
                          ((eq? name 'symbol?) (apply symbol? vargs))
                          ((eq? name 'number?) (apply number? vargs))
                          ((eq? name 'pair?) (apply pair? vargs))
                          ((eq? name 'car) (apply car vargs))
                          ((eq? name 'cdr) (apply cdr vargs))
                          ((eq? name 'eq?) (apply eq? vargs))
                          ((eq? name '=) (apply = vargs))
                          ((eq? name 'cons)  (apply cons vargs))
                          ((eq? name '+) (apply + vargs))
                          ((eq? name '*) (apply * vargs))
                          ((eq? name '-) (apply - vargs))
                          ((eq? name '/) (apply / vargs))
                          (else (error "unknown primitive"))))
              (else
                (error "not a procedure: " vfun))))))))