syndicate-lang
/
racket-matrix-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Switch universe.rkt from os/os-big-bang to os2.

This commit is contained in:
Tony Garnock-Jones 2012-03-24 21:19:13 -04:00
parent 4246e5b217
commit 4c76dc29f1
1 changed files with 70 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

156
universe.rkt
View File

@ -6,7 +6,7 @@
(require racket/async-channel) (require racket/async-channel)
(require racket/gui/base) (require racket/gui/base)
(require 2htdp/image) (require 2htdp/image)
(require "os-big-bang.rkt") (require "os2.rkt")
(provide (struct-out stop-with) (provide (struct-out stop-with)
on-tick on-tick
@ -24,15 +24,15 @@
(define (time-evt msecs) (define (time-evt msecs)
(wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) (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) (define (replace-world w1 w2)
(cond (cond
[(stop-with? w2) (transition (stop-with-w w2) [(stop-with? w2) (transition (stop-with-w w2)
(send-message `(new-state ,(stop-with-w w2))) (broadcast `(new-state ,(stop-with-w w2)))
(send-message 'stop))] (broadcast 'stop))]
[else (transition w2 (send-message `(new-state ,w2)))])) [else (transition w2 (broadcast `(new-state ,w2)))]))
(define (stop w n)
(transition w (unsubscribe n)))
(struct ticker-state (counter interval limit) #:transparent) (struct ticker-state (counter interval limit) #:transparent)
@ -44,87 +44,68 @@
(on-tick tick-expr rate-expr 0)) (on-tick tick-expr rate-expr 0))
((_ tick-expr rate-expr limit-expr) ((_ tick-expr rate-expr limit-expr)
(list (list
(subscribe 'ticker-handler (role wild-sub
(message-handlers w #:state w
['tick (replace-world w (tick-expr w))] #:id id
['stop (stop w 'ticker-handler)])) ['tick (replace-world w (tick-expr w))])
(spawn (os-big-bang (ticker-state 0 rate-expr limit-expr) (spawn (transition (ticker-state 0 rate-expr limit-expr)
(subscribe 'stop-listener (role wild-sub
(message-handlers ts #:state ts
['stop (transition ts ['stop (transition ts (kill))])
(unsubscribe 'stop-listener) (let loop ((next-alarm-time 0))
(unsubscribe 'ticker))])) (role (topic-subscriber (time-evt next-alarm-time))
(let loop ((next-alarm-time 0)) #:state (and ts (ticker-state counter interval limit))
(subscribe 'ticker #:id id
(ground-message-handler [now
(and w (ticker-state counter interval limit)) (if (and (positive? limit) (>= counter limit))
[((list 'timer-alarm next-alarm-time) (transition ts (kill))
(time-evt next-alarm-time) (transition (ticker-state (+ counter 1) interval limit)
=> now) (delete-role id)
(if (and (positive? limit) (>= counter limit)) (loop (+ now (* 1000 interval)))
(transition w (unsubscribe 'ticker)) (broadcast 'tick)))]))))))))
(transition (ticker-state (+ counter 1) interval limit)
(unsubscribe 'ticker)
(loop (+ now (* 1000 interval)))
(send-message 'tick)))])))))))))
(define-syntax-rule (on-key key-expr) (define-syntax-rule (on-key key-expr)
(subscribe 'key-handler (role wild-sub
(message-handlers w #:state w
[`(key-down ,kev) (replace-world w (key-expr w kev))] [`(key-down ,kev) (replace-world w (key-expr w kev))]))
['stop (stop w 'key-handler)])))
(define-syntax-rule (on-release release-expr) (define-syntax-rule (on-release release-expr)
(subscribe 'release-handler (role wild-sub
(message-handlers w #:state w
[`(key-up ,kev) (replace-world w (release-expr w kev))] [`(key-up ,kev) (replace-world w (release-expr w kev))]))
['stop (stop w 'release-handler)])))
(define-syntax-rule (on-mouse mouse-expr) (define-syntax-rule (on-mouse mouse-expr)
(subscribe 'mouse-handler (role wild-sub
(message-handlers w #:state w
[`(mouse ,x ,y ,mev) (replace-world w (mouse-expr w x y mev))] [`(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?) (define-syntax-rule (stop-when last-world?)
(subscribe 'stop-when-handler (role wild-sub
(message-handlers w #:state w
[`(new-state ,_) (if (last-world? w) [`(new-state ,_) (if (last-world? w)
(replace-world w (stop-with w)) (replace-world w (stop-with w))
w)] w)]))
['stop (stop w 'stop-when-handler)])))
(define-syntax-rule (on-draw render-expr) (to-draw render-expr)) (define-syntax-rule (on-draw render-expr) (to-draw render-expr))
(define-syntax-rule (to-draw render-expr) (define-syntax-rule (to-draw render-expr)
(subscribe 'draw-handler (role wild-sub
(message-handlers w #:state w
[`(new-state ,_) (transition w (send-message `(render ,(render-expr w))))] [`(new-state ,_) (transition w (broadcast `(render ,(render-expr w))))]))
['stop (stop w 'draw-handler)])))
(define (ui-actions c:ui->world c:world->ui) (define (ui-actions c:ui->world c:world->ui)
(list (list
(spawn (os-big-bang 'none (role (topic-subscriber c:ui->world) #:state w)
(subscribe 'inbound-relay (role wild-sub
(ground-message-handler w #:state w
[('communication-from-ui ['stop
c:ui->world (async-channel-put c:world->ui 'stop)
=> message) (transition w (kill))])
(transition w (send-message message))])) (role wild-sub
(subscribe 'stopper #:state w
(message-handlers w [`(render ,scene)
['stop (transition w (async-channel-put c:world->ui `(render ,scene))
(send-meta-message w])))
(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) (define (make-key-event code)
(cond (cond
@ -190,18 +171,21 @@
(send canvas refresh-now)] (send canvas refresh-now)]
[_ 'ignore]) [_ 'ignore])
(loop)))) (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 (thread
(lambda () (lambda ()
(ground-vm (apply os-big-bang (ground-vm (transition initial-state
initial-state (ui-actions c:ui->world c:world->ui)
(ui-actions c:ui->world c:world->ui) (spawn (transition 'no-state
#;(spawn (error-listener (topic-publisher (wild)))
(os-big-bang 'none (error-listener (topic-subscriber (wild)))))
(subscribe 'echoer initial-action)))))
(message-handlers w
[any
(transition w
(send-meta-message (lambda ()
(write (list any '-> w))
(newline))))]))))
initial-action)))))