Big bang analogue

2012-01-13 16:14:51 -05:00 · 2012-01-13 16:14:51 -05:00 · 79741ab7b6
parent 9382da7631
commit 79741ab7b6
2 changed files with 196 additions and 0 deletions
--- a/os-big-bang-example.rkt
+++ b/os-big-bang-example.rkt
@ -0,0 +1,61 @@
+#lang racket/base
+
+(require racket/port)
+(require "os-big-bang.rkt")
+
+(define display-driver-handler
+  (message-handlers w
+   [`(display ,message)
+    (transition w (send-meta-message (lambda ()
+				       (display message)
+				       (flush-output))))]))
+
+(define read-line-driver-handler
+  (message-handlers w
+   [`(request ,reply-addr read-line)
+    (define sid `(read-line-transaction ,reply-addr))
+    (transition w
+		(subscribe sid
+			   (meta-message-handler w
+			    [((read-line-evt (current-input-port) 'any) => l)
+			     (transition w
+					 (unsubscribe sid)
+					 (send-message `(reply ,reply-addr ,l)))])))]))
+
+;; This should be part of racket
+(define (time-evt msecs)
+  (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
+
+(define (tick-driver self-sid interval)
+  (let loop ((last-tick-time 0) (counter 0))
+    (subscribe self-sid
+	       (meta-message-handler w
+		[((time-evt (+ last-tick-time interval)) => now)
+		 (transition w
+			     (unsubscribe self-sid)
+			     (send-message `(tick ,counter ,now))
+			     (loop now (+ counter 1)))]))))
+
+(os-big-bang 'none
+	     (subscribe 'display-driver display-driver-handler)
+	     (subscribe 'read-line-driver read-line-driver-handler)
+	     (tick-driver 'ticker 1000)
+	     (send-message `(display "Hello! Enter your name:\n"))
+	     (send-message `(request read-name read-line))
+	     (subscribe 'ticker-handler
+			(message-handlers w
+			 [`(tick ,counter ,_)
+			  (transition w
+				      (send-message
+				       `(display ,(string-append "TICK "
+								 (number->string counter)
+								 "\n"))))]))
+	     (subscribe 'greet
+			(message-handlers w
+			 [`(reply read-name ,name)
+			  (transition w
+				      (send-message `(display "Hello, "))
+				      (send-message `(display ,name))
+				      (send-message `(display "!\n"))
+				      (unsubscribe 'ticker)
+				      )])))
--- a/os-big-bang.rkt
+++ b/os-big-bang.rkt
@ -0,0 +1,135 @@
+#lang racket/base
+
+; Evented userland for os.rkt
+
+(require racket/set)
+(require racket/match)
+(require "os.rkt")
+
+(provide (struct-out subscribe)
+	 (struct-out unsubscribe)
+	 (struct-out send-message)
+	 (struct-out send-meta-message)
+	 (struct-out spawn)
+
+	 (struct-out on-message)
+	 (struct-out on-meta-message)
+	 message-handlers
+	 meta-message-handler
+
+	 (except-out (struct-out transition) transition)
+	 (rename-out [make-transition transition])
+
+	 os-big-bang)
+
+;; A SID is an Any, a world-specific identifier for subscriptions.
+
+;; An Action is one of
+;; -- (subscribe SID EventDescription), to add a subscription
+;; -- (unsubscribe SID), to remove ALL previously-added subscriptions with this SID
+;; -- (send-message Message), to emit a message into the local medium
+;; -- (send-meta-message MetaMessage), to emit a message into the containing medium
+;; -- (spawn OtherWorldState ListOf<Action>), to start a new independent sibling in the local medium
+(struct subscribe (sid event-description) #:transparent)
+(struct unsubscribe (sid) #:transparent)
+(struct send-message (body) #:transparent)
+(struct send-meta-message (body) #:transparent)
+(struct spawn (initial-state initial-actions) #:transparent)
+
+;; An EventDescription is one of
+;; -- (on-message MessagePattern (Message WorldState -> Transition)), conditionally
+;;    invoked when a message arrives
+;; -- (on-meta-message MetaPattern (MetaMessage WorldState -> Transition)), conditionally
+;;    invoked when a metamessage arrives
+;; If multiple EventDescriptions match a given event, one is
+;; nondeterministically selected.
+(struct on-message (pattern handler) #:transparent)
+(struct on-meta-message (pattern handler) #:transparent)
+
+;; A Transition is either
+;; -- a (transition WorldState ListOf<Action>) or
+;; -- a WorldState
+(struct transition (state actions) #:transparent)
+(define (make-transition state . actions) (transition state actions))
+
+;; A World is a (world WorldState Map<SID,Set<EventDescription>>), a
+;; representation of a suspended world and its active subscriptions.
+(struct world (state subscriptions) #:transparent)
+
+(define-syntax message-handlers
+  (syntax-rules ()
+    ((_ old-state [pattern body ...] ...)
+     (on-message (match-lambda [pattern #t] ... [_ #f])
+		 (lambda (message old-state)
+		   (match message
+		     [pattern body ...] ...))))))
+
+(define-syntax meta-message-handler
+  (syntax-rules (=>)
+    ((_ old-state [(raw-pattern => pattern) body ...])
+     (on-meta-message raw-pattern
+		      (lambda (meta-message old-state)
+			(match meta-message
+			  [pattern body ...]))))))
+
+(define (world->os-subscription w)
+  (subscription w
+		#f
+		(for*/list ([(sid vs) (world-subscriptions w)]
+			    [v vs]
+			    #:when (on-message? v))
+		  (match-define (on-message pattern handler) v)
+		  (message-handler pattern (wrap-handler handler)))
+		(for*/list ([(sid vs) (world-subscriptions w)]
+			    [v vs]
+			    #:when (on-meta-message? v))
+		  (match-define (on-meta-message pattern handler) v)
+		  (message-handler pattern (wrap-handler handler)))))
+
+(define (((wrap-handler handler) message) w)
+  (maybe-transition->os-transition w (handler message (world-state w))))
+
+(define (maybe-transition->os-transition w t)
+  (if (transition? t)
+      (transition->os-transition w t)
+      (transition->os-transition w (transition t '()))))
+
+(define (transition->os-transition w t)
+  (match-define (transition state actions) t)
+  (kernel-mode-transition (world->os-subscription (update-world w state actions))
+			  (for/list [(a actions) #:when (send-message? a)]
+			    (send-message-body a))
+			  (for/list [(a actions) #:when (send-meta-message? a)]
+			    (send-meta-message-body a))
+			  (for/list [(a actions) #:when (spawn? a)]
+			    (spawn->runnable a))))
+
+(define (update-world w new-state actions)
+  (world new-state
+	 (foldl (lambda (action old-map)
+		  (match action
+		    [(subscribe sid desc)
+		     (hash-update old-map sid
+				  (lambda (s) (set-add s desc))
+				  (lambda () (set desc)))]
+		    [(unsubscribe sid)
+		     (hash-remove old-map sid)]
+		    [_ old-map]))
+		(world-subscriptions w)
+		actions)))
+
+(define (spawn->runnable s)
+  (match-define (spawn initial-state initial-actions) s)
+  (runnable (void)
+	    (lambda (_) (boot-task initial-state initial-actions))))
+
+(define (boot-task initial-state initial-actions)
+  (transition->os-transition (world (void) (hash))
+			     (transition initial-state initial-actions)))
+
+(define (os-big-bang initial-state
+		     #:pattern-predicate [pattern-predicate (lambda (p m) (p m))]
+		     . initial-actions)
+  (ground-vm pattern-predicate
+	     (lambda ()
+	       (boot-task initial-state initial-actions))))