Big bang analogue
This commit is contained in:
parent
9382da7631
commit
79741ab7b6
|
@ -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)
|
||||||
|
)])))
|
|
@ -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))))
|
Loading…
Reference in New Issue