(include "match.ss")


(define debug-env '())
(define tag
  (lambda (val tag)
    (cons tag val)))

(define remove-tag
  (lambda (tagged-val)
    (cdr tagged-val)))

(define get-tag
  (lambda (tagged-val)
    (car tagged-val)))

(define cp equal?)

(define true (tag 0 'boolean))
(define false (tag 1 'boolean))
(define empty-list 'null)
(define void 'void)

(define heap-size 16384)
(define heap (make-vector heap-size 0))
(define global-env empty-list)
(define ap 0)

(define heap-init
  (lambda ()
    (let loop ([i 0])
      (when (< i heap-size)
        (mem-write i 0)
        (loop (add1 i))))))

(define alloc
    (lambda ()
      (let ([ans ap])
        (set! ap (+ ap 2))
        ans)))

(define mem-write
  (lambda (addr value)
    (vector-set! heap addr value)))

(define mem-read
  (lambda (addr)
    (vector-ref heap addr)))

(define eval-start
  (lambda (expr)
    (heap-init)
    (eval expr empty-env 0 #t)))




(define eval
  (lambda (expr env frame tail?)

    (define nontail
      (lambda (expr)
        (eval expr env 0 #f)))
    
    (define eval-nontail
      (lambda (expr env)
        (eval expr env 0 #f)))
    
    (match expr
      [,n (guard (number? n))
       (tag n 'fixnum)]
      [#t true]
      [#f false]
       
      [,x (guard (symbol? x))
       (let ([value (apply-env (symbol-make x) env)])
         (if value (unstore value) (error 'eval "variable ~s not found" x)))]
      
      [(quote ,expr)
       (cond
         [(pair? expr)
          (let quote-long-list ([ls expr])
            (cond
              [(null? ls) empty-list]
              [(atom? ls) (nontail `(quote ,ls))]
              [else (list-cons 
                      (nontail `(quote ,(car ls)))
                      (quote-long-list (cdr ls)))]))]
         [(or (number? expr) (boolean? expr))
          (nontail expr)]
         [(null? expr) empty-list]
         [else (symbol-make expr)])]
      
      [(set! ,[symbol-make -> var] ,[nontail -> value])
       (mem-write (apply-env var env) value)]
      
      [(begin ,[nontail -> expr*] ... ,expr)
       (eval expr env frame tail?)]
      
      [(let ((,[symbol-make -> lhs*] ,[nontail -> rhs*]) ...) ,body ...)
       (let loop ([env env]
                  [frame frame]
                  [lhs* lhs*]
                  [rhs* rhs*])
         (if (null? lhs*)
             (eval `(begin . ,body) env frame tail?)
             (loop 
               (extend-env 
                 (car lhs*) 
                 (store (car rhs*))
                 env)
               (add1 frame)
               (cdr lhs*)
               (cdr rhs*))))]
             
      [(letrec ((,[symbol-make -> lhs*] ,[nontail -> rhs*]) ...) ,body ...)
       (let loop ([env env]
                  [frame frame]
                  [lhs lhs*]
                  [rhs rhs*])
         (if (not (null? lhs))
             (loop 
               (extend-env 
                 (car lhs) 
                 (store (car rhs))
                 env)
               (add1 frame)
               (cdr lhs)
               (cdr rhs))
             (let env-update ([rhs rhs*])
               (if (not (null? rhs))
                   (begin
                     (if (eq? (get-tag (car rhs)) 'closure)
                         (mem-write 
                           (remove-tag (list-cdr (car rhs)))
                           env))
                     (env-update (cdr rhs)))
                   (eval `(begin . ,body) env frame tail?)))))]
      
      [(if ,test ,conseq ,altern)
       (let ([test (eval-nontail test env)])
         (if (cp test true)
             (eval-nontail conseq env)
             (eval-nontail altern env)))]
      
      [(lambda ,formals ,body)
       (let ([formals (nontail `(quote ,formals))])
         (tag
           (remove-tag (list-cons body (list-cons env formals)))
           'closure))]
      [(cons ,[nontail -> expr1] ,[nontail -> expr2])
         (list-cons expr1 expr2)]
      [(car ,[nontail -> expr])
         (list-car expr)]
      [(cdr ,[nontail -> expr])
       (list-cdr expr)]
      [(list ,[nontail -> expr*] ...)
       (let list-loop ([ls expr*])
         (cond
           [(null? ls) empty-list]
           [else (list-cons (car ls) (list-loop (cdr ls)))]))]
      [(+ ,[nontail -> expr1] ,[nontail -> expr2])
       (tag (+ (remove-tag expr1) (remove-tag expr2)) 'fixnum)]
      [(- ,[nontail -> expr1] ,[nontail -> expr2])
       (tag (- (remove-tag expr1) (remove-tag expr2)) 'fixnum)]
      [(* ,[nontail -> expr1] ,[nontail -> expr2])
       (tag (* (remove-tag expr1) (remove-tag expr2)) 'fixnum)]
      [(/ ,[nontail -> expr1] ,[nontail -> expr2])
       (tag (/ (remove-tag expr1) (remove-tag expr2)) 'fixnum)] 
      [(= ,[nontail -> expr1] ,[nontail -> expr2])
       (if (= (remove-tag expr1) (remove-tag expr2))
           true
           false)]
      [(,[nontail -> rator] ,rand* ...)
       (let ([arglist (nontail `(list . ,rand*))]
             [env (if tail?
                      (let frame-remove ([env env]
                                         [n frame])
                        (cond
                          [(zero? n) env]
                          [else (frame-remove (list-cdr env) (sub1 n))]))
                      env)])
         (apply-closure rator arglist))]
                        
                        
         
      [,expr (error 'eval "invalid expression: ~s" expr)])))
        

(define apply-closure
  (lambda (closure values)
    (let closure-env-loop ([env (list-car (list-cdr closure))]
                           [names (list-cdr (list-cdr closure))]
                           [values values]
                           [frame 0])
        (cond
          [(list-null? names) 
           (eval `(begin ,(list-car closure)) env frame #t)]
          [(not (eq? (get-tag names) 'pair))
           (closure-env-loop
             (extend-env (list-car names) (store values) env)
             '()
             '()
             (add1 frame))]
          [else
            (closure-env-loop
              (extend-env (list-car names) (store (list-car values)) env)
              (list-cdr names)
              (list-cdr values)
              (add1 frame))]))))
          
          
        


(define empty-env empty-list)

(define store
  (lambda (x)
    (let ([store (alloc)])
      (mem-write store x)
      store)))

(define unstore
  (lambda (store)
    (mem-read store)))

(define list-cons
  (lambda (a b)
    (let ([pair (alloc)])
      (mem-write pair a)
      (mem-write (add1 pair) b)
      (tag pair 'pair))))

(define list-car
  (lambda (ls)
    (mem-read (remove-tag ls))))

(define list-cdr
  (lambda (ls)
    (mem-read (add1 (remove-tag ls)))))
              
(define list-null?
  (lambda (ls)
    (cp ls empty-list)))

(define extend-env
  (lambda (name val env)
    (set! debug-env (cons (cons name val) debug-env))
    (list-cons (list-cons name val) env)))

(define apply-env
  (lambda (name env)
    (if (cp env empty-list)
        #f
          (if (cp name (list-car (list-car env)))
              (list-cdr (list-car env))
              (apply-env name (list-cdr env))))))
            

(define pretty-print
  (lambda (expr)
    (let loop ([e expr])
      (if (= e empty-list)
          '()
          (cons (get-car e) (loop (get-cdr e)))))))

(define symbol-make
  (lambda (sym)
    (tag sym 'symbol)))