;;---------------------------------------------------------------------
;;
;;  C A L L -- B Y -- V A L U E   ,    S T A T I C    S C O P I N G
;;
;;                      CS515  Ulrich Kremer
;;---------------------------------------------------------------------

;; Solution to Homework 4 Problem 1.2 (adding let and let*):
;; See comments CHANGE 1-CHANGE 4 and new testcases at the bottom.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                             Parser
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define name?
  (lambda (s)
    (and (symbol? s)
         (not (memq s '(if lambda let let*)))))) ; CHANGE 1: add to keywords.

(define andmap
  (lambda (f l)
    (if (null? l) 
	#t
	(and (f (car l))
	     (andmap f (cdr l))))))

;; used for let*
(define parse-id-list
  (lambda (l)
    (cond
     ((null? l) '())
     ((and (list? (car l)) (= 2 (length (car l))) (name? (caar l)))
      (cons (list (caar l) (parse (cadar l))) (parse-id-list (cdr l))))
     (else error 'parse-id-list "Error parsing id list"))))
      
(define parse
  (lambda (m)
    (cond
      ((number? m)  `(&const ,m))
      ((eq? #t m)   `(&const #t))
      ((eq? #f m)   `(&const #f))
      ((name? m)    `(&var ,m))
      ((pair? m)    (cond 
                      ((eq? `if (car m))
                        (if (= 4 (length m))
                            `(&if ,(parse (cadr m))
                                  ,(parse (caddr m)) ,(parse (cadddr m)))
                            (error 'parse "Syntax error")))
                      ((eq? `lambda (car m))
                        (if (and (= 3 (length m))
                                 (list? (cadr m))
                                 (andmap name? (cadr m)))
                            `(&lambda ,(cadr m) ,(parse (caddr m)))
                            (error 'parse "Syntax error")))
                      ((eq? 'let (car m))         ; CHANGE 2: parse syntax 
                       (if (and (= 2 (length m))
                                (list? (cadr m))
                                (list? (caadr m))
                                (= (length (caadr m)) 2)
                                (name? (caaadr m)))
                           `(&let (,(caaadr m) ,(parse (car (cdaadr m)))) ,(parse (cadadr m)))
                           (error 'parse "Syntax error in 'let'")))
                      ((eq? 'let* (car m))
                       (if (and (= 3 (length m))
                                (list? (cadr m)))
                           `(&let* ,(parse-id-list (cadr m)) ,(parse (caddr m)))
                           (error 'parse "Syntax error in let*")))
                      (else
                        `(&apply ,(parse (car m)) ,(parse* (cdr m))))))
      (else         (error 'parse "Syntax error")))))

(define parse* (lambda (m) (map parse m)))

;; helper function for let*
(define unparse-id-list
  (lambda (l)
    (cond
     ((null? l) '())
     (else
      (cons (list (caar l) (unparse (cadar l))) (unparse-id-list (cdr l)))))))

(define unparse
  (lambda (a)
    (cond
      ((eq? (car a) `&const) (cadr a))
      ((eq? (car a) `&var)   (cadr a))
      ((eq? (car a) `&if)    `(if ,(unparse (cadr a)) ,(unparse (caddr a)) 
                                 ,(unparse (cadddr a))))
      ((eq? (car a) '&lambda) `(lambda ,(cadr a) ,(unparse (caddr a))))
      ((eq? (car a) `&apply)  (cons (unparse (cadr a)) (map unparse (caddr a))))
      ((eq? (car a) '&closure) `(lambda ,(caddr a) ,(unparse (cadddr a))))
      ((eq? (car a) '&let) `(let ((,(caadr a) ,(unparse (cadadr a))) ; CHANGE 3
                              ,(unparse (caddr a)))))
      ((eq? (car a) '&let*) `(let* ,(unparse-id-list (cadr a))
                               ,(unparse (caddr a))))
      (else  (error 'unparse "unexpected syntax tree" a)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;            Environment and closure representations
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define extend*
  (lambda (env xs vs)
    (if (null? xs)
        env
        (extend* (extend env (car xs) (car vs)) (cdr xs) (cdr vs)))))

(define extend
  (lambda (env x v)
    (lambda (y)        ;; environment as function
      (if (eq? x y)
          v
          (lookup env y)))))

(define interpret-free-var
  (lambda (x)
    `(&const ,(eval x))))

(define empty-env interpret-free-var)

(define lookup
  (lambda (env y) (env y)))

;; closures, list implementation 
(define mk-closure                     ;; returns (&closure env parm-list body)
  (lambda (env v)
    (cond
     ((eq? (car v) '&lambda) `(&closure ,env ,(cadr v) ,(caddr v)))))) 

(define apply-cl
  (lambda (vf va)
    (cond
     ((eq? (car vf) '&closure)
      (let ((env (cadr vf))      ;; environment
	    (p   (caddr vf))     ;; parameter list
	    (b   (cadddr vf)))   ;; body
        (if (= (length p) (length va))
            (ev b (extend* env p va))
            (error 'apply-cl "wrong number of arguments")))))))

(define delta
  (lambda (f a)
    (let ((R (lambda (s) `(&const ,s)))
          (R-1 (lambda (cl)
                 (cond
		  ((eq? (car cl) `&const) (cadr cl))
		  (else (error 'delta "non-constant argument"))))))
      (R (apply (R-1 f) (map R-1 a))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                     Closure Interpreter
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; evaluate environment with a list of values for let* - note how it
;;  carries the updated environment through the computation.
(define extend-list
  (lambda (l env)
    (if (null? l)
        env
        (let* ((name (caar l))
               (val (ev (cadar l) env))
               (env2 (extend env name val)))
          (extend-list (cdr l) env2)))))  

(define ev
  (lambda (e env)
    (cond
      ((eq? (car e) '&const) e)                            ;; e == (&const c)
      ((eq? (car e) '&var) (lookup env (cadr e)))          ;; e == (&var v)
      ((eq? (car e) '&lambda)  (mk-closure env e))         ;; e == (&lambda parm-list body)
      ((eq? (car e) '&if) (let ((a (cadr e))               ;; e == (&if a b c)
				(b (caddr e))
				(c (cadddr e)))
			    (ev (if (equal? (ev a env) '(&const #f)) c b) env)))

      ((eq? (car e) `&apply) (let ((f (cadr e))            ;; e == (&apply f args)
				   (args (caddr e)))
			       (let ((fv (ev f env))
				     (av (map (lambda (a) (ev a env)) args)))
				 (if (and (pair? fv) (eq? (car fv) '&const))
				     (delta fv av) 
				     (apply-cl fv av)))))
      ((eq? (car e) '&let) (let ((nam (caadr e))    ;; CHANGE 4: evaluation
                                 (val (ev (cadadr e) env))
                                 (body (caddr e)))
                             (ev body (extend env nam val))))
      ((eq? (car e) '&let*) (let ((vlist (cadr e))
                                  (body (caddr e)))
                              (ev body (extend-list vlist env)))) )))

(define evaluate
  (lambda (m)
    (unparse (ev (parse m) empty-env))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                         Test cases
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define M1 `((lambda (x) (+ x 1)) 5))
(define M2 `((lambda (x) (+ x 2)) (if #t 3 2)))
(define M3 `(lambda (x y z) ((x y) z))) 
(define M4 '((lambda (y) (y 1 2)) (lambda (x z) (+ x z))))
(define M5 '((lambda (x) ( (lambda (x) (+ x 1)) 2 ) ) 1))
(define M6 `((lambda (x z) (x 1 (z 2 2))) + *))
(define M7 `((lambda () 1)))
(define M8 `((lambda (x) (+ x 0)) (+ 1 2)))
(define M9 '((lambda (x) x) (+ 1 2)))
(define M10 '((lambda (x) ((lambda (z) ((lambda (x) (z x)) 3)) (lambda (y) (+ x y)))) 1))
(define M11 '((lambda (x) 1) ((lambda (x) (x x)) (lambda (x) (x x)))))
(define M20 '( (lambda (x) ((lambda (z) ((lambda (x) (+ z x)) 2)) x)) 1))


;; new testcases for let and let*
(define L1 '((lambda (n) 
              (let ((newval (+ n 2))
                    (+ newval newval)))) 1))

(define L2 '(let ((foo 5) (+ foo 7))))

(define L3 '(let* ((foo 5) (bar (+ foo 1))) (+ bar 1)))

(define L4 '(let* ((foo 3)) (+ foo 5)))