;; Ray Hodgkiss
;; c311 Assignment 4


;; Loads the datatype stuff
(load "datatype.ss")

;; This makes things a little more clear.
(define variable? symbol?)

;; This helps test for lists
(define list-of
  (lambda (pred)
    (lambda (lst)
      (andmap pred lst))))

;;===========================================================================
;;DATATYPES
;;Most datatypes are defined here.
;;---------------------------------------------------------------------------

;; This is my full-exp datatype...
;; it gets converted into a core-exp datatype

(define-datatype full-exp
  (num^ (val number?))
  (varref^ (var variable?))
  (app^ (operator full-exp?)
	(operands (list-of full-exp?)))
  (lambda^ (formals (list-of variable?))
	   (body full-exp?))
  (if^ (test full-exp?)
       (then full-exp?)
       (else full-exp?))
  (let^ (decls (list-of declaration?))
    (body full-exp?))
  (begin^ (exp full-exp?)
	  (statements (list-of full-exp?)))
  (varassign^ (vari variable?)
	 (expr full-exp?)))

;; core-exp datatype
;; Almost the same as a full-exp, w/o a let.
;; let is converted into a lambda
  
(define-datatype core-exp
  (num (val number?))
  (varref (var variable?))
  (app (operator core-exp?)
       (operands (list-of core-exp?)))
  (lambda (formals (list-of variable?))
    (body core-exp?))
  (if (test core-exp?)
      (then core-exp?)
      (else core-exp?))
  (begin exp1 exp2)
  (varassign (vari variable?)
	(expr core-exp?)))

;; declaration
;; This helps with variable assignment

(define-datatype declaration  
  (decl (var variable?)
	(exp full-exp?))) ;; just changed this from core-exp?

;; primitives
(define-datatype primitives
  (closure formals body env)
  (primitive proc))

(define-datatype env-type
  (empty-env)
  (extend-env (var-list (list-of symbol?))
	      (val-vector vector?)
	      (old-env env-type?)))


(define create-empty-env
  (lambda ()
    (make-empty-env)))


(define extend-env
  (lambda (var-list val-vector env)
    (make-extend-env var-list (list->vector val-vector) env)))



(define-datatype form
  (define (var variable?) (exp core-exp?))
  (expression (exp core-exp?)))


;;==========================================================================


(define ribassoc
  (lambda (s los v fail-value)
    (cond
     [(memq s los) (vector-ref v (get-index s los))]
     [else fail-value])))

(define get-index
  (lambda (sym lst)
    (cond
     [(eq? (car lst) sym) 0]
     [else
      (+ 1 (get-index sym (cdr lst)))])))


;;==========================================================================
;; recordify, expand-to-core, expand-to-full
;; These three together turn scheme-expressions into full-expressions
;; and then back into a core-expression....
;; Actually, its just one giant recordify, depending on how you
;; look at it...

