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

Various beautifications

This commit is contained in:
Jay McCarthy 2014-11-20 13:31:02 -08:00
parent b760c9fd1b
commit bb1567f481
4 changed files with 105 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
chaos/gui/val.rkt
View File

@ -1,57 +1,37 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/generic racket/draw
racket/contract/base racket/contract/base
pict pict
pict/convert pict/convert)
lux/chaos)
(struct gui/val (scale? g [last #:mutable]) (define (make-gui/val #:scale? [scale? #t])
#:methods gen:chaos (define last-val #f)
[(define/generic super-fps chaos-fps) (define (output-val o)
(define/generic super-yield chaos-yield) (unless (eq? o last-val)
(define/generic super-event chaos-event) (set! last-val o)
(define/generic super-output! chaos-output!) (define p (pict-convert o))
(define/generic super-label! chaos-label!) (λ (w h dc)
(define/generic super-swap! chaos-swap!) (parameterize ([dc-for-text-size dc])
(define (chaos-fps c) (send dc set-background "black")
(super-fps (gui/val-g c))) (send dc clear)
(define (chaos-yield c e) (define sp
(super-yield (gui/val-g c) e)) (if scale?
(define (chaos-event c) (scale-to-fit p w h)
(super-event (gui/val-g c))) p))
;; xxx change this to be a helper for word's output creation (define spw (pict-width sp))
(define (chaos-output! c o) (define left (/ (- w spw) 2))
(unless (eq? o (gui/val-last c)) (define sph (pict-height sp))
(set-gui/val-last! c o) (define top (/ (- h sph) 2))
(define p (pict-convert o)) (send dc set-brush "white" 'solid)
(super-output! (send dc draw-rectangle left top spw sph)
(gui/val-g c) (draw-pict sp dc left top)))))
(λ (w h dc) output-val)
(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 #f))
(provide (provide
(contract-out (contract-out
[make-gui/value [make-gui/val
(->* (chaos?) (->* () (#:scale? boolean?)
(#:scale? boolean?) (-> pict-convertible?
chaos?)])) (-> real? real? (is-a?/c dc<%>)
any)))]))

58
examples/spin.rkt
View File

@ -11,35 +11,32 @@
(define COLORS (define COLORS
'("red" "orange" "yellow" "green" "blue" "indigo" "violet")) '("red" "orange" "yellow" "green" "blue" "indigo" "violet"))
(struct spin (layer ks ms color frame) (struct spin (layer color frame x y)
#:methods gen:word #:methods gen:word
[(define (word-label s ft) [(define (word-label s ft)
(lux-standard-label "Spin!" ft)) (lux-standard-label "Spin!" ft))
(define (word-event w e) (define (word-event w e)
;; xxx remove mutation (match-define (spin layer color f x y) w)
(match-define (spin layer ks ms color f) w) (cond
(define closed? #f) [(or (eq? e 'close)
(match e (and (key-event? e)
['close (eq? (send e get-key-code) 'escape)))
(set! closed? #t)] #f]
[(? mouse-event? me) [(and (key-event? e)
(mouse-state-update! ms me)] (eq? (send e get-key-code) #\space))
[(? key-event? ke) (spin layer (fxmodulo (fx+ 1 color) (length COLORS)) f x y)]
(key-state-update! ks ke)]) [(mouse-event? e)
(when (key-state-set?! ks #\space) (spin layer color f
(set! color (fxmodulo (fx+ 1 color) (length COLORS)))) (send e get-x)
(when (key-state-set?! ks #\return) (send e get-y))]
(spin-it! (add1 layer))) [(and (key-event? e)
(match (or closed? (eq? (send e get-key-code) #\return))
(key-state-set?! ks 'escape)) (spin-it (add1 layer))
[#t w]
#f] [else
[#f w]))
(spin layer ks ms color f)]))
(define (word-output w) (define (word-output w)
(match-define (spin layer ks ms color f) w) (match-define (spin layer color f x y) w)
(define x (mouse-state-x ms))
(define y (mouse-state-y ms))
(lambda (width height dc) (lambda (width height dc)
(send dc set-background (list-ref COLORS color)) (send dc set-background (list-ref COLORS color))
(send dc clear) (send dc clear)
@ -47,19 +44,16 @@
(send dc set-origin x y) (send dc set-origin x y)
(send dc draw-text (format "~a: Spinning!" layer) 0 0))) (send dc draw-text (format "~a: Spinning!" layer) 0 0)))
(define (word-tick w) (define (word-tick w)
(match-define (spin layer ks ms color f) w) (match-define (spin layer color f x y) w)
(spin layer ks ms color (fxmodulo (fx+ f 1) 360)))]) (spin layer color (fxmodulo (fx+ f 1) 360) x y))])
(define (spin-it! layer) (define (spin-it layer)
(define s (define s
(spin layer (spin layer 0 0 0 0))
(make-key-state)
(make-mouse-state)
0 0))
(fiat-lux s)) (fiat-lux s))
(module+ main (module+ main
(call-with-chaos (call-with-chaos
(make-gui 60.0) (make-gui 60.0)
(λ () (λ ()
(spin-it! 0)))) (spin-it 0))))

52
examples/val-demo.rkt
View File

@ -7,47 +7,43 @@
(prefix-in image: 2htdp/image) (prefix-in image: 2htdp/image)
lux lux
lux/chaos/gui lux/chaos/gui
lux/chaos/gui/val) lux/chaos/gui/val
lux/chaos/gui/key)
(define MODES (define MODES
'(pict image)) '(pict image))
(struct demo (struct demo
(mode) (g/v mode)
#:methods gen:word #:methods gen:word
[(define (word-label s ft) [(define (word-label s ft)
(lux-standard-label "Values" ft)) (lux-standard-label "Values" ft))
(define (word-output w) (define (word-output w)
(match-define (demo mode-n) w) (match-define (demo g/v mode-n) w)
(match (list-ref MODES mode-n) (g/v
['pict (match (list-ref MODES mode-n)
(pict:arrowhead 30 0)] ['pict
['image (pict:arrowhead 30 0)]
(image:add-line ['image
(image:rectangle 100 100 "solid" "darkolivegreen") (image:add-line
25 25 75 75 (image:rectangle 100 100 "solid" "darkolivegreen")
(image:make-pen "goldenrod" 30 "solid" "round" "round"))])) 25 25 75 75
(image:make-pen "goldenrod" 30 "solid" "round" "round"))])))
(define (word-event w e) (define (word-event w e)
;; xxx remove mutation (match-define (demo g/v mode-n) w)
(match-define (demo mode-n) w)
(define closed? #f) (define closed? #f)
(match e (cond
['close [(eq? e 'close)
(set! closed? #t)] #f]
[(? (λ (x) (is-a? x key-event%)) ke) [(and (key-event? e)
(unless (eq? 'release (send ke get-key-code)) (not (eq? 'release (send e get-key-code))))
(set! mode-n (fxmodulo (fx+ 1 mode-n) (length MODES))))] (demo g/v (fxmodulo (fx+ 1 mode-n) (length MODES)))]
[_ [else
(void)]) (demo g/v mode-n)]))
(match closed?
[#t
#f]
[#f
(demo mode-n)]))
(define (word-tick w) (define (word-tick w)
w)]) w)])
(module+ main (module+ main
(call-with-chaos (call-with-chaos
(make-gui/value (make-gui 60.0)) (make-gui 60.0)
(λ () (fiat-lux (demo 0))))) (λ () (fiat-lux (demo (make-gui/val) 0)))))

55
word.rkt
View File

@ -49,45 +49,42 @@
(define (factum-fiat-lux c w) (define (factum-fiat-lux c w)
(define fps (chaos-fps c)) (define fps (chaos-fps c))
(define time-incr (fl* (fl/ 1.0 fps) 1000.0)) (define time-incr (fl* (fl/ 1.0 fps) 1000.0))
(define (update-word w make-next-tick-evt f)
(define start-time (current-inexact-milliseconds))
(define new-w (f w))
(match new-w
[#f
(word-return w)]
[_
(chaos-output! c (word-output w))
(define end-time (current-inexact-milliseconds))
(define frame-time (fl- end-time start-time))
(define new-label
(word-label new-w frame-time))
(chaos-label! c new-label)
(define next-tick-evt (make-next-tick-evt start-time))
(body next-tick-evt new-w)]))
(define (body tick-evt w) (define (body tick-evt w)
(chaos-yield (chaos-yield
c c
;; xxx merge these
(choice-evt (choice-evt
(handle-evt (handle-evt
(chaos-event c) (chaos-event c)
(λ (e) (λ (e)
(define start-time (current-inexact-milliseconds)) (update-word w
(define new-w (word-event w e)) (λ (start-time)
(match new-w tick-evt)
[#f (λ (w)
(word-return w)] (word-event w e)))))
[_
(chaos-output! c (word-output w))
(define end-time (current-inexact-milliseconds))
(define frame-time (fl- end-time start-time))
(define new-label
(word-label new-w frame-time))
(chaos-label! c new-label)
(body tick-evt new-w)])))
(handle-evt (handle-evt
tick-evt tick-evt
(λ (_) (λ (_)
(define start-time (current-inexact-milliseconds)) (update-word w
(define new-w (word-tick w)) (λ (start-time)
(match new-w (define next-time (fl+ start-time time-incr))
[#f (define next-tick-evt (alarm-evt next-time))
(word-return w)] next-tick-evt)
[_ word-tick))))))
(chaos-output! c (word-output w))
(define end-time (current-inexact-milliseconds))
(define frame-time (fl- end-time start-time))
(define new-label
(word-label new-w frame-time))
(chaos-label! c new-label)
(define next-time (fl+ start-time time-incr))
(define next-tick-evt (alarm-evt next-time))
(body next-tick-evt new-w)]))))))
(chaos-swap! c (λ () (body always-evt w)))) (chaos-swap! c (λ () (body always-evt w))))
(provide (provide