#lang racket

(require "chez-init.rkt")
(require racket/trace)

;<expression>::= <identifier>
;            ::= <number>
;            ::= (if <expression> <expression> <expression>)
;            ::= (let ((<identifier> <expression>)*) <expression>)
;            ::= (lambda (<identifier>+) <expression>)
;            ::= (<expression> <expression>+)

(define-datatype expression expression?
  [var-exp
   (id symbol?)]
  [num-exp
   (val number?)]
  [if-exp
   (condition expression?)
   (if-true expression?)
   (if-false expression?)]
  [let-exp
   (ids (listof symbol?))
   (vals (listof expression?))
   (body expression?)]
  [lambda-exp
   (ids (listof symbol?))
   (body expression?)]
  [app-exp
   (da-exp (listof expression?))])

(define parse-exp
  (lambda (input)
    (cond [(symbol? input) [var-exp input]]
          [(number? input) [num-exp input]]
          [(pair? input)
           (cond [(eq? (car input) 'lambda)
                  [lambda-exp (cadr input) (parse-exp (caddr input))]]
                 [(eq? (car input) 'let)
                  [let-exp (map car (cadr input))
                           (map parse-exp (map cadr (cadr input)))
                           (parse-exp (caddr input))]]
                 [(eq? (car input) 'if)
                  [if-exp (parse-exp (cadr input))
                          (parse-exp (caddr input))
                          (parse-exp (cadddr input))]]
                 [else [app-exp (map parse-exp input)]])]
          [else 'error])))


;; interpreter proper
(define eval-exp
 (lambda (parse-tree env)
   (cases expression parse-tree
     [var-exp (id) (apply-env env id)]
     [num-exp (val) val]
     [if-exp (condition if-true if-false)
             (if (eval-exp condition) (eval-exp if-true) (eval-exp if-false))]
     [lambda-exp (ids body) (closure ids body env)]
     [app-exp (da-exp)
              (let ([vals (map (lambda (exp) (eval-exp exp env)) da-exp)]) 
                (apply-proc (car vals) (cdr vals)))]
     [else (error 'eval-exp "Should not be here: ~s" parse-tree)])))
;(trace eval-exp)

(define syntax-expand
  (lambda (parse-tree)
    (cases expression parse-tree
      [var-exp (id) parse-tree]
      [num-exp (val) parse-tree]
      [if-exp (condition if-true if-false)     
              (if-exp (syntax-expand condition) (syntax-expand if-true) (syntax-expand if-false))]
      [lambda-exp (ids body) (lambda-exp ids (syntax-expand body))]
      [let-exp (ids vals body)
               (app-exp (cons (lambda-exp ids (syntax-expand body)) (map syntax-expand vals)))]
      [app-exp (da-exp) (app-exp (map syntax-expand da-exp))])))
    

(define eval-one-exp
  (lambda (input)
    (let* ([parse-tree (parse-exp input)]
           [exp-parse-tree (syntax-expand parse-tree)]
           [val (eval-exp exp-parse-tree simple-env)])
      val)))

(define apply-proc
  (lambda (proc args)
    (if (procedure? proc)
        (cases procedure proc
          [closure (ids body env)
                          (eval-exp body (extend-env ids args env))]
          [primitive (id) (apply-prim-proc id args)])
        (error 'apply-proc "no procedure"))))

(define apply-prim-proc
  (lambda (id args)
    (case id
      [(+) (apply + args)]
      [(-) (apply - args)]
      [(car) (caar args)]
      [(add1) (+ 1 (caar args))]
      )))
      
(define-datatype environment environment? 
  [empty-env-record]
  [extended-env-record
    (syms (listof symbol?))
    (vals vector?)
    (env environment?)])

(define empty-env
  (lambda ()
    (empty-env-record)))

(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms (list->vector vals) env)))

(define apply-env
  (lambda (env sym)
    (cases environment env
      [empty-env-record ()
        (error 'apply-env "No binding for ~s" sym)]
      [extended-env-record (syms vals env)
        (let ((pos (find-position sym syms 0)))
          (if (number? pos)
            (vector-ref vals pos)
            (apply-env env sym)))])))

;(trace apply-env)

(define find-position
  (lambda (sym ls pos)
    (cond [(null? ls) #f]
	  [(eq? sym (car ls)) pos]
	  [else (find-position sym (cdr ls) (+ pos 1))])))

(define-datatype procedure procedure?
  [closure
   (ids (listof symbol?))
   (body expression?)
   (env environment?)]
  [primitive
   (id symbol?)])

(define *prim-proc-names* '(+ - car cdr add1))

(define simple-env
  (extend-env *prim-proc-names*
              (map primitive *prim-proc-names*)
              (empty-env)))