From 3fdd1ae746f5eeb2eafa89a8e946959e9fa64b8e Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Mon, 9 Jul 2012 12:18:08 -0400
Subject: [PATCH] Event relaying plus an example program

---
 os2-event-relay.rkt    | 28 ++++++++++++++++++++++++++
 os2-nested-example.rkt | 45 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 73 insertions(+)
 create mode 100644 os2-event-relay.rkt
 create mode 100644 os2-nested-example.rkt

diff --git a/os2-event-relay.rkt b/os2-event-relay.rkt
new file mode 100644
index 0000000..3a42c1e
--- /dev/null
+++ b/os2-event-relay.rkt
@@ -0,0 +1,28 @@
+#lang racket/base
+;; Ground-event relay for os2.
+
+(provide event-relay)
+(require "os2.rkt")
+
+(define event-relay
+  (transition 'no-state
+   (role 'relay-down (topic-publisher (cons (wild) (wild)) #:monitor? #t)
+     #:state state
+     #:topic t
+     #:on-presence (match t
+		     [(topic 'subscriber (cons (? evt? e) _) #f)
+		      (printf "SUBSCRIBED ~v~n" e) (flush-output)
+		      (transition state
+			(at-meta-level
+			 (role t (topic-subscriber (cons e (wild)))
+			   #:state state
+			   [msg
+			    (printf "FIRED ~v -> ~v~n" e msg) (flush-output)
+			    (transition state
+			      (send-message msg))])))]
+		     [_ state])
+     #:on-absence (match t
+		    [(topic 'subscriber (cons (? evt?) e) #f)
+		     (printf "UNSUBSCRIBED ~v~n" e) (flush-output)
+		     (transition state
+		       (at-meta-level (delete-role t)))]))))
diff --git a/os2-nested-example.rkt b/os2-nested-example.rkt
new file mode 100644
index 0000000..431b7c5
--- /dev/null
+++ b/os2-nested-example.rkt
@@ -0,0 +1,45 @@
+#lang racket/base
+;; Trivial demonstration of nested os2.rkt virtual machines.
+
+(require "os2.rkt")
+(require "os2-event-relay.rkt")
+
+(define (spy spy-label)
+  (lambda (spy-pid)
+    (define (hs label)
+      (define ((w kind) . args) (write `(,spy-label ,label ,kind ,@args)) (newline) values)
+      (handlers (w 'presence)
+		(w 'absence)
+		(w 'message)))
+    (transition 'spy-state
+      (add-role 's->p (topic-publisher (wild) #:monitor? 'everything)
+		(hs 'subscriber->publisher))
+      (add-role 'p->s (topic-subscriber (wild) #:monitor? 'everything)
+		(hs 'publisher->subscriber)))))
+
+(define (eventing-process label)
+  (spawn (lambda (self-pid)
+	   (transition 'no-state
+	     (role 'waiter (topic-subscriber (cons always-evt (wild)))
+	       #:state state
+	       [msg
+		(write `(event ,label ,msg)) (newline) (flush-output)
+		(transition state
+		  (delete-role 'waiter))])))
+	 #:debug-name (debug-name label)))
+
+(ground-vm (lambda (boot-pid)
+	     (define event-at-ground? #f)
+	     (define install-relay? #t)
+	     (transition 'no-state
+	       (spawn (spy 'ground-spy))
+	       (when event-at-ground? (eventing-process 'ground-level-eventing-process))
+	       (spawn (nested-vm (debug-name 'nested-vm)
+				 (lambda (boot-pid)
+				   (transition 'no-state
+				     (spawn (spy 'nested-spy))
+				     (when install-relay? (spawn event-relay
+								 #:debug-name 'event-relay))
+				     (when (not event-at-ground?)
+				       (eventing-process 'nested-eventing-process)))))
+		      #:debug-name (debug-name 'nested-vm)))))