210 lines
8.8 KiB
Racket
210 lines
8.8 KiB
Racket
#lang racket/base
|
|
|
|
(provide big-bang-dataspace
|
|
big-bang-dataspace/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)
|
|
(struct-out frame-dimensions)
|
|
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 "trie.rkt")
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(struct window (id x y z image) #:transparent) ;; image must be sealed
|
|
|
|
(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)
|
|
(struct frame-dimensions (width height) #:transparent)
|
|
|
|
(define (update-window id x y image #:z [z 0])
|
|
(patch-seq (retract (outbound (window id ? ? ? ?)))
|
|
(assert (outbound (window id x y z (seal image))))))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(struct bb (proc windows inbound outbound halted? x y width height) #:transparent)
|
|
|
|
(define window-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? (if (or (and (bb-halted? b)
|
|
(not (trie-lookup (patch-removed p) 'stop #f)))
|
|
(trie-lookup (patch-added p) 'stop #f))
|
|
#t
|
|
#f)]))
|
|
|
|
(define (deliver b e)
|
|
(clean-transition ((process-behavior (bb-proc b)) e (process-state (bb-proc 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))])]
|
|
[(<quit> _ _)
|
|
(struct-copy bb b [halted? #t])]
|
|
[(transition new-state actions)
|
|
(let process-actions ((b (struct-copy bb b
|
|
[proc (update-process-state (bb-proc b) new-state)]))
|
|
(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 _ (seal 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 (seal 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-dataspace* width height boot-actions extra-clause ...)
|
|
(let-values (((proc initial-transition _initial-assertions-always-empty)
|
|
(actor->process+transition/assertions (dataspace-actor boot-actions))))
|
|
(big-bang (interpret-actions (bb proc
|
|
'()
|
|
(list (assert (frame-dimensions width height)))
|
|
'()
|
|
#f
|
|
0
|
|
0
|
|
width
|
|
height)
|
|
initial-transition
|
|
#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-dataspace** fullscreen? width height exit? boot-actions
|
|
extra-clause ...)
|
|
(begin
|
|
(cond
|
|
[fullscreen?
|
|
(big-bang-dataspace* width height boot-actions (to-draw render)
|
|
(display-mode 'fullscreen
|
|
(lambda (b w h)
|
|
(inject (struct-copy bb b [width w] [height h])
|
|
(list
|
|
(patch-seq (retract (frame-dimensions ? ?))
|
|
(assert (frame-dimensions w h)))))))
|
|
extra-clause ...)]
|
|
[(and width height)
|
|
(big-bang-dataspace* width height boot-actions (to-draw render width height)
|
|
extra-clause ...)]
|
|
[else
|
|
(big-bang-dataspace* width height boot-actions (to-draw render)
|
|
extra-clause ...)])
|
|
(when exit? (exit 0))))
|
|
|
|
(define ((big-bang-dataspace #:width [width #f]
|
|
#:height [height #f]
|
|
#:exit? [exit? #t]
|
|
#:fullscreen? [fullscreen? #f])
|
|
. boot-actions)
|
|
(big-bang-dataspace** fullscreen? width height exit? boot-actions))
|
|
|
|
(define ((big-bang-dataspace/universe #:width [width #f]
|
|
#:height [height #f]
|
|
#:exit? [exit? #t]
|
|
#:register [ip LOCALHOST]
|
|
#:port [port-number SQPORT]
|
|
#:name [world-name (gensym 'syndicate)]
|
|
#:fullscreen? [fullscreen? #f])
|
|
. boot-actions)
|
|
(big-bang-dataspace** fullscreen? width height exit? 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)))
|