#lang plai
(define-type BCFAE
  [num (n number?)] 
  [add (lhs BCFAE?)(rhs BCFAE?)] 
  [id (name symbol?)] 
  [fun (param symbol?)(body BCFAE?)] 
  [app (fun-expr BCFAE?)(arg-expr BCFAE?)]
  [if0 (test BCFAE?)(true BCFAE?)(false BCFAE?)]
  [newbox (value-expr BCFAE?)]
  [setbox (box-expr BCFAE?)(value-expr BCFAE?)]
  [openbox (box-expr BCFAE?)]
  [seqn (e1 BCFAE?)(e2 BCFAE?)])

;; parse: sexp -> BCFAE
(define (parse sexp)
  (cond
    ((number? sexp)(num sexp))
    ((symbol? sexp)(id sexp))
    ((list? sexp)
     (case (first sexp)
       ((+)(add (parse (second sexp))
                (parse (third sexp))))
       ((fun)(fun (caadr sexp)
                  (parse (third sexp))))
       ((with)(app (fun (caadr sexp)
                        (parse (third sexp)))
                   (parse (cadadr sexp))))
       ((if0)(if0 (parse (second sexp))
                 (parse (third sexp))
                 (parse (fourth sexp))))
       ((newbox)(newbox (parse (second sexp))))
       ((setbox)(setbox (parse (second sexp))
                        (parse (third sexp))))
       ((openbox)(openbox (parse (second sexp))))
       ((seqn)(seqn (parse (second sexp))
                    (parse (third sexp))))
       (else (app (parse(first sexp)) (parse (second sexp))))
      ))
   ))

(define-type BCFAE-Value 
  [numV (n number?)] 
  [closureV (param symbol?) 
            (body BCFAE?) 
            (env Env?)] 
  [boxV (location number?)]) 

(define-type Env 
  [mtSub] 
  [aSub (name symbol?) 
        (location number?) 
        (env Env?)]) 

(define-type Store 
  [mtSto] 
  [aSto (location number?) 
        (value BCFAE-Value?) 
        (store Store?)]) 


;; env-lookup:symbol Env -> location 

(define (env-lookup name env) 
  (type-case Env env 
             [mtSub ()(error 'env-lookup 
                             "no binding for identifier")] 
             [aSub (bound-name bound-location rest-env) 
                   (if (symbol=? bound-name name) 
                       bound-location 
                       (env-lookup name rest-env))])) 


;; store-lookup:location Store -> BCFAE-Value 
(define (store-lookup loc-index sto) 
  (type-case Store sto 
             [mtSto ()(error 'store-lookup 
                             "no value at location")] 
             [aSto (location value rest-store) 
                   (if (= location loc-index) 
                       value 
                       (store-lookup loc-index rest-store))])) 


(define-type Value*Store 
  [v*s (value BCFAE-Value?)(store Store?)]) 

(define next-location 
  (local ([define last-loc (box -1)]) 
    (lambda (store) 
      (begin 
        (set-box! last-loc (+ 1 
                              (unbox last-loc))) 
        (unbox last-loc))))) 

;; num+: numV numV -> numV 
(define (num+ n1 n2) 
  (numV (+(numV-n n1)(numV-n n2)))) 

(define (num-zero? n) 
  (zero? (numV-n n))) 

;; interp: BCFAE Env Store -> Value×Store 
(define (interp expr env store) 
  (type-case BCFAE expr 
     [num (n)(v*s (numV n)store)] 
     [add (l r) 
        (type-case Value*Store (interp l env store) 
           [v*s (l-value l-store) 
             (type-case Value*Store (interp r env l-store) 
                [v*s (r-value r-store) 
                   (v*s (num+ l-value r-value) r-store)])])] 
     [id (v)(v*s (store-lookup (env-lookup v env)store)store)] 
     [fun (bound-id bound-body) 
        (v*s (closureV bound-id bound-body env)store)] 
     [app (fun-expr arg-expr) 
        (type-case Value*Store (interp fun-expr env store) 
           [v*s (fun-value fun-store) 
             (type-case Value*Store (interp arg-expr env fun-store) 
                [v*s (arg-value arg-store) 
                   (local ([define new-loc (next-location arg-store)]) 
                      (interp (closureV-body fun-value) 
                         (aSub (closureV-param fun-value) 
                               new-loc 
                               (closureV-env fun-value)) 

                         (aSto new-loc 
                               arg-value 
                               arg-store)))])])] 
     [if0 (test truth falsity) 
        (type-case Value*Store (interp test env store) 
           [v*s (test-value test-store) 
             (if (num-zero? test-value) 
                 (interp truth env test-store) 
                 (interp falsity env test-store))])] 
     [newbox (value-expr) 
       (type-case Value*Store (interp value-expr env store) 
          [v*s (expr-value expr-store) 
            (local ([define new-loc (next-location expr-store)]) 
              (v*s (boxV new-loc) 
                   (aSto new-loc expr-value expr-store)))])] 
     [setbox (box-expr value-expr) 
       (type-case Value*Store (interp box-expr env store) 
          [v*s (box-value box-store) 
             (type-case Value*Store (interp value-expr env box-store) 
                [v*s (value-value value-store) 
                   (v*s value-value 
                        (aSto (boxV-location box-value) 
                              value-value 
                              value-store))])])] 

     [openbox (box-expr) 
        (type-case Value*Store (interp box-expr env store) 
            [v*s (box-value box-store) 
               (begin (print env)
                      (newline)
               (v*s (store-lookup (boxV-location box-value) box-store) 
                    box-store)
                            )
                               ])] 
     [seqn (e1 e2) 
        (type-case Value*Store (interp e1 env store) 
            [v*s (e1-value e1-store) 
               (interp e2 env e1-store)])]))

;; sample expression
(interp (parse '{with {b {newbox 0}}
                        {seqn {setbox b 5}
                              {openbox b}}}) 
        (mtSub) 
        (mtSto))