racket-matrix-2012/universe.rkt

#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 (except-in racket/gui/base yield make-color make-pen))
(require 2htdp/image)
(require "os2.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 wild-sub (topic-subscriber (wild)))
(define (broadcast message) (send-message message))

(define (replace-world w1 w2)
  (cond
   [(stop-with? w2) (transition (stop-with-w w2)
				(broadcast `(new-state ,(stop-with-w w2)))
				(broadcast 'stop))]
   [else (transition w2 (broadcast `(new-state ,w2)))]))

(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
      (role wild-sub
	#:state w
	['tick (replace-world w (tick-expr w))])
      (spawn (transition (ticker-state 0 rate-expr limit-expr)
	       (role wild-sub
		 #:state ts
		 ['stop (transition ts (quit))])
	       (let loop ((next-alarm-time 0))
		 (role (topic-subscriber (cons (time-evt next-alarm-time) (wild)))
		   #:name 'tick-sequence
		   #:state (and ts (ticker-state counter interval limit))
		   [(cons _ now)
		    (if (and (positive? limit) (>= counter limit))
			(transition ts (quit))
			(transition (ticker-state (+ counter 1) interval limit)
			  (delete-role 'tick-sequence)
			  (loop (+ now (* 1000 interval)))
			  (broadcast 'tick)))]))))))))

(define-syntax-rule (on-key key-expr)
  (role wild-sub
    #:state w
    [`(key-down ,kev) (replace-world w (key-expr w kev))]))

(define-syntax-rule (on-release release-expr)
  (role wild-sub
    #:state w
    [`(key-up ,kev) (replace-world w (release-expr w kev))]))

(define-syntax-rule (on-mouse mouse-expr)
  (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?)
  (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)
  (role wild-sub
    #:state w
    [`(new-state ,_) (transition w (broadcast `(render ,(render-expr w))))]))

(define (ui-actions c:ui->world c:world->ui)
  (list 
   (role (topic-subscriber (cons c:ui->world (wild)))
     #:state w
     [(cons _ e)
      (transition w (send-message e))])
   (role wild-sub
     #:state w
     ['stop
      (async-channel-put c:world->ui 'stop)
      (transition w (quit))])
   (role wild-sub
     #:state w
     [`(render ,scene)
      (async-channel-put c:world->ui `(render ,scene))
      w])))

(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))))

  (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 (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)))))