From 4c76dc29f1e605bd9b8cd2c11ad7184c71d11f12 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 24 Mar 2012 21:19:13 -0400 Subject: [PATCH] Switch universe.rkt from os/os-big-bang to os2. --- universe.rkt | 156 +++++++++++++++++++++++---------------------------- 1 file changed, 70 insertions(+), 86 deletions(-) diff --git a/universe.rkt b/universe.rkt index 871b69a..47be377 100644 --- a/universe.rkt +++ b/universe.rkt @@ -6,7 +6,7 @@ (require racket/async-channel) (require racket/gui/base) (require 2htdp/image) -(require "os-big-bang.rkt") +(require "os2.rkt") (provide (struct-out stop-with) on-tick @@ -24,15 +24,15 @@ (define (time-evt msecs) (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) +(define wild-sub (topic-subscriber (wild))) +(define (broadcast message) (send-message (topic-publisher 'universe) message)) + (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))) + (broadcast `(new-state ,(stop-with-w w2))) + (broadcast 'stop))] + [else (transition w2 (broadcast `(new-state ,w2)))])) (struct ticker-state (counter interval limit) #:transparent) @@ -44,87 +44,68 @@ (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)))]))))))))) + (role wild-sub + #:state w + #:id id + ['tick (replace-world w (tick-expr w))]) + (spawn (transition (ticker-state 0 rate-expr limit-expr) + (role wild-sub + #:state ts + ['stop (transition ts (kill))]) + (let loop ((next-alarm-time 0)) + (role (topic-subscriber (time-evt next-alarm-time)) + #:state (and ts (ticker-state counter interval limit)) + #:id id + [now + (if (and (positive? limit) (>= counter limit)) + (transition ts (kill)) + (transition (ticker-state (+ counter 1) interval limit) + (delete-role id) + (loop (+ now (* 1000 interval))) + (broadcast '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)]))) + (role wild-sub + #:state w + [`(key-down ,kev) (replace-world w (key-expr w kev))])) (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)]))) + (role wild-sub + #:state w + [`(key-up ,kev) (replace-world w (release-expr w kev))])) (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)]))) + (role wild-sub + #:state w + [`(mouse ,x ,y ,mev) (replace-world w (mouse-expr w x y mev))])) (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)]))) + (role wild-sub + #:state w + [`(new-state ,_) (if (last-world? w) + (replace-world w (stop-with w)) + w)])) (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)]))) + (role wild-sub + #:state w + [`(new-state ,_) (transition w (broadcast `(render ,(render-expr w))))])) (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)])))) + (role (topic-subscriber c:ui->world) #:state w) + (role wild-sub + #:state w + ['stop + (async-channel-put c:world->ui 'stop) + (transition w (kill))]) + (role wild-sub + #:state w + [`(render ,scene) + (async-channel-put c:world->ui `(render ,scene)) + w]))) (define (make-key-event code) (cond @@ -190,18 +171,21 @@ (send canvas refresh-now)] [_ 'ignore]) (loop)))) + + (define (error-listener topic) + (role topic + #:state w + #:topic flow + #:reason reason + #:on-absence (begin (when reason + (write (list flow '--> reason)) + (newline)) + w))) (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))))) + (ground-vm (transition initial-state + (ui-actions c:ui->world c:world->ui) + (spawn (transition 'no-state + (error-listener (topic-publisher (wild))) + (error-listener (topic-subscriber (wild))))) + initial-action)))))