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 data/queue
lux/chaos) 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 #:methods gen:chaos
[(define (chaos-fps c) [(define (chaos-fps c)
(gui-fps c)) (gui-fps c))
(define (chaos-yield c e) (define (chaos-yield c e)
(yield e)) (yield e))
(define (chaos-inputs c) (define (chaos-inputs c)
(define eb (gui-events-box c)) (define eb (gui-events-sbox c))
(define new-q (make-queue)) (define new-q (make-queue))
(define q (unbox eb)) (define q (sbox-swap! eb new-q))
(set-box! eb new-q)
(in-queue q)) (in-queue q))
(define (chaos-output! c o) (define (chaos-output! c o)
(set-box! (gui-drawer c) o) (set-box! (gui-drawer c) o)
@ -36,17 +49,17 @@
#:mode [mode 'draw] #:mode [mode 'draw]
#:width [init-w 800] #:width [init-w 800]
#:height [init-h 600]) #:height [init-h 600])
(define events-box (box (make-queue))) (define events-box (sbox (make-queue)))
(define gframe% (define gframe%
(class frame% (class frame%
(define/override (on-size w h) (define/override (on-size w h)
(refresh!)) (refresh!))
(define/augment (on-close) (define/augment (on-close)
(enqueue! (unbox events-box) 'close)) (sbox-poke events-box (λ (q) (enqueue! q 'close))))
(define/override (on-subwindow-char w ke) (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) (define/override (on-subwindow-event w me)
(enqueue! (unbox events-box) me)) (sbox-poke events-box (λ (q) (enqueue! q me))))
(super-new))) (super-new)))
(define drawer (box void)) (define drawer (box void))

42
chaos/gui/val.rkt
View File

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