;; self-evaluating evaluator

(define global-env
  (list '(read     . (prim . read    )) '(newline  . (prim . newline))
        '(write    . (prim . write   )) '(symbol?  . (prim . symbol?))
        '(null?    . (prim . null?   )) '(pair?    . (prim . pair?  ))
        '(car      . (prim . car     )) '(cdr      . (prim . cdr    ))
        '(cadr     . (prim . cadr    )) '(cons     . (prim . cons   ))
        '(set-cdr! . (prim . set-cdr!)) '(assoc    . (prim . assoc  ))
        '(eq?      . (prim . eq?     )) '(list     . (prim . list   ))))

(define env-read
  (lambda (env var)
    (cdr (assoc var env))))

(define env-set!
  (lambda (env var val)
    (cond ((eq? (car (car env)) var) (set-cdr! (car env) val))
          ((null? (cdr env))         (set-cdr! env (list (cons var val))))
          (#t                        (env-set! (cdr env) var val)))))

(define env-extend
  (lambda (env parms vals)
    (cond ((null? parms) env)
          (#t            (cons (cons (car parms) (car vals))
                               (env-extend env (cdr parms) (cdr vals)))))))

(define eval
  (lambda (expr env)
    (cond ((symbol? expr) (env-read env expr))
          ((pair? expr)   (eval-composite (car expr) (cdr expr) env))
          (#t             expr))))

(define eval-composite
  (lambda (x lst env)
    (cond ((assoc x macros)  (eval (apply (env-read macros x) lst) env))
          ((eq? x 'defmacro) (env-set! macros (car lst) (eval (cadr lst) env)))
          ((eq? x 'set!)     (env-set! env (car lst) (eval (cadr lst) env)))
          ((eq? x 'quote)    (car lst))
          ((eq? x 'lambda)   (eval-lambda lst env))
          ((eq? x 'begin)    (eval-begin #f lst env))
          ((eq? x 'cond)     (eval-cond lst env))
          (#t                (eval-call x lst env)))))

(define eval-lambda
  (lambda (parms-and-body def-env)
    (cons parms-and-body def-env)))

(define eval-begin
  (lambda (val lst env)
    (cond ((null? lst) val)
          (#t          (eval-begin (eval (car lst) env) (cdr lst) env)))))

(define eval-cond
  (lambda (lst env)
    (cond ((eval (car (car lst)) env) (eval (cadr (car lst)) env))
          ((pair? (cdr lst))          (eval-cond (cdr lst) env)))))

(define eval-call
  (lambda (fn-expr arg-exprs env)
    (apply (eval fn-expr env) (eval-list arg-exprs env))))

(define eval-list
  (lambda (lst env)
    (cond ((null? lst) '())
          (#t          (cons (eval (car lst) env)
                             (eval-list (cdr lst) env))))))

(define apply
  (lambda (fn lst)
    (cond ((eq? (car fn) 'prim)
           (cond ((eq? (cdr fn) 'read)     (read))
                 ((eq? (cdr fn) 'newline)  (newline))
                 ((eq? (cdr fn) 'write)    (write    (car lst)))
                 ((eq? (cdr fn) 'symbol?)  (symbol?  (car lst)))
                 ((eq? (cdr fn) 'null?)    (null?    (car lst)))
                 ((eq? (cdr fn) 'pair?)    (pair?    (car lst)))
                 ((eq? (cdr fn) 'car)      (car      (car lst)))
                 ((eq? (cdr fn) 'cdr)      (cdr      (car lst)))
                 ((eq? (cdr fn) 'cadr)     (cadr     (car lst)))
                 ((eq? (cdr fn) 'cons)     (cons     (car lst) (cadr lst)))
                 ((eq? (cdr fn) 'set-cdr!) (set-cdr! (car lst) (cadr lst)))
                 ((eq? (cdr fn) 'assoc)    (assoc    (car lst) (cadr lst)))
                 ((eq? (cdr fn) 'eq?)      (eq?      (car lst) (cadr lst)))
                 ((eq? (cdr fn) 'list)     lst)))
          (#t
           (eval (cadr (car fn))
                 (env-extend (cdr fn) (car (car fn)) lst))))))
  
(define macros
  (list (cons 'define
              (eval-lambda '((var expr) (list 'set! var expr)) global-env))))

(define repl
  (lambda ()
    (begin (write '>) (write (eval (read) global-env)) (newline) (repl))))

;; ----------------------------------------------------------------------
;Does the code below qualify?

;Features:
;  - conditional construct
;  - functions (of one argument)
;  - application
;  - quotation

;The environment is represented as a function from strings to values.
;To look up the name n in the environment r is simply (r n).
;Extending the environment is done by function composition.
;It is done directly since I have only included no binding construct
;besides application. Restricting functions to one variable makes
;application simpler. Recursion is done by the trick discussed in
;length on c.l.l this week.

;There is no mutation - I didn't need it.

; Self evaluating evaluator, version 2
; Jens Axel Søgaard, oct 2002

(define first car)
(define second cadr)
(define third caddr)
(define rest cdr)

; Support code for fak-example
(define (plus a) (lambda (b) (+ a b)))
(define (mult a) (lambda (b) (* a b)))
(define (one? x) (= x 1))
(define (sub1 n) (- n 1))

(define fak '(lambda (f)
               (lambda (n)
                 (cond
                   [(one? n)  1]
                   [#t        ((mult n) ((f f) (sub1 n)))]))))

(define fac-code (list (list fak fak) 5))


; Conventions:  n name, v value, r environment, e expression
(define code-jas-eval
  '(lambda (ev)
     (lambda (e)
       (lambda (r)
         (cond
           [(symbol? e)      (r e)]
           [(not (pair? e))  e]
           [(pair? e)        (cond
                               [((ceq? (first e)) 'quote)  (first (rest e))]
                               [((ceq? (first e)) 'cond)
                                (cond
                                  [(((ev ev) (first (second e))) r)  (((ev ev) (second (second e))) r)]
                                  [#t                                (((ev ev) ((ccons 'cond) (rest (rest e)))) r)])]
                               [((ceq? (first e)) 'lambda)              (lambda (x)
                                                                       (((ev ev) (third e))
                                                                        (lambda (n)
                                                                          (cond
                                                                            [((ceq? (first (second e))) n)   x]
                                                                            [#t                           (r n)]))))]
                               [#t                                   ((((ev ev) (first e)) r)
                                                                      (((ev ev) (second e)) r))])])))))

; setup initial environment;
; currying the primitives used in the evaluator
(define (ceq? a)
  (lambda (b)
    (eq? a b)))

(define (ccons a)
  (lambda (b)
    (cons a b)))

(define initial-env eval)


; use Scheme-eval to get jas-eval
(define jas-eval (eval code-jas-eval))
(define initial-env eval)

; test it in (fak 5)
(define expression fac-code)
(time (((jas-eval jas-eval) expression) initial-env))

; use jas-eval to evaluate (jas-eval (fak 5) initial-env)
(define expression (list (list (list code-jas-eval code-jas-eval) (list 'quote fac-code)) initial-env))
;expression
(time (((jas-eval jas-eval) expression) initial-env))

; use jas-eval to evaluate (jas-eval (fak 5) initial-env)
(define expression (list (list (list code-jas-eval code-jas-eval) (list 'quote fac-code))  initial-env))
(define expression (list (list (list code-jas-eval code-jas-eval) (list 'quote expression)) initial-env))
;expression
(time (((jas-eval jas-eval) expression) initial-env))