#lang scheme
(require (only-in mzlib/trace trace))

; The grammar of object programs

(define-struct lit (num) #:transparent)
(define-struct sub (e1 e2) #:transparent)
(define-struct catch (e1) #:transparent)
(define-struct both (n1 n2) #:transparent)

(define test-expr
  (make-sub (make-catch (make-sub (make-both 4 3) (make-lit 1)))
            (make-lit 2)))

; Evaluator (denotational semantics)

(define eval-big
  (lambda (e c)
    (match e
      ((struct lit (n))
       (c n))
      ((struct sub (e1 e2))
       (eval-big e1 (lambda (n1) (eval-big e2 (lambda (n2) (c (- n1 n2)))))))
      ((struct catch (e1))
       (c (eval-big e1 (lambda (n) n))))
      ((struct both (n1 n2))
       (* (c n1) (c n2))))))

; Try: (eval-big test-expr (lambda (n) n))

(trace eval-big)

; Step function (operational semantics)

(define-struct done () #:transparent)
(define-struct sub1 (c e2) #:transparent)
(define-struct sub2 (n1 c) #:transparent)

(define-struct finish () #:transparent)
(define-struct caught (c d) #:transparent)
(define-struct both1 (d c n2) #:transparent)
(define-struct both2 (n1 d) #:transparent)

(define-struct eval (e c d) #:transparent)
(define-struct apply (c n d) #:transparent)
(define-struct return (d n) #:transparent)

(define step
  (lambda (s)
    (match s
      ((struct eval ((struct lit (n)) c d))
       (make-apply c n d))
      ((struct eval ((struct sub (e1 e2)) c d))
       (make-eval e1 (make-sub1 c e2) d))
      ((struct eval ((struct catch (e1)) c d))
       (make-eval e1 (make-done) (make-caught c d)))
      ((struct eval ((struct both (n1 n2)) c d))
       (make-apply c n1 (make-both1 d c n2)))
      ((struct apply ((struct done ()) n d))
       (make-return d n))
      ((struct apply ((struct sub1 (c e2)) n d))
       (make-eval e2 (make-sub2 n c) d))
      ((struct apply ((struct sub2 (n1 c)) n d))
       (make-apply c (- n1 n) d))
      ((struct return ((struct finish ()) n))
       n)
      ((struct return ((struct caught (c d)) n))
       (make-apply c n d))
      ((struct return ((struct both1 (d c n2)) n))
       (make-apply c n2 (make-both2 n d)))
      ((struct return ((struct both2 (n1 d)) n))
       (make-return d (* n1 n)))
      (_
       #f))))

(define steps
  (lambda (s0)
    (match (step s0)
      (#f s0)
      (s (steps s)))))

(define eval-small
  (lambda (e)
    (steps (make-eval e (make-done) (make-finish)))))

; Try: (eval-small test-expr)

(trace steps)

; Evaluator using metalanguage control

(require (only-in scheme/control reset shift))

(define eval-meta
  (lambda (e)
    (match e
      ((struct lit (n))
       n)
      ((struct sub (e1 e2))
       (- (eval-meta e1) (eval-meta e2)))
      ((struct catch (e1))
       (reset (eval-meta e1)))
      ((struct both (n1 n2))
       (shift c (* (c n1) (c n2)))))))

; Try: (eval-meta test-expr)

(trace eval-meta)