;; ----------------------------------------
;; Parser

;; First, we describe high-level classes of tokens, like numbers 
;; and ids (i.e., the ones we defined as direct sets in the
;; first lecture):

(define scanner-spec
  '((white-sp
     (whitespace)                           skip)
    (id
     (letter (arbno (or letter digit "?"))) make-symbol)
    (number
     (digit (arbno digit))                  make-number)))

;; Then we write the BNF in a paritcular format:

(define grammar
  '((program (expression)
             a-program) ;; we leave off field names in this form
    
    (expression (number)
                lit-exp)
    (expression (id)
                var-exp)
    (expression (primitive 
                 "(" (separated-list expression ",")")")
                primapp-exp)
    (expression ("if" expression "then" expression 
                 "else" expression)
                if-exp)
    (expression ("let" (arbno id "=" expression)
                 "in" expression)
                let-exp)
    
    (primitive ("cons")
               cons-prim)
    (primitive ("+")
               add-prim)
    (primitive ("-")
               subtract-prim)
    (primitive ("*") 
               mult-prim)
    (primitive ("add1") 
               incr-prim)               
    (primitive ("sub1") 
               decr-prim)))

;; scan&parse : string -> program
;;  Parses one program (provided in a string)
(define scan&parse
  (sllgen:make-string-parser scanner-spec grammar))


;; The parsing support can even generate the define-datatype
;;  expressions for us, so the ones above are not needed:
(sllgen:make-define-datatypes scanner-spec grammar)

;; ----------------------------------------
;; Evaluator

