misc-deps
/
lux
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Safety and performance

This commit is contained in:
Jay McCarthy 2014-11-20 00:53:29 -05:00
parent 7a4ce679cd
commit 6303cec7f0
2 changed files with 43 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
chaos/gui.rkt
View File

@ -6,17 +6,30 @@
data/queue
lux/chaos)
(struct gui (depth-box events-box fps drawer frame refresh!)
(struct *sbox (sema box))
(define (sbox v)
(*sbox (make-semaphore 1) (box v)))
(define (sbox-swap! sb new)
(match-define (*sbox sema b) sb)
(call-with-semaphore sema
(λ ()
(begin0 (unbox b)
(set-box! b new)))))
(define (sbox-poke sb f)
(match-define (*sbox sema b) sb)
(call-with-semaphore sema
(λ () (f (unbox b)))))
(struct gui (depth-box events-sbox fps drawer frame refresh!)
#:methods gen:chaos
[(define (chaos-fps c)
(gui-fps c))
(define (chaos-yield c e)
(yield e))
(define (chaos-inputs c)
(define eb (gui-events-box c))
(define eb (gui-events-sbox c))
(define new-q (make-queue))
(define q (unbox eb))
(set-box! eb new-q)
(define q (sbox-swap! eb new-q))
(in-queue q))
(define (chaos-output! c o)
(set-box! (gui-drawer c) o)
@ -36,17 +49,17 @@
#:mode [mode 'draw]
#:width [init-w 800]
#:height [init-h 600])
(define events-box (box (make-queue)))
(define events-box (sbox (make-queue)))
(define gframe%
(class frame%
(define/override (on-size w h)
(refresh!))
(define/augment (on-close)
(enqueue! (unbox events-box) 'close))
(sbox-poke events-box (λ (q) (enqueue! q 'close))))
(define/override (on-subwindow-char w ke)
(enqueue! (unbox events-box) ke))
(sbox-poke events-box (λ (q) (enqueue! q ke))))
(define/override (on-subwindow-event w me)
(enqueue! (unbox events-box) me))
(sbox-poke events-box (λ (q) (enqueue! q me))))
(super-new)))
(define drawer (box void))

42
chaos/gui/val.rkt
View File

@ -6,7 +6,7 @@
pict/convert
lux/chaos)
(struct gui/val (scale? g)
(struct gui/val (scale? g [last #:mutable])
#:methods gen:chaos
[(define/generic super-fps chaos-fps)
(define/generic super-yield chaos-yield)
@ -21,31 +21,33 @@
(define (chaos-inputs c)
(super-inputs (gui/val-g c)))
(define (chaos-output! c o)
(define p (pict-convert o))
(super-output!
(gui/val-g c)
(λ (w h dc)
(parameterize ([dc-for-text-size dc])
(send dc set-background "black")
(send dc clear)
(define sp
(if (gui/val-scale? c)
(scale-to-fit p w h)
p))
(define spw (pict-width sp))
(define left (/ (- w spw) 2))
(define sph (pict-height sp))
(define top (/ (- h sph) 2))
(send dc set-brush "white" 'solid)
(send dc draw-rectangle left top spw sph)
(draw-pict sp dc left top)))))
(unless (eq? o (gui/val-last c))
(set-gui/val-last! c o)
(define p (pict-convert o))
(super-output!
(gui/val-g c)
(λ (w h dc)
(parameterize ([dc-for-text-size dc])
(send dc set-background "black")
(send dc clear)
(define sp
(if (gui/val-scale? c)
(scale-to-fit p w h)
p))
(define spw (pict-width sp))
(define left (/ (- w spw) 2))
(define sph (pict-height sp))
(define top (/ (- h sph) 2))
(send dc set-brush "white" 'solid)
(send dc draw-rectangle left top spw sph)
(draw-pict sp dc left top))))))
(define (chaos-label! c l)
(super-label! (gui/val-g c) l))
(define (chaos-swap! c t)
(super-swap! (gui/val-g c) t))])
(define (make-gui/value g #:scale? [scale? #t])
(gui/val scale? g))
(gui/val scale? g #f))
(provide
(contract-out
[make-gui/value