;; ----------------------------------------
;; 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" id "=" expression
                 "in" expression)
                let-exp)
    (expression ("proc(" type-expression id ")" expression)
		proc-exp)
    (expression ("(" expression expression ")")
                app-exp)
    (expression ("!")
		loop-forever-exp)
    
    (primitive ("cons")
               cons-prim)
    (primitive ("car")
	       car-prim)
    (primitive ("cdr")
	       cdr-prim)
    (primitive ("iscons")
	       iscons-prim)
    (primitive ("+")
               add-prim)
    (primitive ("-")
               subtract-prim)
    (primitive ("*") 
               mult-prim)
    (primitive ("add1") 
               incr-prim)               
    (primitive ("sub1") 
               decr-prim)

    (type-expression ("num")
		     num-texp)
    (type-expression ("(" type-expression "->" type-expression ")")
		     proc-texp)
    (type-expression ("[" type-expression ":" type-expression "]")
		     pair-texp)))

;; 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)

;; ----------------------------------------
;; Type Checker

(define-datatype type type?
  (number-type)
  (proc-type
    (arg-type type?)
    (result-type type?))
  (pair-type
    (left-type type?)
    (right-type type?)))

; expand-type : type-expression -> type
(define (expand-type texpr)
  (cases type-expression texpr
    (num-texp () (number-type))
    (proc-texp (arg-texpr result-texpr) 
	       (proc-type (expand-type arg-texpr) (expand-type result-texpr)))
    (pair-texp (left-texpr right-texpr) 
	       (pair-type (expand-type left-texpr) (expand-type right-texpr)))))

; type-of-expression : program -> type
(define (type-of-program prog)
  (cases program prog
         (a-program (expr) (type-of-expression expr (empty-tenv)))))

; type-of-expression : expression tenv -> type
(define (type-of-expression exp tenv)
  (cases expression exp
    (loop-forever-exp () (number-type))
    (lit-exp (sym) (number-type))
    (var-exp (id) (apply-tenv tenv id))
    (let-exp (id rhs body)
             (let ((rhs-type (type-of-expression rhs tenv)))
               (type-of-expression 
                body
                (extend-tenv id rhs-type tenv))))
    (proc-exp (texpr id body)
	      (let ((arg-type (expand-type texpr)))
		(let ((result-type (type-of-expression 
				    body
				    (extend-tenv id arg-type tenv))))
		  (proc-type arg-type result-type))))
    (app-exp (rator rand)
	     (let ([rator-type (type-of-expression rator tenv)]
		   [rand-type (type-of-expression rand tenv)])
	       (cases type rator-type
		 (proc-type (arg-type result-type)
			    (check-equal-type! arg-type rand-type exp)
			    result-type)
		 (else (eopl:error 'application 
				   "type of function expression ~e is not a procedure type in ~e"
                                   (type-to-external-form rator-type)
				   rator)))))
    (primapp-exp (prim rands)
		 (type-of-primitive-application
		  prim
		  (map (lambda (rand)
                         (type-of-expression rand tenv))
                       rands)
                  exp))
    (if-exp (test-expr then-expr else-expr)
	    ;; THIS IS NOT RIGHT! <<<<<<<<<<<<<<--------
	    (number-type))))

; type-of-primitive-application : primitive list-of-types expression => type
;  The expression argument is merely for error reporting.
(define type-of-primitive-application
  (lambda (prim arg-types exp)
    ;; THIS IS NOT RIGHT! <<<<<<<<<<<<<<--------
    (number-type)))

;;;;;;;;;;;;;;;; type helper functions ;;;;;;;;;;;;;;;;

(define type-to-external-form
  (lambda (ty)
    (cases type ty
      (number-type () 'num)
      (proc-type (arg-type result-type)
		 (list
		  (type-to-external-form arg-type)
		  '->
		  (type-to-external-form result-type)))
      (pair-type (left-type right-type)
		 (list
		  (type-to-external-form left-type)
		  ':
		  (type-to-external-form right-type))))))

;;;;;;;;;;;;;;;; type equivalence ;;;;;;;;;;;;;;;;

; type-of-primitive-application : type type expression -> 
;  The expression argument is merely for error reporting.
(define check-equal-type!               
  (lambda (t1 t2 exp)
    (if (equal? t1 t2)
	'ok
	(eopl:error 'check-equal-type!
		    "Type mismatch: ~s doesn't match ~s in ~s~%"
		    (type-to-external-form t1)
		    (type-to-external-form t2)
		    exp))))

;;;;;;;;;;;;;;;; type environment ;;;;;;;;;;;;;;;;

(define-datatype type-environment type-environment?
  (empty-tenv-record)
  (extended-tenv-record
   (name symbol?)
   (type type?)
   (tenv type-environment?)))

(define empty-tenv empty-tenv-record)
(define extend-tenv extended-tenv-record)

(define apply-tenv 
  (lambda (tenv name-to-find)
    (cases type-environment tenv
      (empty-tenv-record ()
			 (eopl:error 'apply-tenv "unbound variable: ~e" name-to-find))
      (extended-tenv-record (name type tenv)
			    (if (eq? name name-to-find)
				type
				(apply-tenv tenv name-to-find))))))

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

;; eval-program : program -> num-proc-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)))))

(define-datatype proc proc?
  (closure (param symbol?)
	   (body expression?)
	   (env list?)))

;; eval-expression : expression env -> num-proc-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)))
    (proc-exp (texpr param body)
	      (closure param body env))
    (app-exp (func arg)
	     (let ((arg-val (eval-expression arg env))
		   (func-val (eval-expression func env)))
	       (cases proc func-val
		 (closure (param body closure-env)
			  (eval-expression 
			   body 
			   (extend-env (list param)
				       (list arg-val)
				       closure-env))))))
    (loop-forever-exp () (letrec ([loop (lambda () (loop))])
			   (loop)))))


;; 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-proc-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-proc-trees -> num-proc-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))]
    [car-prim () (car (car lont))]
    [cdr-prim () (cdr (car lont))]
    [iscons-prim () (cond
                      [(pair? (car lont)) 1]
                      [else 0])]
    [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)))


; type-check : string -> val
;
; Takes a string respresting concrete syntax and
; infers types while checking it. If it checks, a value
; is returned representing the type, otherwise an error
; is reported.
;
;  (type-check "5") = num
;  (type-check "proc(num x)x") = (num -> num)
;
(define type-check
  (lambda (string)
    (type-to-external-form (type-of-program (scan&parse string)))))

;; ----------------------------------------
;; 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))

;; -------------- 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))))))