;;;; Modular interpreter, style 2

;;; Liftings

(define ((lift-p1-e0 unit bind op) p1)
  (unit (op p1)))

(define ((lift-p0-e1 unit bind op) e1)
  (bind e1
    (lambda (v1)
      (unit (op v1)))))

(define ((lift-p0-e2 unit bind op) e1 e2)
  (bind e1
    (lambda (v1)
      (bind e2
        (lambda (v2)
          (unit (op v1 v2)))))))

(define ((lift-p1-e1 unit bind op) p1 e1)
  (bind e1
    (lambda (v1)
      (unit (op p1 v1)))))

(define ((lift-if unit bind op) e1 e2 e3)
  (bind e1
    (lambda (v1)
      (op v1 e2 e3))))

;---------------

;;; V = Val

(define runV id)

(define %constV id)
(define %+V +)
(define %*V *)

(define (%ifV e1 e2 e3)
  (if e1 e2 e3))

;---------------

;;; S = Sto -> V * Sto

(define (unitS v)
  (lambda (sto)
    (pair v sto)))

(define (bindS s f)
  (lambda (sto)
    (let ((v*sto (s sto)))
      (let ((v (left v*sto))
            (sto (right v*sto)))
        ((f v) sto)))))

(define (runS exp)
  (runV (left (exp (empty-store)))))

(define %constS (lift-p1-e0 unitS bindS %constV))
(define %+S     (lift-p0-e2 unitS bindS %+V))
(define %*S     (lift-p0-e2 unitS bindS %*V))

(define %ifS (lift-if unitS bindS %ifV))

(define ((%fetchS loc) sto)
  (pair (store-fetch loc sto) sto))

(define ((%storeS loc exp) sto)
  (let ((v*s (exp sto)))
    (let ((v (left v*s))
          (s (right v*s)))
      (pair (%constV 'unit)
            (store-store loc v s)))))

(define ((%beginS e1 e2) sto)
  (e2 (right (e1 sto))))

;---------------

;;; E    = Env -> S
;;; Proc = V -> S

(define (unitE s)
  (lambda (env) s))

(define (bindE e f)
  (lambda (env)
    ((f (e env)) env)))

(define (run exp)
  (runS (exp (empty-env))))

(define %const (lift-p1-e0 unitE bindE %constS))

(define %+ (lift-p0-e2 unitE bindE %+S))
(define %* (lift-p0-e2 unitE bindE %*S))

(define %if (lift-if unitE bindE %ifS))

(define %fetch (lift-p1-e0 unitE bindE %fetchS))
(define %store (lift-p1-e1 unitE bindE %storeS))
(define %begin (lift-p0-e2 unitE bindE %beginS))

(define ((%var name) env)
  (unitS (env-lookup name env)))

(define ((%lambda name exp) env)
  (unitS
   (lambda (val)
     (exp (env-extend name val env)))))

(define ((%call e1 e2) env)
  (bindS (e1 env)
    (lambda (v1)
      (bindS (e2 env)
        (lambda (v2)
          (v1 v2))))))

;-----------------

;;; Utilities

(define pair cons)
(define left car)
(define right cdr)

(define id identity-procedure)

(define (empty-env) '())

(define (env-lookup name env)
  (right (assq name env)))

(define (env-extend name val env)
  (pair (pair name val) env))

(define (empty-store) '())

(define (store-fetch loc sto)
  (right (assq loc sto)))

(define (store-store loc val sto)
  (pair (pair loc val) sto))