From 0a5906e116a81fde6af0f104f68d666ca7de2e0b Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Mon, 23 Jul 2012 12:12:14 -0400
Subject: [PATCH] Exactly the code from the paper

---
 chat-os2-paper.rkt | 59 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 59 insertions(+)
 create mode 100644 chat-os2-paper.rkt

diff --git a/chat-os2-paper.rkt b/chat-os2-paper.rkt
new file mode 100644
index 0000000..5e7fdf1
--- /dev/null
+++ b/chat-os2-paper.rkt
@@ -0,0 +1,59 @@
+#lang racket/base
+
+(require racket/list)
+(require racket/port)
+(require racket/match)
+(require "os2.rkt")
+(require "fake-tcp.rkt")
+
+(define (term->bytes v)
+  (with-output-to-bytes (lambda () (write v) (newline))))
+
+;;---------------------------------------------------------------------------
+
+(define listener-proc
+ (transition 'no-state
+  (at-meta-level
+   (role/anon (tcp-listener 5999)
+    #:topic t
+    #:on-presence
+     (spawn (connection-handler t))))))
+
+(define (connection-handler t)
+  (define me (gensym 'user))
+  (define-values (cin cout in-topic out-topic) (tcp-accept t))
+  (transition 'no-state
+    (peer-to-peer-roles me cout)
+    (relay-to-tcp-roles me cin cout in-topic out-topic)))
+
+(define (peer-to-peer-roles me cout)
+  (define (announce t did-what)
+    (unless (equal? (speaker t) me)
+      (at-meta-level (cout (term->bytes `(,(speaker t) ,did-what))))))
+  (list (role/anon (topic-publisher `(,me says ,(wild))))
+	(role/anon (topic-subscriber `(,(wild) says ,(wild)))
+	  #:topic t
+	  #:on-presence (announce t 'arrived)
+	  #:on-absence  (announce t 'departed)
+	  [message (at-meta-level (cout (term->bytes message)))])))
+
+(define (speaker t)
+  (first (topic-pattern t)))
+
+(define (relay-to-tcp-roles me cin cout in-topic out-topic)
+  (at-meta-level
+    (cout (term->bytes `(you-are ,me)))
+     (cin (tcp-mode 'lines))
+     (cin (tcp-credit 1))
+     (role/anon out-topic)
+     (role/anon in-topic
+       #:on-absence (kill)
+       [(tcp-channel _ _ (? bytes? line))
+        (list (at-meta-level (cin (tcp-credit 1)))
+              (send-message
+                `(,me says ,line)))])))
+
+(ground-vm
+ (transition 'no-state
+   (spawn tcp-driver)
+   (spawn (nested-vm 'app-vm listener-proc))))