;;; Resumption semantics

;;; Utilities

(define id identity-procedure)

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

(define (in-left x) (cons 'left x))
(define (in-right x) (cons 'right x))

(define (sum-case x f g)
  (case (car x)
    ((left) (f (cdr x)))
    ((right) (g (cdr x)))
    (else
     (error "Bad case: " x))))

(define (make-empty-store) '())

(define (update var val s)
  (cons (cons var val) s))

(define (lookup var s)
  (let ((entry (assq var s)))
    (if entry
	(cdr entry)
	(error "Unassigned variable: " var))))


;;; Commands

;; Cmd = rec(X) Sto -> List((Val + X) * Sto)
;; Ans = List Val

(define ((%value exp) s)
  (list (pair (in-left (exp s)) s)))

(define ((step f) s)			; (Sto -> Sto) -> Cmd
  (list (pair (in-left 'unit) (f s))))

(define ((%pause c) s)
  (list (pair (in-right c) s)))

(define ((%seq2 c1 c2) s)
  (append-map
   (lambda (p*s)
     (let ((p (left p*s))
	   (s (right p*s)))
       (sum-case p
	 (lambda (v)
	   ((%pause c2) s))
	 (lambda (c)
	   ((%pause (%seq2 c c2)) s)))))
   (c1 s)))

(define ((%par2 c1 c2) s)
  (append ((%then c1 c2) s) 
	  ((%then c2 c1) s)))

(define ((%then c1 c2) s)
  (append-map
   (lambda (p*s)
     (let ((p (left p*s))
	   (s (right p*s)))
       (sum-case p
	 (lambda (v) ((%pause c2) s))
	 (lambda (c) ((%pause (%par2 c c2)) s)))))
   (c1 s)))

(define (compute c)
  (let loop ((c c) (s (make-empty-store)))
    (append-map
     (lambda (p*s)
       (let ((p (left p*s))
	     (s (right p*s)))
	 (sum-case p
	   list
	   (lambda (c) (loop c s)))))
     (c s))))

(define (%assign var exp)
  (step (lambda (s) (update var (exp s) s))))

(define (%seq . cmds)
  (reduce %seq2 id cmds))

(define (%par . cmds)
  (reduce %par2 id cmds))

(define ((%if exp c1 c2) s)
  (if (exp s)
      ((%pause c1) s)
      ((%pause c2) s)))

(define (%skip) (step id))

(define (%while exp cmd)
  (define (loop s)
    (if (exp s)
	((%pause (%seq2 cmd loop)) s)
	((%skip) s)))
  loop)


;;; Expressions

(define ((%var name) s)
  (lookup name s))

(define ((%const n) s)
  n)

(define ((%prim f . args) s)
  (apply f (map (lambda (arg) (arg s)) args)))