(define recordify
  (lambda (expr)
    (if (and (pair? expr) (eq? (length expr) 3) (eq? (car expr) 'define))
	(make-define (cadr expr) (expand-to-core (expand-to-full (caddr expr))))
	(make-expression (expand-to-core (expand-to-full expr))))))

(define decls->var
  (lambda (dec)
    (type-case declaration dec
       [(decl var exp) var])))

(define decls->exp
  (lambda (dec)
    (type-case declaration dec
       [(decl var exp) exp])))

(define expand-to-core
  (lambda (f-exp)
    (type-case full-exp f-exp
       [(num^ val) (make-num val)]
       [(varref^ var) (make-varref var)]
       [(app^ operator operands)
	(make-app (expand-to-core operator)
		  (map expand-to-core operands))]
       [(lambda^ formals body)
	(make-lambda formals (expand-to-core body))]
       [(if^ test then else)
	(make-if (expand-to-core test)
		 (expand-to-core then)
		 (expand-to-core else))]
       [(let^ decls body)
	(let ((vars (map decls->var decls))
	      (exps (map decls->exp decls)))
	  (let ((exps (map expand-to-core exps)))
	    (make-app
	     (make-lambda vars (expand-to-core body))
	     exps)))]
       [(begin^ exp statements) (if (null? (cdr statements))
				    (make-begin (expand-to-core exp) (expand-to-core (car statements)))
				    (make-begin
				     (expand-to-core exp)
				     (expand-to-core (make-begin^ (car statements) (cdr statements)))))]
       [(varassign^ vari expr) (make-varassign vari (expand-to-core expr))])))


(define expand-to-full
  (lambda (exp)
    (cond
     [(number? exp) (make-num^ exp)]
     [(symbol? exp) (make-varref^ exp)]
     [(not (pair? exp)) (error 'expand-to-full "illegal expression ~s" exp)]
     [(eq? (car exp) 'lambda)
      (make-lambda^ (cadr exp) (expand-to-full (caddr exp)))]
     [(eq? (car exp) 'if)
      (make-if^ (expand-to-full (cadr exp))
		(expand-to-full (caddr exp))
		(expand-to-full (cadddr exp)))]
     [(eq? (car exp) 'let)
      (let ((vars (map car (cadr exp)))
	    (exps (map cadr (cadr exp))))
	(let ((exps (map expand-to-full exps)))
	  (make-let^ (map make-decl vars exps)
		     (expand-to-full (caddr exp)))))]
     [(eq? (car exp) 'begin)
      (if (null? (cddr exp))
	  (expand-to-full (cadr exp))
	  (make-begin^ (expand-to-full (cadr exp))
		       (map expand-to-full (cddr exp))))]
     [(eq? (car exp) 'set!) (make-varassign^ (cadr exp)
					     (expand-to-full (caddr exp)))]
     [else (make-app^ (expand-to-full (car exp))
		     (map expand-to-full (cdr exp)))])))

;;============================================================================


(define apply-env
  (lambda (env var)
    (type-case env-type env
       [(empty-env) (error 'eval-exp "Unbound variable: ~s" var)]
       [(extend-env var-list val-vector old-env)
	(let ((val (ribassoc var var-list val-vector 'fail)))
	  (if (eq? val 'fail)
	      (apply-env old-env var)
	      val))])))


(define less
  (lambda (x y)
    (if (< x y) 1 0)))

(define greater
  (lambda (x y)
    (if (> x y) 1 0)))

(define null
  (lambda (x)
    (if (null? x) 1 0)))

(define equal
  (lambda (x y)
    (if (= x y) 1 0)))

(define zero
  (lambda (z)
    (if (zero? z) 1 0)))

(define true-test?
  (lambda (exp)
    (cond
     [(eq? exp #t) #t]
     [(eq? exp 1) #t]
     [else
      #f])))



(define prim-op-names '(+ - * car cdr cons list add1 sub1 less greater equal null zero))


(define apply-proc
  (lambda (proc args)
    (type-case primitives proc
       [(primitive proc) (apply proc args)]
       [(closure formals body env)
	(eval-exp body (extend-env formals args env))])))

    
(define init-env
  (extend-env
   prim-op-names
   (map make-primitive (map eval prim-op-names))
   (extend-env
    '(emptylist)
    '(())
    (create-empty-env))))


(define eval-exp
  (lambda (exp env)
    (type-case core-exp exp
	 [(num val) val]
	 [(varref var) (apply-env env var)]
	 [(app operator operands)
	  (let ((proc (eval-exp operator env))
		(args (eval-rands operands env)))
	    (apply-proc proc args))]
	 [(lambda formals body) (make-closure formals body env)]
	 [(begin exp1 exp2) (begin
			      (eval-exp exp1 env)
			      (eval-exp exp2 env))]
	 [(varassign vari expr) (set-bang-helper vari (eval-exp expr env) env)]
	 [(if test then else)
	  (if (true-test? (eval-exp test env))
	      (eval-exp then env)
	      (eval-exp else env))]
	 [else
	  (error 'eval-exp "Invalid ADT syntax")])))


(define eval-rands
  (lambda (rands env)
    (map (lambda (rand) (eval-exp rand env)) rands)))


(define set-bang-helper
  (lambda (variable express environment)
    (type-case env-type environment
       [(empty-env) (error 'set-bang-helper "EMPTY env")]
       [(extend-env var-list val-vector old-env)
	(if (mem? variable var-list)
	    (vector-set! val-vector (get-index variable var-list)
			 express)
	    (set-bang-helper variable express old-env))])))

(define mem?
  (lambda (a ls)
    (cond
     ((null? ls) #f)
     ((eq? a (car ls)) #t)
     (else (mem? a (cdr ls))))))


(define eval-form
  (lambda (ef)
    (type-case form ef
       [(define var exp) (define-helper var exp init-env)]
       [(expression exp) (eval-exp exp init-env)])))

(define define-helper
  (lambda (sym exp env)
    (type-case env-type env
      [(empty-env)
       (begin
	 (set! init-env
	       (extend-env (list sym)
			   (list '*) init-env))
	 (define-helper sym exp init-env))]
      [(extend-env var-list val-vector old-env)
       (if (mem? sym var-list)
	   (set-bang-helper sym (eval-exp exp env) env)
	   (define-helper sym exp old-env))])))