;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(planet plai/plai:1:6/lang/reader)

(define-type BCFAE
  [num (n number?)]
  [add (lhs BCFAE?) (rhs BCFAE?)]
  [id (name symbol?)]
  [fun (param symbol?) (body BCFAE?)]
  [with (param symbol?) (named-expr BCFAE?) (body BCFAE?)]
  [app (fun-expr BCFAE?) (arg-expr BCFAE?)]
  [if0 (cond BCFAE?) (then BCFAE?) (else BCFAE?)]
  [newbox (content BCFAE?)]
  [setbox (bx BCFAE?) (ctnt BCFAE?)]
  [openbox (bx BCFAE?)]
  [seqn (fst BCFAE?) (snd BCFAE?)])

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

(define-type Env
  [emptyEnv]
  [anEnv (name symbol?) (location number?) (rest Env?)])

(define (env-lookup name env)
  (type-case Env env
             [emptyEnv () (error 'lookup "name not found")]
             [anEnv (n value rest)
                    (if (symbol=? n name)
                        value
                        (env-lookup name rest))]))

(define-type Store
  [emptyStore]
  [aStore (location number?)
          (value BCFAE-Value?)
          (store Store?)])

(define (store-lookup loc sto)
  (type-case Store sto
             [emptyStore () (error 'store-lookup "no value at location")]
             [aStore (location value rest-store)
                     (if (= location loc)
                         value
                         (store-lookup loc rest-store))]))


; M s a = s -> Value*Store (a,s)
(define-type Value*Store
  [v*s (value any/c) (store any/c)])

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

; bind: M a -> (a -> M b) -> M b
(define (bind f g)
  (lambda (s)
    (type-case Value*Store (f s)
      [v*s (v s2) ((g v) s2)])))

; return : a -> M a
(define (return x) (lambda (s)  (v*s x s)))

; get : M s
(define (get s)
  (v*s s s))

; put : s -> M ()

(define (put s)
  (lambda (_) (v*s empty s)))

(define-syntax do
  (syntax-rules (<-)
    ((do expr              ) expr)
    ((do (v <- expr) . rest) (bind expr (lambda (v) (do . rest))))
    ((do expr        . rest) (bind expr (lambda (v) (do . rest)))))) 


(define (interp expr env)
  (type-case BCFAE expr
             [num (n) (return (numV n))]
             [add (l r) 
               (do
                  (lv <- (interp l env))
                  (rv <- (interp r env))
                  (return (numV (+ (numV-n lv) (numV-n rv)))))]
;            [id (v) (lambda (store) (v*s (store-lookup (env-lookup v env) store) store))]
             [id (v) 
                 (do
                     (store <- get)
                     (return (store-lookup (env-lookup v env) store)))]
             [fun (bound-id bound-body) (return (closureV bound-id bound-body env))]
             [with (param named-expr body)
                   (interp (app (fun param body) named-expr) env)]
             [app (the-fun the-arg)
               (do
                   (fun-value <- (interp the-fun env))
                   (fun-arg   <- (interp the-arg env))
                   (s         <- get)
                   (new-loc   <- next-location)                 
                   (put (aStore new-loc fun-arg s))
                   (interp (closureV-body fun-value)
                           (anEnv (closureV-param fun-value)
                                  new-loc
                                  (closureV-env fun-value))))]
             [if0 (test then else)
                  (do
                      (t <- (interp test env))
                      (if (zero? (numV-n t))
                           (interp then env)
                           (interp else env)))]
             [newbox (value-expr)
                     (do 
                         (expr-value <- (interp value-expr env))
                         (new-loc    <- next-location)
                         (expr-store <- get)
                         (put (aStore new-loc expr-value expr-store))
                         (return (boxV new-loc)))]
             [setbox (box-expr value-expr)
                  (do
                      (box-value <- (interp box-expr env))
                      (value-value <- (interp value-expr env))
                      (value-store <- get)
                      (put (aStore (boxV-location box-value) value-value value-store))
                      (return value-value))]
             [openbox (box-expr)
                  (do
                      (box-value <- (interp box-expr env))
                      (box-store <- get)
                      (return (store-lookup (boxV-location box-value) box-store)))]
             [seqn (e1 e2)
                   (do
                       (interp e1 env)
                       (interp e2 env)
                       )]))

(define (run p)
  ((interp p (emptyEnv)) (emptyStore)))
; Tests

(define test1
  (with 'switch (newbox (num 0))
        (with 'toggle (fun 'dum
                           (if0 (openbox (id 'switch))
                                (seqn 
                                 (setbox (id 'switch) (num 1))
                                 (num 1))
                                (seqn
                                 (setbox (id 'switch) (num 0))
                                 (num 0))))
              (add
               (app (id 'toggle) (num 1729))
               (app (id 'toggle) (num 1729))))))

(run test1)