syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fullscreen big-bang

This commit is contained in:
Tony Garnock-Jones 2017-11-25 12:03:32 -05:00
parent 1dbab91ccc
commit 75093d0e1a
1 changed files with 32 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
racket/syndicate/big-bang.rkt
View File

@ -12,6 +12,7 @@
(struct-out mouse-event) (struct-out mouse-event)
(struct-out mouse-state) (struct-out mouse-state)
(struct-out active-window) (struct-out active-window)
(struct-out frame-dimensions)
update-window update-window
(all-from-out 2htdp/image)) (all-from-out 2htdp/image))
@ -41,6 +42,7 @@
(struct mouse-event (x y window type) #:transparent) (struct mouse-event (x y window type) #:transparent)
(struct mouse-state (x y window) #:transparent) (struct mouse-state (x y window) #:transparent)
(struct active-window (id) #:transparent) (struct active-window (id) #:transparent)
(struct frame-dimensions (width height) #:transparent)
(define (update-window id x y image #:z [z 0]) (define (update-window id x y image #:z [z 0])
(patch-seq (retract (outbound (window id ? ? ? ?))) (patch-seq (retract (outbound (window id ? ? ? ?)))
@ -48,7 +50,7 @@
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(struct bb (proc windows inbound outbound halted? x y) #:transparent) (struct bb (proc windows inbound outbound halted? x y width height) #:transparent)
(define window-projection (?! (window ? ? ? ? ?))) (define window-projection (?! (window ? ? ? ? ?)))
@ -132,16 +134,18 @@
(patch-seq (retract (active-window ?)) (patch-seq (retract (active-window ?))
(assert (active-window active-id)))) (assert (active-window active-id))))
(define-syntax-rule (big-bang-dataspace* boot-actions extra-clause ...) (define-syntax-rule (big-bang-dataspace* width height boot-actions extra-clause ...)
(let-values (((proc initial-transition _initial-assertions-always-empty) (let-values (((proc initial-transition _initial-assertions-always-empty)
(actor->process+transition/assertions (dataspace-actor boot-actions)))) (actor->process+transition/assertions (dataspace-actor boot-actions))))
(big-bang (interpret-actions (bb proc (big-bang (interpret-actions (bb proc
'() '()
'() (list (assert (frame-dimensions width height)))
'() '()
#f #f
0 0
0) 0
width
height)
initial-transition initial-transition
#t) #t)
(on-tick (lambda (b) (on-tick (lambda (b)
@ -161,27 +165,43 @@
(stop-when bb-halted?) (stop-when bb-halted?)
extra-clause ...))) extra-clause ...)))
(define-syntax-rule (big-bang-dataspace** width height exit? boot-actions extra-clause ...) (define-syntax-rule (big-bang-dataspace** fullscreen? width height exit? boot-actions
extra-clause ...)
(begin (begin
(if (and width height) (cond
(big-bang-dataspace* boot-actions (to-draw render width height) extra-clause ...) [fullscreen?
(big-bang-dataspace* boot-actions (to-draw render) extra-clause ...)) (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)))) (when exit? (exit 0))))
(define ((big-bang-dataspace #:width [width #f] (define ((big-bang-dataspace #:width [width #f]
#:height [height #f] #:height [height #f]
#:exit? [exit? #t]) #:exit? [exit? #t]
#:fullscreen? [fullscreen? #f])
. boot-actions) . boot-actions)
(big-bang-dataspace** width height exit? boot-actions)) (big-bang-dataspace** fullscreen? width height exit? boot-actions))
(define ((big-bang-dataspace/universe #:width [width #f] (define ((big-bang-dataspace/universe #:width [width #f]
#:height [height #f] #:height [height #f]
#:exit? [exit? #t] #:exit? [exit? #t]
#:register [ip LOCALHOST] #:register [ip LOCALHOST]
#:port [port-number SQPORT] #:port [port-number SQPORT]
#:name [world-name (gensym 'syndicate)]) #:name [world-name (gensym 'syndicate)]
#:fullscreen? [fullscreen? #f])
. boot-actions) . boot-actions)
(big-bang-dataspace** width height exit? boot-actions (big-bang-dataspace** fullscreen? width height exit? boot-actions
(on-receive (lambda (b sexps) (on-receive (lambda (b sexps)
(inject b (for/list ((m sexps)) (message (from-server m)))))) (inject b (for/list ((m sexps)) (message (from-server m))))))
(register ip) (register ip)