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

; The grammar of object programs

(define-struct love (subj obj) #:transparent)
(define-struct alice () #:transparent)
(define-struct bob () #:transparent)
(define-struct everyone () #:transparent)
(define-struct someone () #:transparent)

(define test-expr (make-love (make-everyone) (make-someone)))

; Evaluator (denotational semantics)

(define eval-big
  (lambda (e c)
    (match e
      ((struct love (subj obj))
       (eval-big subj (lambda (s) (eval-big obj (lambda (o) (c (eq? s o)))))))
      ((struct alice ())
       (c 'coltrane))
      ((struct bob ())
       (c 'dylan))
      ((struct everyone ())
       (and (c 'coltrane) (c 'dylan)))
      ((struct someone ())
       (or (c 'coltrane) (c 'dylan))))))

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

(trace eval-big)

; Step function (operational semantics)

(define-struct done () #:transparent)
(define-struct love1 (c obj) #:transparent)
(define-struct love2 (s c) #:transparent)

(define-struct finish () #:transparent)
(define-struct and-dylan (c d) #:transparent)
(define-struct or-dylan (c 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 love (subj obj)) c d))
       (make-eval subj (make-love1 c obj) d))
      ((struct eval ((struct alice ()) c d))
       (make-apply c 'coltrane d))
      ((struct eval ((struct bob ()) c d))
       (make-apply c 'dylan d))
      ((struct eval ((struct everyone ()) c d))
       (make-apply c 'coltrane (make-and-dylan c d)))
      ((struct eval ((struct someone ()) c d))
       (make-apply c 'coltrane (make-or-dylan c d)))
      ((struct apply ((struct done ()) n d))
       (make-return d n))
      ((struct apply ((struct love1 (c obj)) n d))
       (make-eval obj (make-love2 n c) d))
      ((struct apply ((struct love2 (s c)) n d))
       (make-apply c (eq? s n) d))
      ((struct return ((struct finish ()) n))
       n)
      ((struct return ((struct and-dylan (c d)) n))
       (match n (#f (make-return d #f))
                (#t (make-apply c 'dylan d))))
      ((struct return ((struct or-dylan (c d)) n))
       (match n (#t (make-return d #t))
                (#f (make-apply c 'dylan d))))
      (_
       'stop))))

(define steps
  (lambda (s0)
    (match (step s0)
      ('stop 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 shift))

(define eval-meta
  (lambda (e)
    (match e
      ((struct love (subj obj))
       (eq? (eval-meta subj) (eval-meta obj)))
      ((struct alice ())
       'coltrane)
      ((struct bob ())
       'dylan)
      ((struct everyone ())
       (shift c (and (c 'coltrane) (c 'dylan))))
      ((struct someone ())
       (shift c (or (c 'coltrane) (c 'dylan)))))))

; Try: (eval-meta test-expr)

(trace eval-meta)