(load "datatype.ss")

(define variable? symbol?)

(define list-of
  (lambda (pred)
    (lambda (lst)
      (andmap pred lst))))

(define-datatype core-exp
  (num (val number?))
  (varref (var variable?))
  (app (operator core-exp?)
       (operands (list-of core-exp?)))
  (lambda (formals (list-of variable?))
          (body core-exp?))
  (if (test core-exp?)
      (then core-exp?)
      (else core-exp?))
  (let (decls (list-of declaration?))
       (body core-exp?)))

(define-datatype declaration
  (decl (var variable?)
        (exp core-exp?)))

(define recordify
  (lambda (exp)
    (cond      
      ((number? exp) (make-num exp))      
      ((symbol? exp) (make-varref exp))
      ((not (pair? exp)) (error 'recordify "illegal expression ~s" exp))
      ((eq? (car exp) 'lambda)
       (make-lambda (cadr exp) (recordify (caddr exp))))
      ((eq? (car exp) 'if)
       (make-if (recordify (cadr exp)) 
                (recordify (caddr exp))
                (recordify (cadddr exp)))) 
      ((eq? (car exp) 'let)
       (let ((vars (map car (cadr exp))) 
             (exps (map cadr (cadr exp))))
         (let ((exps (map recordify exps)))
           (make-let (map make-decl vars exps) 
                     (recordify (caddr exp)))))) 
      (else (make-app (recordify (car exp)) 
                      (map recordify (cdr exp)))))))

(define-datatype env-type
  (empty-env)
  (extended-env (symbol-list (list-of variable?))
                (val-list list?)
                (env env-type?)))

(define create-empty-env
  (lambda ()
    (make-empty-env)))

(define extend-env 
  (lambda (sym-list val-list env)
    (make-extended-env sym-list val-list env)))

(define apply-env
  (lambda (env var)
    (type-case env-type env
      [(empty-env) (error 'eval-exp "Unbound variable: ~s" exp)]
      [(extended-env sym-list val-list envr)
        (let ((val (ribassoc var sym-list
                     (list->vector val-list) '*fail*)))
           (if (eq? val '*fail*)
               (apply-env envr var)
               val))])))

(define get-index
  (lambda (a ls)
    (cond
      [(eq? a (car ls)) 0]
      [else (add1 (get-index a (cdr ls)))])))

(define ribassoc
  (lambda (s los v fail-value)
    (cond
      [(memq s los) (vector-ref v (get-index s los))]
      [else fail-value])))

;;; Initial environment

(define init-env
  (let ((null (lambda (x) (if (null? x) 1 0)))
        (zero (lambda (x) (if (zero? x) 1 0)))
        (equal (lambda (x y) (if (= x y) 1 0)))
        (less (lambda (x y) (if (< x y) 1 0)))
        (greater (lambda (x y) (if (> x y) 1 0))))
    (extend-env
      '(+ - * add1 sub1 cons car cdr list null equal zero less greater)
      (list + - * add1 sub1 cons car cdr list null equal zero less greater)
      (extend-env '(emptylist) '(()) (create-empty-env)))))

;;; Interpreter

(define apply-proc apply)

(define eval-exp
  (lambda (exp)
    (type-case core-exp exp
      ((num val) val)
      ((varref var) (apply-env init-env var))
      ((app operator operands)
        (let ((rator (eval-exp operator))
              (rands (map eval-exp operands)))
          (apply-proc rator rands)))
      ((if test then else)
          (if (= (eval-exp test) 0) (eval-exp else) (eval-exp then)))
      (else (error 'eval-exp "invalid syntax tree: ~s" exp)))))