big-bang example
This commit is contained in:
Tony Garnock-Jones
parent
fc971868d9
commit
5eb155cc11
|
|
@ -0,0 +1,177 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide big-bang-world
|
||||
big-bang-universe
|
||||
(struct-out window)
|
||||
(struct-out to-server)
|
||||
(struct-out from-server)
|
||||
(struct-out tick-event)
|
||||
(struct-out key-event)
|
||||
(struct-out pad-event)
|
||||
(struct-out release-event)
|
||||
(struct-out mouse-event)
|
||||
(struct-out mouse-state)
|
||||
(struct-out active-window)
|
||||
update-window
|
||||
(all-from-out 2htdp/image))
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require 2htdp/image)
|
||||
(require (except-in 2htdp/universe
|
||||
key-event?
|
||||
pad-event?
|
||||
mouse-event?))
|
||||
(require (only-in 2htdp/private/check-aux SQPORT))
|
||||
(require (only-in racket/list flatten))
|
||||
|
||||
(require "main.rkt")
|
||||
(require "route.rkt")
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(struct window (id x y z image) #:transparent)
|
||||
|
||||
(struct to-server (message) #:transparent)
|
||||
(struct from-server (message) #:transparent)
|
||||
(struct tick-event () #:transparent)
|
||||
(struct key-event (key window) #:transparent)
|
||||
(struct pad-event (key window) #:transparent)
|
||||
(struct release-event (key window) #:transparent)
|
||||
(struct mouse-event (x y window type) #:transparent)
|
||||
(struct mouse-state (x y window) #:transparent)
|
||||
(struct active-window (id) #:transparent)
|
||||
|
||||
(define (update-window id x y image #:z [z 0])
|
||||
(patch-seq (retract (window id ? ? ? ?) #:meta-level 1)
|
||||
(assert (window id x y z image) #:meta-level 1)))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(struct bb (world windows inbound outbound halted? x y) #:transparent)
|
||||
|
||||
(define window-projection (compile-projection (?! (window ? ? ? ? ?))))
|
||||
|
||||
(define (inject b es)
|
||||
(interpret-actions (struct-copy bb b [inbound (append (bb-inbound b)
|
||||
es
|
||||
(list (update-active-window
|
||||
(find-active-window b))))])
|
||||
#f
|
||||
#t))
|
||||
|
||||
(define (incorporate-patch b p)
|
||||
(define-values (added removed) (patch-project/set/single p window-projection))
|
||||
(struct-copy bb b
|
||||
[windows (sort (set->list (set-union added
|
||||
(set-subtract (list->set (bb-windows b))
|
||||
removed)))
|
||||
(lambda (w1 w2) (< (window-z w1) (window-z w2))))]
|
||||
[halted? (or (and (bb-halted? b)
|
||||
(not (matcher-match-value (patch-removed p) 'stop #f)))
|
||||
(matcher-match-value (patch-added p) 'stop #f))]))
|
||||
|
||||
(define (deliver b e)
|
||||
(clean-transition (world-handle-event e (bb-world b))))
|
||||
|
||||
(define (interpret-actions b txn need-poll?)
|
||||
(match txn
|
||||
[#f ;; inert
|
||||
(match (bb-inbound b)
|
||||
['()
|
||||
(if need-poll?
|
||||
(interpret-actions b (deliver b #f) #f)
|
||||
(let ((outbound (reverse (bb-outbound b))))
|
||||
(if (null? outbound)
|
||||
b
|
||||
(make-package (struct-copy bb b [outbound '()]) outbound))))]
|
||||
[(cons e rest)
|
||||
(let ((b (struct-copy bb b [inbound rest])))
|
||||
(interpret-actions b (deliver b e) #t))])]
|
||||
[(transition new-world actions)
|
||||
(let process-actions ((b (struct-copy bb b [world new-world])) (actions actions))
|
||||
(match actions
|
||||
['() (interpret-actions b #f #t)]
|
||||
[(cons a actions)
|
||||
(process-actions (match a
|
||||
[(? patch? p)
|
||||
(incorporate-patch b p)]
|
||||
[(message (to-server sexp))
|
||||
(struct-copy bb b
|
||||
[outbound (cons sexp (bb-outbound b))])]
|
||||
[_ b])
|
||||
actions)]))]))
|
||||
|
||||
(define (inside? mx my x y image)
|
||||
(and (>= mx x)
|
||||
(>= my y)
|
||||
(< (- mx x) (image-width image))
|
||||
(< (- my y) (image-height image))))
|
||||
|
||||
(define (find-active-window b)
|
||||
(define mx (bb-x b))
|
||||
(define my (bb-y b))
|
||||
(let loop ((ws (bb-windows b)))
|
||||
(match ws
|
||||
['() #f]
|
||||
[(cons (window id x y _ image) ws)
|
||||
(if (inside? mx my x y image) id (loop ws))])))
|
||||
|
||||
(define (render b)
|
||||
(for/fold [(scene empty-image)] [(w (bb-windows b))]
|
||||
(match-define (window _ x y z image) w)
|
||||
(overlay/xy scene x y image)))
|
||||
|
||||
(define (update-active-window active-id)
|
||||
(patch-seq (retract (active-window ?))
|
||||
(assert (active-window active-id))))
|
||||
|
||||
(define-syntax-rule (big-bang-world* boot-actions extra-clause ...)
|
||||
(big-bang (interpret-actions (bb (make-world boot-actions)
|
||||
'()
|
||||
'()
|
||||
'()
|
||||
#f
|
||||
0
|
||||
0)
|
||||
#f
|
||||
#t)
|
||||
(on-tick (lambda (b)
|
||||
(inject b (list (message (tick-event))))))
|
||||
(on-key (lambda (b k)
|
||||
(inject b (list (message (key-event k (find-active-window b)))))))
|
||||
;; (on-pad (lambda (b p)
|
||||
;; (inject b (list (message (pad-event p (find-active-window b)))))))
|
||||
(on-release (lambda (b k)
|
||||
(inject b (list (message (release-event k (find-active-window b)))))))
|
||||
(on-mouse (lambda (b0 x y e)
|
||||
(define b (struct-copy bb b0 [x x] [y y]))
|
||||
(define active-id (find-active-window b))
|
||||
(inject b (list (patch-seq (retract (mouse-state ? ? ?))
|
||||
(assert (mouse-state x y active-id)))
|
||||
(message (mouse-event x y active-id e))))))
|
||||
(stop-when bb-halted?)
|
||||
extra-clause ...))
|
||||
|
||||
(define-syntax-rule (big-bang-world** width height boot-actions extra-clause ...)
|
||||
(if (and width height)
|
||||
(big-bang-world* boot-actions (to-draw render width height) extra-clause ...)
|
||||
(big-bang-world* boot-actions (to-draw render) extra-clause ...)))
|
||||
|
||||
(define (big-bang-world #:width [width #f]
|
||||
#:height [height #f]
|
||||
. boot-actions)
|
||||
(big-bang-world** width height boot-actions))
|
||||
|
||||
(define (big-bang-universe #:width [width #f]
|
||||
#:height [height #f]
|
||||
#:register [ip LOCALHOST]
|
||||
#:port [port-number SQPORT]
|
||||
#:name [world-name (gensym 'prospect)]
|
||||
. boot-actions)
|
||||
(big-bang-world** width height boot-actions
|
||||
(on-receive (lambda (b sexps)
|
||||
(inject b (for/list ((m sexps)) (message (from-server m))))))
|
||||
(register ip)
|
||||
(port port-number)
|
||||
(name world-name)))
|
||||
|
|
@ -0,0 +1,71 @@
|
|||
#lang racket
|
||||
|
||||
(require "../main.rkt")
|
||||
(require "../big-bang.rkt")
|
||||
|
||||
(define (button #:background [background "grey"]
|
||||
#:foreground [foreground "white"]
|
||||
#:font-size [font-size 22]
|
||||
name x y label callback)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(message (at-meta (mouse-event _ _ _ "button-down"))) (transition s (callback))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(let ((label-image (text label font-size foreground)))
|
||||
(update-window name x y
|
||||
(overlay label-image
|
||||
(rectangle (+ (image-width label-image) 20)
|
||||
(+ (image-height label-image) 20)
|
||||
"solid"
|
||||
background))))
|
||||
(sub (mouse-event ? ? name ?) #:meta-level 1)))
|
||||
|
||||
(define (draggable-shape name orig-x orig-y image)
|
||||
(struct idle (ticks x y) #:transparent)
|
||||
(struct dragging (dx dy) #:transparent)
|
||||
(define (move-to x y) (update-window name x y image #:z 10))
|
||||
(define (mouse-sub active-pat)
|
||||
(patch-seq (unsub (mouse-event ? ? ? ?) #:meta-level 1)
|
||||
(sub (mouse-event ? ? active-pat ?) #:meta-level 1)))
|
||||
(spawn (match-lambda**
|
||||
[((message (at-meta (tick-event))) (idle ticks bx by))
|
||||
(define new-ticks (+ ticks 1))
|
||||
(define displacement (* (cos (* new-ticks 10 1/180 pi)) 4))
|
||||
(define new-y (+ by displacement))
|
||||
(transition (idle new-ticks bx new-y)
|
||||
(move-to bx new-y))]
|
||||
[((message (at-meta (mouse-event mx my _ "button-down"))) (idle _ bx by))
|
||||
(transition (dragging (- mx bx) (- my by)) (mouse-sub ?))]
|
||||
[((message (at-meta (mouse-event mx my _ "drag"))) (dragging dx dy))
|
||||
(transition (dragging dx dy) (move-to (- mx dx) (- my dy)))]
|
||||
[((message (at-meta (mouse-event mx my _ (or "leave" "button-up")))) (dragging dx dy))
|
||||
(transition (idle 0 (- mx dx) (- my dy))
|
||||
(list (move-to (- mx dx) (- my dy))
|
||||
(mouse-sub name)))]
|
||||
[(_ _) #f])
|
||||
(idle 0 orig-x orig-y)
|
||||
(sub (tick-event) #:meta-level 1)
|
||||
(mouse-sub name)
|
||||
(move-to orig-x orig-y)))
|
||||
|
||||
(big-bang-world #:width 640
|
||||
#:height 480
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(? patch? p)
|
||||
(define-values (in out)
|
||||
(patch-project/set/single p
|
||||
(compile-projection
|
||||
(at-meta (?! (active-window ?))))))
|
||||
(log-info "~v" in)
|
||||
#f]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(sub (active-window ?) #:meta-level 1))
|
||||
(button #:background "red" 'stop-button 0 0 "Exit"
|
||||
(lambda () (assert 'stop #:meta-level 1)))
|
||||
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
|
||||
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")))
|
||||
|
||||
(exit 0)
|
||||
Loading…
Reference in New Issue