From 3415e910f891213eeeab31c9648fb3affa76ffa1 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 13 Jan 2012 23:09:23 -0500 Subject: [PATCH] Crude emulation of 2htdp/universe's big-bang using os-big-bang. --- universe.rkt | 204 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 204 insertions(+) create mode 100644 universe.rkt diff --git a/universe.rkt b/universe.rkt new file mode 100644 index 0000000..5d505f5 --- /dev/null +++ b/universe.rkt @@ -0,0 +1,204 @@ +#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 + (meta-message-handler + (and w (ticker-state counter interval limit)) + [((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 + (meta-message-handler w + [(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)))))