;; eval-program : program -> num-tree
;; 
;;   (eval-program (a-program (lit-exp 0))) = 0
;;   (eval-program (a-program (var-exp 'x))) = error
;;   (eval-program (a-program (primapp-exp
;;                                 (add-prim)
;;                                 (list (lit-exp 1)
;;                                       (lit-exp 2)))) = 3
(define (eval-program prog)
  (cases program prog
    (a-program (exp) (eval-expression exp (empty-env)))))

;; eval-expression : expression env -> num-tree
;;
;;  (eval-expression (lit-exp 0) (empty-env)) = 0
;;  (eval-expression (var-exp 'x) 
;                    (extend-env '(x y) '(1 2) (empty-env))) = 1
;;  ... and more examples, based on programs above ...
;;
(define (eval-expression expr env)
  ;; (eopl:printf "(eval-expression ~a ~a)~n" expr env)
  (cases expression expr
    (lit-exp (n) n)
    (var-exp (sym) (apply-env env sym))
    (primapp-exp (prim loe) 
                 (apply-prim prim (eval-rands loe env)))
    (if-exp (test nonzero-branch zero-branch)
            (if (numtree-zero? (eval-expression test env))
                (eval-expression zero-branch env)
                (eval-expression nonzero-branch env)))
    (let-exp (los loe body)
             (eval-expression body
                              (extend-env los
                                          (eval-rands loe env)
                                          env)))))

;; numtree-zero?: <num-tree> -> <boolean>
;; numtree-zero? return true iff all the numbers in the tree are zero.
;; (numtree-zero? 1) = #f
;; (numtree-zero? 0) = #t
;; (numtree-zero? '((0 . 0) . (0 . 0))) = #t
;; (numtree-zero? '((0 . 0) . (0 . 1))) = #f
(define (numtree-zero? tree)
  (fold-tree (lambda (a b) (and a b))  (lambda (x) (= x 0)) tree))

;; <list-of-expr> ::= '()
;;                ::= (cons <expr> <list-of-expr>)

;; eval-rands : list-of-expr env -> list-of-num-tree
;;   takes a list of expression,andproduces the corresponding
;;    list of values after evaluating the expressions
(define (eval-rands loe env)
  (cond
    [(null? loe) '()]
    [else  (cons (eval-expression (car loe)env)
                 (eval-rands (cdr loe) env))]))


;; apply-prim : primitive list-of-num-trees -> num-tree
;; (apply-prim (cons-prim) '(1 2)) = '(1 . 2)
;; (apply-prim (cons-prim) '((1 . 2) ((1 . (2 . 4))))) = '((1 . 2) . ((1 . (2 . 4))))
;; (apply-prim (add-prim) '(1 2)) = 3
;; (apply-prim (add-prim) '(((1 . 2) . (3 . 4)) ((5 . 6) . (7 . 8)))) = '((6 . 8) . (10 . 12))
(define (apply-prim prim lont)
  ;; (eopl:printf "(apply-prim ~a ~a)~n" prim lon)
  (cases primitive prim
    [cons-prim () (cons (car lont) (cadr lont))]
    [add-prim () (combine-trees + (car lont) (cadr lont))]
    [subtract-prim () (combine-trees - (car lont) (cadr lont))]
    [mult-prim () (combine-trees * (car lont) (cadr lont))]
    [incr-prim () (heavier-tree (car lont))]
    [decr-prim () (map-tree (lambda (x) (- x 1)) (car lont))]))


;; combine-trees: (<num> <num> -> <num>) <num-tree> <num-tree> -> <num-tree>
;; Assuming t1 and t2 have the same shape, build a new tree by performing op
;; on corresponding numbers in t1 and t2.
;; (combine-trees + 1 2) = 3
;; (combine-trees + '((1 . 2) . (3 . 4)) '((5 . 6) . (7 . 8))) =
;;   '((6 . 8) . (10 . 12))
(define (combine-trees op t1 t2)
  (cond
    ((and (number? t1) (number? t2))
     (op t1 t2))
    ((and (pair? t1) (pair? t2))
     (cons (combine-trees op (car t1) (car t2))
           (combine-trees op (cdr t1) (cdr t2))))))

;; ----------------------------------------
;; Read-eval-print:

;; Provides a prompt that reads programs and evals them:
(define read-eval-print
  (sllgen:make-rep-loop
   "-->" 
   eval-program
   (sllgen:make-stream-parser scanner-spec grammar)))



;; ----------------------------------------
;; Environments:

;; <env> ::= '()
;;       ::= (cons (cons <symbol> <number>) <env>)

;; empty-env : -> env
(define (empty-env) '())

;; extend-env : list-of-symbol list-of-number env -> env
(define (extend-env names vals env)
  (letrec ([make-pairs
            ;; This local function takes a list of names
            ;; and a list of values and creates a list
            ;; of pairs of name and value.
	    (lambda (names vals)
	      (cond
	       [(null? names) '()]
	       [else (cons (cons (car names) (car vals))
			   (make-pairs (cdr names) (cdr vals)))]))])
    ;; Add new pairs to old environment:
    (append (make-pairs names vals) env)))

;; apply-env : env symbol -> num
(define (apply-env env s)
  (cond
   [(null? env) (eopl:error 'apply-env 
                            "no binding for variable: ~a" s)]
   [else (cond
           ;; Check whether the first binding is the one we're
           ;;  looking for
           [(eq? (car (car env)) s) (cdr (car env))]
           ;; If not, look in the rest of the environment:
           [else (apply-env (cdr env) s)])]))


;; ------------ 4.1 ------------------

;; map-tree: (<num> -> <num>) <num-tree> -> <num-tree>
(define (map-tree f tree)
  (cond
    ((number? tree) (f tree))
    (else
     (cons (map-tree f (car tree))
           (map-tree f (cdr tree))))))

(define (heavier-tree tree)
  (map-tree (lambda (x) (+ 1 x)) tree))

(define (zero-tree tree)
  (map-tree (lambda (n) 0) tree))

(define (grow-tree tree)
  (map-tree (lambda (n) (cons n n)) tree))

;; -------------- 4.2 -----------------
;; fold-tree: (x x -> x) (<num> -> x) <num-tree> -> x
(define (fold-tree combine make-base tree)
  (cond
    ((number? tree) (make-base tree))
    (else
     (combine (fold-tree combine make-base (car tree))
              (fold-tree combine make-base (cdr tree))))))

(define (sum-tree tree)
  (fold-tree + (lambda (x) x) tree))

(define (max-tree tree)
  (fold-tree max (lambda (x) x) tree))

(define (content-tree tree)
  (fold-tree append list tree))