208 lines
6.1 KiB
Racket
208 lines
6.1 KiB
Racket
#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)))))
|