From b109465b00c5b1f66c3b0901ec13c682dca8b792 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 15 Feb 2012 10:34:17 -0500 Subject: [PATCH] Split out to racket-matrix --- matrix/TODO | 10 - matrix/dump-bytes.rkt | 45 ----- matrix/indenting.el | 5 - matrix/os-big-bang-example.rkt | 79 -------- matrix/os-big-bang-testing.rkt | 21 --- matrix/os-big-bang.rkt | 158 ---------------- matrix/os-example.rkt | 64 ------- matrix/os-timer.rkt | 49 ----- matrix/os-udp-test-big-bang.rkt | 45 ----- matrix/os-udp-test-userland.rkt | 20 -- matrix/os-udp.rkt | 82 -------- matrix/os-userland-example.rkt | 23 --- matrix/os-userland-stdlib.rkt | 134 ------------- matrix/os-userland.rkt | 100 ---------- matrix/os.hs | 137 -------------- matrix/os.rkt | 320 -------------------------------- matrix/universe.rkt | 208 --------------------- 17 files changed, 1500 deletions(-) delete mode 100644 matrix/TODO delete mode 100644 matrix/dump-bytes.rkt delete mode 100644 matrix/indenting.el delete mode 100644 matrix/os-big-bang-example.rkt delete mode 100644 matrix/os-big-bang-testing.rkt delete mode 100644 matrix/os-big-bang.rkt delete mode 100644 matrix/os-example.rkt delete mode 100644 matrix/os-timer.rkt delete mode 100644 matrix/os-udp-test-big-bang.rkt delete mode 100644 matrix/os-udp-test-userland.rkt delete mode 100644 matrix/os-udp.rkt delete mode 100644 matrix/os-userland-example.rkt delete mode 100644 matrix/os-userland-stdlib.rkt delete mode 100644 matrix/os-userland.rkt delete mode 100644 matrix/os.hs delete mode 100644 matrix/os.rkt delete mode 100644 matrix/universe.rkt diff --git a/matrix/TODO b/matrix/TODO deleted file mode 100644 index 87ace0f..0000000 --- a/matrix/TODO +++ /dev/null @@ -1,10 +0,0 @@ -## os.rkt and friends - - - move from quasiquoted to prefab structs - - define a prefab struct for every evt? that we want to use - - define lowest-level drivers for each prefab struct - -It feels like those lowest-level drivers are listening for *demand* -i.e. they're listening for presence and are then acting to supply such -demand. Think about the relationships between presence (both positive -and negative), and interfacing to ad-hoc sources and sinks. diff --git a/matrix/dump-bytes.rkt b/matrix/dump-bytes.rkt deleted file mode 100644 index 6b568ef..0000000 --- a/matrix/dump-bytes.rkt +++ /dev/null @@ -1,45 +0,0 @@ -#lang racket/base - -(provide dump-bytes!) - -(define (hex width n) - (define s (number->string n 16)) - (define slen (string-length s)) - (cond - ((< slen width) (string-append (make-string (- width slen) #\0) s)) - ((= slen width) s) - ((> slen width) (substring s 0 width)))) - -(define (dump-bytes! bs requested-count) - (define count (min requested-count (bytes-length bs))) - (define clipped (subbytes bs 0 count)) - (define (dump-hex i) - (if (< i count) - (display (hex 2 (bytes-ref clipped i))) - (display " ")) - (display #\space)) - (define (dump-char i) - (if (< i count) - (let ((ch (bytes-ref clipped i))) - (if (<= 32 ch 127) - (display (integer->char ch)) - (display #\.))) - (display #\space))) - (define (for-each-between f low high) - (do ((i low (+ i 1))) - ((= i high)) - (f i))) - (define (dump-line i) - (display (hex 8 i)) - (display #\space) - (for-each-between dump-hex i (+ i 8)) - (display ": ") - (for-each-between dump-hex (+ i 8) (+ i 16)) - (display #\space) - (for-each-between dump-char i (+ i 8)) - (display " : ") - (for-each-between dump-char (+ i 8) (+ i 16)) - (newline)) - (do ((i 0 (+ i 16))) - ((>= i count)) - (dump-line i))) diff --git a/matrix/indenting.el b/matrix/indenting.el deleted file mode 100644 index 7ea17c2..0000000 --- a/matrix/indenting.el +++ /dev/null @@ -1,5 +0,0 @@ -(mapcar #'(lambda (x) (put x 'scheme-indent-function 1)) - '(transition extend-transition - subscribe subscribe/fresh unsubscribe - os-big-bang - message-handlers meta-message-handlers ground-message-handler)) diff --git a/matrix/os-big-bang-example.rkt b/matrix/os-big-bang-example.rkt deleted file mode 100644 index f1745ca..0000000 --- a/matrix/os-big-bang-example.rkt +++ /dev/null @@ -1,79 +0,0 @@ -#lang racket/base - -(require racket/match) -(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) - (transition w - (subscribe/fresh sid - (ground-message-handler w - [((list 'read-line reply-addr) - (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)) - (define next-time (+ last-tick-time interval)) - (subscribe self-sid - (ground-message-handler w - [((list 'timer-alarm next-time) - (time-evt next-time) - => now) - (transition w - (unsubscribe self-sid) - (send-message `(tick ,counter ,now)) - (loop now (+ counter 1)))])))) - -(define main - (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! ")) - (send-message 'greet-loop) - (subscribe 'greet-loop-handler - (message-handlers w - ['greet-loop - (transition w - (send-message `(display "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 'read-line-result-handler - (message-handlers w - [`(reply read-name ,(== eof)) - (transition w - (send-message `(display "Goodbye!\n")))] - [`(reply read-name ,name) - (transition w - (send-message `(display "Hello, ")) - (send-message `(display ,name)) - (send-message `(display "!\n")) - (unsubscribe 'ticker) - (send-message 'greet-loop) - )])))) - -(ground-vm main) diff --git a/matrix/os-big-bang-testing.rkt b/matrix/os-big-bang-testing.rkt deleted file mode 100644 index 091d447..0000000 --- a/matrix/os-big-bang-testing.rkt +++ /dev/null @@ -1,21 +0,0 @@ -#lang racket/base - -(require racket/match) -(require rackunit) -(require "os-big-bang.rkt") - -(provide check-message-handler) - -(define (flatten-transition t) - (if (transition? t) - (transition (transition-state t) (transition-actions t)) ;; autoflattens - (transition t '()))) ;; wrap for convenient comparison - -(define (check-message-handler mh initial-w message final-w expected-actions) - (match-define (on-message pattern handler) mh) - (check-true (pattern message) "Message-handler pattern did not match message provided") - (define v (match (handler message initial-w) - [(? transition? t) t] - [new-w (transition new-w '())])) - (check-equal? (flatten-transition v) (transition final-w expected-actions) - "Produced world-and-actions did not match expected world-and-actions")) diff --git a/matrix/os-big-bang.rkt b/matrix/os-big-bang.rkt deleted file mode 100644 index 4ce1af2..0000000 --- a/matrix/os-big-bang.rkt +++ /dev/null @@ -1,158 +0,0 @@ -#lang racket/base - -; Evented userland for os.rkt - -(require racket/set) -(require racket/match) -(require racket/list) -(require "os.rkt") - -(provide (struct-out subscribe) - subscribe/fresh - - (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-handlers - ground-message-handler - - (except-out (struct-out transition) transition) - (rename-out [make-transition transition]) - extend-transition - - ground-vm ;; reprovided from os.rkt for convenience - os-big-bang - os-big-bang/transition) - -;; 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 BootK), to start a new sibling in the raw os.rkt eventing model -(struct subscribe (sid event-description) #:transparent) -(struct unsubscribe (sid) #:transparent) -(struct send-message (body) #:transparent) -(struct send-meta-message (body) #:transparent) -(struct spawn (thunk) #: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) or -;; -- a WorldState -(struct transition (state actions) #:transparent) -(define (make-transition state . actions) (transition state actions)) - -;; Transition [Action ...] -> Transition -;; Append the given actions to the transition given as the first argument. -(define (extend-transition t . more-actions) - (match t - [(transition state actions) (transition state (list actions more-actions))] - [state (transition state more-actions)])) - -;; A World is a (world WorldState Map>), a -;; representation of a suspended world and its active subscriptions. -(struct world (state subscriptions) #:transparent) - -(define-syntax subscribe/fresh - (syntax-rules () - ((_ id-binder event-description) - (let ((id-binder (gensym 'id-binder))) - (subscribe id-binder event-description))))) - -(define-syntax message-handlers* - (syntax-rules () - ((_ action-constructor old-state-pattern [pattern body ...] ...) - (action-constructor (match-lambda [pattern #t] ... [_ #f]) - (lambda (message old-state) - (match-define old-state-pattern old-state) - (match message - [pattern body ...] ...)))))) - -(define-syntax message-handlers - (syntax-rules () - ((_ old-state-pattern [pattern body ...] ...) - (message-handlers* on-message old-state-pattern [pattern body ...] ...)))) - -(define-syntax meta-message-handlers - (syntax-rules () - ((_ old-state-pattern [pattern body ...] ...) - (message-handlers* on-meta-message old-state-pattern [pattern body ...] ...)))) - -(define-syntax ground-message-handler - (syntax-rules (=>) - ((_ old-state-pattern [(tag-expr evt-expr => pattern) body ...]) - (on-meta-message (ground-event-pattern tag-expr evt-expr) - (lambda (meta-message old-state) - (match-define old-state-pattern old-state) - (match meta-message - [(ground-event-value _ pattern) body ...])))))) - -(define (world->os-suspension w) - (suspension 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 unflattened-actions) t) - (define actions (flatten unflattened-actions)) - (kernel-mode-transition (world->os-suspension (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-thunk 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 (os-big-bang initial-state . initial-actions) - (os-big-bang/transition (transition initial-state initial-actions))) - -(define (os-big-bang/transition t) - (lambda () (transition->os-transition (world (void) (hash)) t))) diff --git a/matrix/os-example.rkt b/matrix/os-example.rkt deleted file mode 100644 index 579f373..0000000 --- a/matrix/os-example.rkt +++ /dev/null @@ -1,64 +0,0 @@ -#lang racket/base - -(require "os.rkt") -(require racket/pretty) - -(define (yield k) - (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '()) - '() - '() - '())) - -(define (quit) - (kernel-mode-transition (suspension 'none #f '() '()) - '() - '() - '())) - -(define (print x k) - (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '()) - '() - (list (lambda () (pretty-print x))) - '())) - -(define (super-alarm msecs) - (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) - -(define (sleep n k) - (kernel-mode-transition (suspension 'none - #f - '() - (list (message-handler - (let ((wakeup-time - (+ (current-inexact-milliseconds) n))) - (ground-event-pattern - (list 'alarm wakeup-time) - (super-alarm wakeup-time))) - (lambda (_message) - (lambda (_state) - (k)))))) - '() - '() - '())) - -(define (spawn thunk k) - (kernel-mode-transition (suspension 'none (lambda (_) (k)) '() '()) - '() - '() - (list thunk))) - -(define (example-process delay) - (print "SLEEPING" - (lambda () - (sleep delay - (lambda () - (yield - (lambda () - (print "HELLO" - quit)))))))) - -(ground-vm (lambda () - (spawn (lambda () - (example-process 1000)) - (lambda () - (example-process 2000))))) diff --git a/matrix/os-timer.rkt b/matrix/os-timer.rkt deleted file mode 100644 index 3cbd1a1..0000000 --- a/matrix/os-timer.rkt +++ /dev/null @@ -1,49 +0,0 @@ -#lang racket/base - -(require racket/match) -(require "codec.rkt") -(require "os-big-bang.rkt") -(require "os-udp.rkt") - -(provide (struct-out set-timer) - (struct-out timer-expired) - timer-driver - timer-relay) - -(struct set-timer (label msecs relative?) #:prefab) -(struct timer-expired (label msecs) #:prefab) - -;; Something like this should be part of racket -(define (timer-evt msecs relative?) - (wrap-evt (alarm-evt (if relative? (+ (current-inexact-milliseconds) msecs) msecs)) - (lambda (_) (current-inexact-milliseconds)))) - -(define (timer-driver [self-id 'timer-driver]) - (os-big-bang 'no-state - (subscribe 'timer-setter - (message-handlers w - [(set-timer reply-label msecs relative?) - (transition w - (subscribe/fresh label - (ground-message-handler w - [((list self-id label) - (timer-evt msecs relative?) - => now) - (transition w - (unsubscribe label) - (send-message (timer-expired reply-label now)))])))])))) - -(define (timer-relay [self-id 'timer-relay]) - (os-big-bang 'no-state - (subscribe 'timer-relay - (message-handlers w - [(set-timer reply-label msecs relative?) - (define timer-id (list self-id reply-label)) - (transition w - (send-meta-message (set-timer timer-id msecs relative?)) - (subscribe/fresh label - (meta-message-handlers w - [(timer-expired (== timer-id) now) - (transition w - (unsubscribe label) - (send-message (timer-expired reply-label now)))])))])))) diff --git a/matrix/os-udp-test-big-bang.rkt b/matrix/os-udp-test-big-bang.rkt deleted file mode 100644 index e13e0fc..0000000 --- a/matrix/os-udp-test-big-bang.rkt +++ /dev/null @@ -1,45 +0,0 @@ -#lang racket/base - -(require racket/match) -(require "os-big-bang.rkt") -(require (only-in "os-userland.rkt" userland)) -(require "os-udp.rkt") -(require "os-big-bang-testing.rkt") - -(define (packet-handler sname) - (message-handlers w - [(udp-packet source (== sname) body) - (transition w - (send-message (udp-packet sname source body)))])) - -(check-message-handler (packet-handler (udp-address #f 5555)) - 'none - (udp-packet (udp-address "127.0.0.1" 12345) (udp-address #f 5555) #"abcd") - 'none - (list (send-message (udp-packet (udp-address #f 5555) - (udp-address "127.0.0.1" 12345) - #"abcd")))) - -(define echoer - (os-big-bang 'none - (send-message `(request create-echo-socket (udp new 5555 65536))) - (subscribe/fresh sub - (message-handlers w - [`(reply create-echo-socket ,sname) - (transition w - (unsubscribe sub) - (subscribe 'packet-handler (packet-handler sname)))])))) - -(define spy - (os-big-bang 'none - (subscribe 'spy (message-handlers w [x (write `(MESSAGE ,x)) (newline)])))) - -(define (main) - (ground-vm - (os-big-bang 'none - (spawn spy) - (spawn udp-driver) - (spawn echoer)))) - -(main) -;;(provide main) diff --git a/matrix/os-udp-test-userland.rkt b/matrix/os-udp-test-userland.rkt deleted file mode 100644 index 02eb83a..0000000 --- a/matrix/os-udp-test-userland.rkt +++ /dev/null @@ -1,20 +0,0 @@ -#lang racket/base - -(require racket/match) -(require "os-userland-stdlib.rkt") -(require "os-udp.rkt") - -(ground-vm/stdlib - (userland - (lambda () - (spawn display-driver) - (spawn read-line-driver) - (spawn udp-driver) - (poll) - (define s (rpc `(udp new 5555 65536))) - (let loop () - (wait (message-handlers - [(udp-packet source (and sink (== s)) body) - (write `(udp (source ,source) (sink ,sink))) (newline) - (send (udp-packet sink source body)) - (loop)])))))) \ No newline at end of file diff --git a/matrix/os-udp.rkt b/matrix/os-udp.rkt deleted file mode 100644 index 10ba0cf..0000000 --- a/matrix/os-udp.rkt +++ /dev/null @@ -1,82 +0,0 @@ -#lang racket/base - -;; UDP drivers for os.rkt - -(require racket/match) -(require racket/udp) -(require "dump-bytes.rkt") -(require "os-userland-stdlib.rkt") - -(provide (struct-out udp-address) - (struct-out udp-packet) - udp-driver - udp-spy) - -;; A UdpAddress is one of -;; -- a (udp-address String Uint16), representing a remote socket -;; -- a (udp-address #f Uint16), representing a local socket -(struct udp-address (host port) #:prefab) - -;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and -;; represents a packet appearing on our local "subnet" of the full UDP -;; network, complete with source, destination and contents. -(struct udp-packet (source destination body) #:prefab) - -;; TODO: BUG?: Routing packets between two local sockets won't work -;; because the patterns aren't set up to recognise that situation. - -(define udp-driver - (userland - (lambda () - (rpc-service - [`(udp new ,port-number ,buffer-size) - (define s (udp-open-socket #f #f)) - (when port-number - (udp-bind! s #f port-number)) - (define-values (_local-address local-port _remote-address _remote-port) - (udp-addresses s #t)) - (define sname (udp-address #f local-port)) - (spawn (userland (udp-sender sname s))) - (spawn (userland (udp-receiver sname s buffer-size))) - (spawn (userland (udp-closer sname s))) - sname])))) - -(define ((udp-sender sname s)) - (let loop () - (wait (message-handlers - [`(close ,(== sname)) - (void)] - [(udp-packet (== sname) (udp-address host port) body) - (meta-send (lambda () (udp-send-to s host port body))) - (loop)])))) - -(define ((udp-receiver sname s buffer-size)) - (define buffer (make-bytes buffer-size)) - (let loop () - (wait (message-handlers - [`(close ,(== sname)) - (void)]) - (meta-message-handlers - [((list 'udp-receive sname) - (udp-receive!-evt s buffer) - => (list packet-length host port)) - (define packet (subbytes buffer 0 packet-length)) - (send (udp-packet (udp-address host port) sname packet)) - (loop)])))) - -(define ((udp-closer sname s)) - (wait (message-handlers - [`(close ,(== sname)) - (udp-close s)]))) - -(define udp-spy - (userland - (lambda () - (let loop () - (wait (message-handlers - [(udp-packet source dest body) - (write `(UDP ,source --> ,dest)) (newline) - (dump-bytes! body (bytes-length body))] - [x - (write `(UDP ,x)) (newline)])) - (loop))))) diff --git a/matrix/os-userland-example.rkt b/matrix/os-userland-example.rkt deleted file mode 100644 index af45920..0000000 --- a/matrix/os-userland-example.rkt +++ /dev/null @@ -1,23 +0,0 @@ -#lang racket/base - -(require "os-userland-stdlib.rkt") - -(define (main) - (spawn display-driver) - (spawn read-line-driver) - (spawn sleep-driver) - (spawn (userland (lambda () - (display "HI\n") - (sleep 1000) - (display "THERE\n")))) - (poll) ;; Wait for drivers to become ready (!) - ;; The Right Way to do this is to have presence integrated with subscription - (display "Hello! Enter your name:\n") - (define name (rpc 'read-line)) - (display "Hello, ") - (display name) - (display "!\n") - (sleep 1000) - (display "Goodbye\n")) - -(ground-vm/stdlib (userland main)) diff --git a/matrix/os-userland-stdlib.rkt b/matrix/os-userland-stdlib.rkt deleted file mode 100644 index e815424..0000000 --- a/matrix/os-userland-stdlib.rkt +++ /dev/null @@ -1,134 +0,0 @@ -#lang racket/base - -(require racket/match) -(require racket/port) -(require "os-userland.rkt") - -(require (prefix-in base: racket/base)) - -(provide (all-from-out "os-userland.rkt") - - ground-vm/stdlib - - message-handlers - meta-message-handlers - - rpc - rpc-service - - display-driver - display - - read-line-driver - read-line - - current-time - sleep-driver - sleep - - receive - receive/timeout) - -(define (ground-vm/stdlib boot) - (ground-vm boot #:pattern-predicate (lambda (p m) (p m)))) - -(define-syntax message-handlers - (syntax-rules () - ((_ (pattern body ...) ...) - (list (wait-clause (match-lambda (pattern #t) (_ #f)) - (match-lambda (pattern body ...))) - ...)))) - -(define-syntax meta-message-handlers - (syntax-rules (=>) - ((_ [(tag-expr evt-expr => pattern) body ...] ...) - (list (wait-clause (ground-event-pattern tag-expr evt-expr) - (match-lambda ((ground-event-value _ pattern) body ...))) - ...)))) - -(define (rpc req) - (define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect? - (send `(request ,reply-addr ,req)) - (wait (message-handlers - [`(reply ,(== reply-addr) ,v) - v]))) - -(define-syntax rpc-service - (syntax-rules () - [(_ [pattern body ...] ...) - (let loop () - (wait (message-handlers - [`(request ,reply-addr ,pattern) - (spawn (userland (lambda () - (define answer (let () body ...)) - (send `(reply ,reply-addr ,answer)))))] - ...)) - (loop))])) - -(define display-driver - (userland - (lambda () - (let loop () - (define message (wait (message-handlers [`(display ,message) message]))) - (meta-send (lambda () - (base:display message) - (flush-output))) - (loop))))) - -(define (display x) - (send `(display ,x))) - -(define read-line-driver - (userland - (lambda () - (rpc-service - [`read-line (wait (message-handlers) - (meta-message-handlers - [('read-line - (read-line-evt (current-input-port) 'any) - => line) - line]))])))) - -(define (read-line) - (rpc 'read-line)) - -(define (time-evt msecs) - (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) - -(define (wait-mmh msecs) - (meta-message-handlers - [((list 'time-evt msecs) - (time-evt msecs) - => current-time) - current-time])) - -(define (wait-until-time msecs) - (wait (message-handlers) - (wait-mmh msecs))) - -(define (current-time) - (wait-until-time 0)) - -(define sleep-driver - (userland - (lambda () - (rpc-service - [`(sleep ,msecs) - (send `(display (Sleeping ,msecs))) - (define now (wait-until-time (+ (current-time) msecs))) - (send `(display "\n")) - now])))) - -(define (sleep msecs) - (rpc `(sleep ,msecs))) - -(define-syntax receive - (syntax-rules () - ((_ mh-clause ...) - (wait (message-handlers mh-clause ...))))) - -(define-syntax receive/timeout - (syntax-rules () - ((_ timeout-msecs mh-clause ...) - (wait (message-handlers mh-clause ...) - (wait-mmh timeout-msecs))))) diff --git a/matrix/os-userland.rkt b/matrix/os-userland.rkt deleted file mode 100644 index 2a292ef..0000000 --- a/matrix/os-userland.rkt +++ /dev/null @@ -1,100 +0,0 @@ -#lang racket/base - -; Userland for os.rkt: use of delimited continuations to invoke kernel services - -(require racket/match) -(require racket/list) -(require "os.rkt") - -(provide (struct-out wait-clause) - - ground-vm ;; convenience re-export - (struct-out ground-event-pattern) ;; convenience re-export - (struct-out ground-event-value) ;; convenience re-export - - userland - - send - meta-send - send* - - wait - poll - - spawn) - -(struct wait-clause (pattern handler-proc) #:transparent) - -(define prompt (make-continuation-prompt-tag 'os-userland)) - -;; ( -> Void) -> BootK -;; Wraps a thunk that uses the userland continuation-based approach to -;; simulating side effects so that it can be used as a BootK with a -;; KernelModeTransition. -(define (userland main) - (lambda () - (start-transaction ((reply-to (lambda (_) - (main) - 'finish)) - void)))) - -(define ((reply-to k) v) - (call-with-continuation-prompt (lambda () (k (v))) prompt)) - -(define (start-transaction first-action) - (accumulate-transaction '() '() '() first-action)) - -(define (accumulate-transaction messages meta-messages new-threads action) - (define (syscall sub) - (kernel-mode-transition sub - (reverse messages) - (reverse meta-messages) - (reverse new-threads))) - (match action - [`(actions ,ms ,mms ,thrs ,k) - (accumulate-transaction (append (reverse ms) messages) - (append (reverse mms) meta-messages) - (append (reverse thrs) new-threads) - (k void))] - [`(wait ,polling? ,mhs ,mmhs ,k) - (syscall (suspension k - (and polling? (lambda (k) (start-transaction (k void)))) - (wrap-handlers mhs) - (wrap-handlers mmhs)))] - [`finish - (syscall (suspension 'finished #f '() '()))])) - -(define (((invoke-handler proc) v) k) - (start-transaction (k (lambda () (proc v))))) - -(define (wrap-handlers hs) - (map (lambda (h) (message-handler (wait-clause-pattern h) - (invoke-handler (wait-clause-handler-proc h)))) - (flatten hs))) - -(define (call-in-kernel-context proc) - (call-with-composable-continuation - (lambda (k) (abort-current-continuation prompt - (lambda () (proc (reply-to k))))) - prompt)) - -(define (actions ms mms thrs) - (call-in-kernel-context (lambda (k) `(actions ,ms ,mms ,thrs ,k)))) - -(define (send message) - (actions (list message) '() '())) - -(define (meta-send meta-message) - (actions '() (list meta-message) '())) - -(define (send* messages [meta-messages '()]) - (actions messages meta-messages '())) - -(define (wait mhs [mmhs '()]) - (call-in-kernel-context (lambda (k) `(wait #f ,mhs ,mmhs ,k)))) - -(define (poll [mhs '()] [mmhs '()]) - (call-in-kernel-context (lambda (k) `(wait #t ,mhs ,mmhs ,k)))) - -(define (spawn thunk) - (actions '() '() (list thunk))) diff --git a/matrix/os.hs b/matrix/os.hs deleted file mode 100644 index 36def6a..0000000 --- a/matrix/os.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} --- MultiParamTypeClasses FunctionalDependencies -module OS where - --- TODO try avoiding double-matching for metamessages and the need for --- broadcast by introducing a facility for supporting event-pattern --- subtyping - -import Control.Arrow ((>>>)) -import Data.Maybe -import Data.List -import Control.Concurrent.Chan - -data VM m mm = VM { suspensions :: [Suspension m mm], - messages :: [m], - metaMessages :: [mm], - runnables :: [Callback m mm ()] } -type Callback m mm state = (state -> KernelModeTransition m mm) -data Suspension m mm = forall state. Suspension - state - (Maybe (Callback m mm state)) - [Handler m mm state] - [MetaHandler m mm state] -data KernelModeTransition m mm = KernelModeTransition (Suspension m mm) - [m] - [mm] - [Callback m mm ()] -type Handler m mm state = (m -> Maybe (Callback m mm state)) -type MetaHandler m mm state = (mm -> Maybe (Callback m mm state)) - -newVM boot = VM { suspensions = [], - messages = [], - metaMessages = [], - runnables = [boot] } - -runVM :: VM m mm -> KernelModeTransition mm mm1 -runVM = rebuildSuspensions enqueuePoller >>> runRunnables >>> dispatchMessages >>> \ vm -> - let mms = reverse $ metaMessages vm - mmhs = concatMap extractDown $ suspensions vm - pollerK = if shouldPoll vm then Just runVM else Nothing - in - KernelModeTransition (Suspension (vm { metaMessages = [] }) pollerK mmhs []) mms [] [] - -rebuildSuspensions :: (VM m mm -> Suspension m mm -> VM m mm) -> (VM m mm) -> (VM m mm) -rebuildSuspensions f vm = foldl f (vm { suspensions = [] }) (suspensions vm) - -enqueuePoller :: VM m mm -> Suspension m mm -> VM m mm -enqueuePoller vm susp@(Suspension state k _ _) = - if isPolling susp - then vm { runnables = (\ () -> (fromJust k) state) : runnables vm } - else vm { suspensions = susp : suspensions vm } - -runRunnables :: VM m mm -> VM m mm -runRunnables vm = foldl runRunnable (vm { runnables = [] }) (reverse (runnables vm)) -runRunnable vm r = performTransition (r ()) vm - -dispatchMessages :: VM m mm -> VM m mm -dispatchMessages vm = foldr dispatchMessage (vm { messages = [] }) (messages vm) - -dispatchMessage m = rebuildSuspensions matchSuspension - where matchSuspension vm susp@(Suspension state _ mhs _) = - searchHandlers vm susp state m mhs - -searchHandlers vm susp state m [] = vm { suspensions = susp : suspensions vm } -searchHandlers vm susp state m (mh:mhs) = - case mh m of - Just h -> performTransition (h state) vm - Nothing -> searchHandlers vm susp state m mhs - -extractDown (Suspension _ _ _ mmhs) = map matchMetaMessage mmhs - where matchMetaMessage mmh mm = - case mmh mm of - Nothing -> Nothing - Just _ -> Just (runMetaHandler mm) - -isPolling (Suspension _ pollerK _ _) = isNothing pollerK -isBlocked = not . isPolling - -shouldPoll vm@(VM { messages = [], runnables = []}) = not $ all isBlocked (suspensions vm) -shouldPoll _ = True - -runMetaHandler :: mm -> (VM m mm) -> (KernelModeTransition mm mm1) -runMetaHandler mm = runVM . rebuildSuspensions dispatchMetaMessage - where dispatchMetaMessage vm susp@(Suspension state _ _ mmhs) = - searchHandlers vm susp state mm mmhs - -performTransition :: KernelModeTransition m mm -> VM m mm -> VM m mm -performTransition (KernelModeTransition susp ms mms cbs) vm = - vm { suspensions = susp : suspensions vm, - messages = reverse ms ++ (messages vm), - metaMessages = reverse mms ++ (metaMessages vm), - runnables = reverse cbs ++ (runnables vm) } - ---------------------------------------------------------------------------- -{- -type LabelledMessage a b = (a, b) - -groundVM :: Callback m (IO ()) () -> IO () -groundVM boot = do inboundChannel <- newChan - mainloop inboundChannel (runVM (makeVM boot)) - where mainloop ch (KernelModeTransition (Subscription newState pollingK mhs []) ms [] []) = do - runActions ch ms - case (newState, pollingK, mhs) of - (VM { messages = [], metaMessages = [], runnables = [] }, Nothing, []) -> - -- inert. - return () - _ -> - - - (when (not (nested-vm-inert? (kernel-mode-transition-subscription transition))) - (match transition - [(kernel-mode-transition (subscription new-state - polling-k - message-handlers - '()) - _ - '() - '()) - (define inbound-messages - (map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))]) - message-handlers)) - (match-define (cons inbound-value inbound-continuation) - (apply sync - (wrap-evt (if polling-k always-evt never-evt) - (lambda (v) (cons (void) - (lambda (dummy) polling-k)))) - inbound-messages)) - (loop ((inbound-continuation inbound-value) new-state))] - [_ - (error 'ground-vm - "Outermost VM may not spawn new siblings or send or receive metamessages")])))) --} - --- -- Values of type v are matchable by values of type p, yielding --- -- residuals of type a. --- class Matchable v p a | v -> p where --- match :: p -> v -> Maybe a diff --git a/matrix/os.rkt b/matrix/os.rkt deleted file mode 100644 index 2fdb65b..0000000 --- a/matrix/os.rkt +++ /dev/null @@ -1,320 +0,0 @@ -#lang racket/base - -;; Virtualized operating system. - -(require racket/match) -(require racket/list) - -(provide - ;; Waiting for messages - (struct-out suspension) - (struct-out message-handler) - - ;; Kernel requests - (struct-out kernel-mode-transition) - - ;; Constructing, accessing and running VMs - make-vm - vm? - run-vm - nested-vm - default-pattern-predicate - - ;; Grounding out the infinite tower of VMs - (struct-out ground-event-pattern) - (struct-out ground-event-value) - ground-vm - ) - -;; Each VM hosts 0 or more *multiplexed* processes. Each process has -;; its own state record. In between schedulings, a process consists of -;; 1 or more message handlers. A message handler is a pair of a message -;; recogniser and a procedure taking a message and a process state to a -;; new process state. -;; -;; Each VM provides a *communication bus* for its processes to -;; use. The communication bus is the only form of IPC the VM provides. -;; -;; Some processes *relay* messages out from the VM to other -;; VMs. Because the "tree" of VMs so formed has to be a tree - See -;; Shivers & Might 2006 for a discussion of this - we gather together -;; all the interactions between the supervenient VM and its support VM -;; into a single channel of communication. The relaying processes are, -;; in effect, device-drivers, providing application-specific -;; communication services to other processes in the VM. -;; -;; We split processes into "user" processes, permitted only to spawn -;; other user processes and send messages on the VM's bus, and -;; "kernel" processes, permitted also to spawn other kernel processes -;; and send messages to the VM's container. -;; -;; Time plays an interesting role in a distributed system: if the -;; medium messages are sent through isn't cooperative enough to let us -;; know of a failed conversational participant, our only recourse is -;; /timeout/. Therefore, we require every level of the machine to -;; support timeouts, though we do not require such timeouts to be tied -;; to real, wall-clock time: simulated time is just fine. This helps -;; with testability. -;; -;; Racket's alarm-evt is almost the right design for timeouts: its -;; synchronisation value should be the (or some) value of the clock -;; after the asked-for time. That way it serves as timeout and -;; clock-reader in one. - -;; VMs are parameterised over: -;; - the type of messages carried on the bus, Message -;; - the type of patterns over Messages, MessagePattern -;; - the type of messages to other VMs, MetaMessage -;; - the type of patterns over MetaMessages, MetaMessagePattern - -;; A PatternPredicate is a (MessagePattern Message -> Boolean), used -;; to match a message against a pattern. - -;; A VM is a (vm ListBagOf -;; QueueOf ;; TODO: make unordered? -;; QueueOf ;; TODO: make unordered? -;; QueueOf). -(struct vm (suspensions - pending-messages - pending-meta-messages - pending-processes - pattern-predicate - meta-pattern-predicate) #:transparent) - -;; A TrapK is a X -> InterruptK, representing a suspended process -;; waiting for some information from the VM before it can continue. - -;; An InterruptK is a -;; ProcessState -> KernelModeTransition -;; representing a suspended process that can run instantly without -;; waiting for more information from the VM. The input is the state of -;; the process, and the output is the information passed back to the -;; VM when the process yields the CPU. - -;; A BootK is a ( -> KernelModeTransition), representing either a -;; fresh process or a previously-suspended process just about to -;; resume. - -;; A Suspension is a -;; (suspension ProcessState -;; Maybe -;; ListBagOf -;; ListBagOf). -;; To poll the kernel, include a non-#f InterruptK. -(struct suspension (state - k - message-handlers - meta-message-handlers) #:transparent) - -;; A HID is a per-VM unique value, used to identify specific -;; MetaMessageHandlers. Here, we use gensyms, though an alternative -;; (and purer) approach would be to keep a counter in the VM and use -;; that to construct IDs. - -;; A MessageHandler is one of -;; -- (message-handler MessagePattern TrapK) -(struct message-handler (pattern k) #:transparent) - -;; A KernelModeTransition is a -;; (kernel-mode-transition Suspension -;; ListBagOf -;; ListBagOf -;; ListBagOf) -;; representing the suspension of the transitioning process, a list of -;; messages to emit at both this VM's and its container's level, and a -;; list of new processes to create and schedule. -(struct kernel-mode-transition (suspension - messages - meta-messages - new-processes) #:transparent) - -;; A ListBagOf is a ListOf with the additional constraint that -;; order isn't meaningful. - -;; TODO: is timeout really primitive? If so, isn't presence primitive? -;; TODO: what about metatimeout? -;; TODO: what about spawn-meta-process etc? Come back to this later. -;; TODO: enforce user-mode restrictions -;; TODO: timeouts - -;; BootK -> VM -(define (make-vm boot - #:pattern-predicate [pattern-predicate default-pattern-predicate] - #:meta-pattern-predicate [meta-pattern-predicate default-pattern-predicate]) - (vm (list) - (list) - (list) - (cons boot (list)) - pattern-predicate - meta-pattern-predicate)) - -;; VM -> KernelModeTransition -;; (A kind of Meta-InterruptK) -(define (run-vm state) - (let* ((state (requeue-pollers state)) - (state (run-runnables state)) - (state (dispatch-messages state)) - (meta-messages (reverse (vm-pending-meta-messages state))) - (meta-handlers (append-map extract-downward-meta-message-handlers (vm-suspensions state))) - (poller-k (and (should-poll? state) run-vm)) ;; only block if there's nothing left to do - (state (struct-copy vm state [pending-meta-messages (list)]))) - (kernel-mode-transition (suspension state poller-k meta-handlers '()) - meta-messages - '() - '()))) - -(define (requeue-pollers state) - (foldl (lambda (susp state) - (if (suspension-polling? susp) - (enqueue-runnable (lambda () ((suspension-k susp) (suspension-state susp))) state) - (enqueue-suspension susp state))) - (struct-copy vm state [suspensions '()]) - (vm-suspensions state))) - -(define (run-runnables state) - (foldl (lambda (r state) (perform-transition (r) state)) - (struct-copy vm state [pending-processes (list)]) - (reverse (vm-pending-processes state)))) - -(define (dispatch-messages state) - (foldl dispatch-message - (struct-copy vm state [pending-messages (list)]) - (reverse (vm-pending-messages state)))) - -(define (extract-downward-meta-message-handlers susp) - (for/list ([mmh (suspension-meta-message-handlers susp)]) - (message-handler (message-handler-pattern mmh) (dispatch-meta-message mmh)))) - -(define (((dispatch-meta-message mmh) message) state) - (run-vm - (foldl (match-suspension message - (vm-meta-pattern-predicate state) - suspension-meta-message-handlers) - (struct-copy vm state [suspensions '()]) - (vm-suspensions state)))) - -;; KernelModeTransition VM -> VM -(define (perform-transition transition state) - (match transition - [(kernel-mode-transition new-suspension - messages - meta-messages - new-processes) - (let* ((state (foldl enqueue-message state messages)) - (state (foldl enqueue-runnable state new-processes)) - (state (enqueue-suspension new-suspension state)) - (state (foldl enqueue-meta-message state meta-messages))) - state)] - [other - (error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)])) - -(define (enqueue-message message state) - (struct-copy vm state [pending-messages (cons message (vm-pending-messages state))])) - -(define (enqueue-runnable r state) - (struct-copy vm state [pending-processes (cons r (vm-pending-processes state))])) - -(define (enqueue-suspension susp state) - (match susp - [(suspension _ #f '() '()) - ;; dead process because no continuations offered - state] - [(suspension _ _ _ _) - (struct-copy vm state [suspensions (cons susp (vm-suspensions state))])])) - -(define (enqueue-meta-message message state) - (struct-copy vm state [pending-meta-messages (cons message (vm-pending-meta-messages state))])) - -(define (dispatch-message message state) - (foldl (match-suspension message - (vm-pattern-predicate state) - suspension-message-handlers) - (struct-copy vm state [suspensions '()]) - (vm-suspensions state))) - -(define ((match-suspension message apply-pattern handlers-getter) susp state) - (let search-handlers ((message-handlers (handlers-getter susp))) - (cond - [(null? message-handlers) - ;; No handler matched this message. Put the suspension - ;; back on the list for some future message. - (enqueue-suspension susp state)] - [(apply-pattern (message-handler-pattern (car message-handlers)) message) - (define trapk (message-handler-k (car message-handlers))) - (define interruptk (trapk message)) - (perform-transition (interruptk (suspension-state susp)) state)] - [else - (search-handlers (cdr message-handlers))]))) - -(define (suspension-polling? susp) - (not (eq? (suspension-k susp) #f))) - -;; VM -> Boolean -;; When should a VM block? When it has no runnables, no pending -;; messages, and no polling suspensions. Otherwise, it should poll. -(define (should-poll? state) - (or (not (null? (vm-pending-processes state))) - (not (null? (vm-pending-messages state))) - (ormap suspension-polling? (vm-suspensions state)))) - -(define (nested-vm boot - #:pattern-predicate [pattern-predicate default-pattern-predicate] - #:meta-pattern-predicate [meta-pattern-predicate default-pattern-predicate]) - (lambda () (run-vm (make-vm boot - #:pattern-predicate pattern-predicate - #:meta-pattern-predicate meta-pattern-predicate)))) - -(define default-pattern-predicate - (lambda (p m) (p m))) - -;;--------------------------------------------------------------------------- - -(define (nested-vm-inert? sub) - (match sub - [(suspension (vm _ '() '() '() _ _) #f '() '()) - ;; Inert iff not waiting for any messages or metamessages, and - ;; with no internal work left to do. - #t] - [_ #f])) - -(struct ground-event-pattern (tag evt) #:transparent) -(struct ground-event-value (tag val) #:transparent) - -(define (match-ground-event p m) - (equal? (ground-event-pattern-tag p) (ground-event-value-tag m))) - -;; PatternPredicate ( -> KernelModeTransition ) -> Void -;; In this context, -;; Message = a thunk -;; MessagePattern = evt? -;; MetaMessage, MetaMessagePattern = not defined because there's no outer level -;; Runs its argument VM until it becomes (provably) inert. -(define (ground-vm boot - #:pattern-predicate [pattern-predicate default-pattern-predicate]) - (let loop ((transition (run-vm (make-vm boot - #:pattern-predicate pattern-predicate - #:meta-pattern-predicate match-ground-event)))) - (for-each (lambda (thunk) (thunk)) (kernel-mode-transition-messages transition)) - (when (not (nested-vm-inert? (kernel-mode-transition-suspension transition))) - (match transition - [(kernel-mode-transition (suspension new-state - polling-k - message-handlers - '()) - _ - '() - '()) - (define inbound-messages - (map (match-lambda [(message-handler (ground-event-pattern tag evt) k) - (wrap-evt evt (lambda (v) (cons (ground-event-value tag v) k)))]) - message-handlers)) - (match-define (cons inbound-value inbound-continuation) - (apply sync - (wrap-evt (if polling-k always-evt never-evt) - (lambda (v) (cons (ground-event-value 'idle (void)) - (lambda (dummy) polling-k)))) - inbound-messages)) - (loop ((inbound-continuation inbound-value) new-state))] - [_ - (error 'ground-vm - "Outermost VM may not spawn new siblings or send or receive metamessages")])))) diff --git a/matrix/universe.rkt b/matrix/universe.rkt deleted file mode 100644 index b44d3cf..0000000 --- a/matrix/universe.rkt +++ /dev/null @@ -1,208 +0,0 @@ -#lang racket/base - -;; Compatibility: 2htdp/universe's big-bang expressed in terms of ground-vm and os-big-bang. - -(require racket/match) -(require racket/class) -(require racket/async-channel) -(require racket/gui/base) -(require 2htdp/image) -(require "os-big-bang.rkt") - -(provide (struct-out stop-with) - on-tick - on-key - on-release - on-mouse - stop-when - to-draw - on-draw - big-bang) - -(struct stop-with (w) #:transparent) - -;; This should be part of racket -(define (time-evt msecs) - (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) - -(define (replace-world w1 w2) - (cond - [(stop-with? w2) (transition (stop-with-w w2) - (send-message `(new-state ,(stop-with-w w2))) - (send-message 'stop))] - [else (transition w2 (send-message `(new-state ,w2)))])) - -(define (stop w n) - (transition w (unsubscribe n))) - -(struct ticker-state (counter interval limit) #:transparent) - -(define-syntax on-tick - (syntax-rules () - ((_ tick-expr) - (on-tick tick-expr 1/28)) - ((_ tick-expr rate-expr) - (on-tick tick-expr rate-expr 0)) - ((_ tick-expr rate-expr limit-expr) - (list - (subscribe 'ticker-handler - (message-handlers w - ['tick (replace-world w (tick-expr w))] - ['stop (stop w 'ticker-handler)])) - (spawn (os-big-bang (ticker-state 0 rate-expr limit-expr) - (subscribe 'stop-listener - (message-handlers ts - ['stop (transition ts - (unsubscribe 'stop-listener) - (unsubscribe 'ticker))])) - (let loop ((next-alarm-time 0)) - (subscribe 'ticker - (ground-message-handler - (and w (ticker-state counter interval limit)) - [((list 'timer-alarm next-alarm-time) - (time-evt next-alarm-time) - => now) - (if (and (positive? limit) (>= counter limit)) - (transition w (unsubscribe 'ticker)) - (transition (ticker-state (+ counter 1) interval limit) - (unsubscribe 'ticker) - (loop (+ now (* 1000 interval))) - (send-message 'tick)))]))))))))) - -(define-syntax-rule (on-key key-expr) - (subscribe 'key-handler - (message-handlers w - [`(key-down ,kev) (replace-world w (key-expr w kev))] - ['stop (stop w 'key-handler)]))) - -(define-syntax-rule (on-release release-expr) - (subscribe 'release-handler - (message-handlers w - [`(key-up ,kev) (replace-world w (release-expr w kev))] - ['stop (stop w 'release-handler)]))) - -(define-syntax-rule (on-mouse mouse-expr) - (subscribe 'mouse-handler - (message-handlers w - [`(mouse ,x ,y ,mev) (replace-world w (mouse-expr w x y mev))] - ['stop (stop w 'mouse-handler)]))) - -(define-syntax-rule (stop-when last-world?) - (subscribe 'stop-when-handler - (message-handlers w - [`(new-state ,_) (if (last-world? w) - (replace-world w (stop-with w)) - w)] - ['stop (stop w 'stop-when-handler)]))) - -(define-syntax-rule (on-draw render-expr) (to-draw render-expr)) - -(define-syntax-rule (to-draw render-expr) - (subscribe 'draw-handler - (message-handlers w - [`(new-state ,_) (transition w (send-message `(render ,(render-expr w))))] - ['stop (stop w 'draw-handler)]))) - -(define (ui-actions c:ui->world c:world->ui) - (list - (spawn (os-big-bang 'none - (subscribe 'inbound-relay - (ground-message-handler w - [('communication-from-ui - c:ui->world - => message) - (transition w (send-message message))])) - (subscribe 'stopper - (message-handlers w - ['stop (transition w - (send-meta-message - (lambda () - (async-channel-put c:world->ui 'stop))) - (unsubscribe 'inbound-relay) - (unsubscribe 'stopper))])))) - (subscribe 'renderer - (message-handlers w - [`(render ,scene) - (transition w - (send-meta-message (lambda () (async-channel-put c:world->ui `(render ,scene)))))] - ['stop (stop w 'renderer)])))) - -(define (make-key-event code) - (cond - [(char? code) (string code)] - [(symbol? code) (symbol->string code)])) - -;; Pinched almost without change from collects/2htdp/private/world.rkt -(define (mouse-event->parts e) - (define x (send e get-x)) - (define y (send e get-y)) - (list 'mouse x y - (cond [(send e button-down?) "button-down"] - [(send e button-up?) "button-up"] - [(send e dragging?) "drag"] - [(send e moving?) "move"] - [(send e entering?) "enter"] - [(send e leaving?) "leave"] - [else ; (send e get-event-type) - (let ([m (send e get-event-type)]) - (error 'on-mouse (format "Unknown event: ~a" m)))]))) - -(define universe-canvas% - (class canvas% - (init-field c:ui->world) - (super-new) - (define/override (on-event e) - (async-channel-put c:ui->world (mouse-event->parts e))) - (define/override (on-char e) - (async-channel-put c:ui->world - (match (make-key-event (send e get-key-code)) - ["release" `(key-up ,(make-key-event (send e get-key-release-code)))] - [other `(key-down ,other)]))))) - -(define (big-bang initial-state . initial-action) - (define c:ui->world (make-async-channel)) - (define c:world->ui (make-async-channel)) - - (define frame (new frame% - [label "os-big-bang universe"] - [width 500] - [height 300])) - (define image (empty-scene 200 200)) - (define canvas (new universe-canvas% - [c:ui->world c:ui->world] - [parent frame] - [paint-callback - (lambda (canvas dc) - (send image draw dc - 0 0 - 0 0 - (send frame get-width) (send frame get-height) - 0 0 - #f))])) - (send frame show #t) - - (thread (lambda () - (let loop () - (define v (async-channel-get c:world->ui)) - (match v - [`(render ,scene) - (set! image scene) - (send frame resize (image-width image) (image-height image)) - (send canvas refresh-now)] - [_ 'ignore]) - (loop)))) - (thread - (lambda () - (ground-vm (apply os-big-bang - initial-state - (ui-actions c:ui->world c:world->ui) - #;(spawn - (os-big-bang 'none - (subscribe 'echoer - (message-handlers w - [any - (transition w - (send-meta-message (lambda () - (write (list any '-> w)) - (newline))))])))) - initial-action)))))