Various beautifications
This commit is contained in:
Jay McCarthy
parent
b760c9fd1b
commit
bb1567f481
|
|
@ -1,57 +1,37 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/generic
|
||||
racket/draw
|
||||
racket/contract/base
|
||||
pict
|
||||
pict/convert
|
||||
lux/chaos)
|
||||
pict/convert)
|
||||
|
||||
(struct gui/val (scale? g [last #:mutable])
|
||||
#:methods gen:chaos
|
||||
[(define/generic super-fps chaos-fps)
|
||||
(define/generic super-yield chaos-yield)
|
||||
(define/generic super-event chaos-event)
|
||||
(define/generic super-output! chaos-output!)
|
||||
(define/generic super-label! chaos-label!)
|
||||
(define/generic super-swap! chaos-swap!)
|
||||
(define (chaos-fps c)
|
||||
(super-fps (gui/val-g c)))
|
||||
(define (chaos-yield c e)
|
||||
(super-yield (gui/val-g c) e))
|
||||
(define (chaos-event c)
|
||||
(super-event (gui/val-g c)))
|
||||
;; xxx change this to be a helper for word's output creation
|
||||
(define (chaos-output! c o)
|
||||
(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/val #:scale? [scale? #t])
|
||||
(define last-val #f)
|
||||
(define (output-val o)
|
||||
(unless (eq? o last-val)
|
||||
(set! last-val o)
|
||||
(define p (pict-convert o))
|
||||
(λ (w h dc)
|
||||
(parameterize ([dc-for-text-size dc])
|
||||
(send dc set-background "black")
|
||||
(send dc clear)
|
||||
(define sp
|
||||
(if scale?
|
||||
(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)))))
|
||||
output-val)
|
||||
|
||||
(define (make-gui/value g #:scale? [scale? #t])
|
||||
(gui/val scale? g #f))
|
||||
(provide
|
||||
(contract-out
|
||||
[make-gui/value
|
||||
(->* (chaos?)
|
||||
(#:scale? boolean?)
|
||||
chaos?)]))
|
||||
[make-gui/val
|
||||
(->* () (#:scale? boolean?)
|
||||
(-> pict-convertible?
|
||||
(-> real? real? (is-a?/c dc<%>)
|
||||
any)))]))
|
||||
|
|
|
|||
|
|
@ -11,35 +11,32 @@
|
|||
(define COLORS
|
||||
'("red" "orange" "yellow" "green" "blue" "indigo" "violet"))
|
||||
|
||||
(struct spin (layer ks ms color frame)
|
||||
(struct spin (layer color frame x y)
|
||||
#:methods gen:word
|
||||
[(define (word-label s ft)
|
||||
(lux-standard-label "Spin!" ft))
|
||||
(define (word-event w e)
|
||||
;; xxx remove mutation
|
||||
(match-define (spin layer ks ms color f) w)
|
||||
(define closed? #f)
|
||||
(match e
|
||||
['close
|
||||
(set! closed? #t)]
|
||||
[(? mouse-event? me)
|
||||
(mouse-state-update! ms me)]
|
||||
[(? key-event? ke)
|
||||
(key-state-update! ks ke)])
|
||||
(when (key-state-set?! ks #\space)
|
||||
(set! color (fxmodulo (fx+ 1 color) (length COLORS))))
|
||||
(when (key-state-set?! ks #\return)
|
||||
(spin-it! (add1 layer)))
|
||||
(match (or closed?
|
||||
(key-state-set?! ks 'escape))
|
||||
[#t
|
||||
#f]
|
||||
[#f
|
||||
(spin layer ks ms color f)]))
|
||||
(match-define (spin layer color f x y) w)
|
||||
(cond
|
||||
[(or (eq? e 'close)
|
||||
(and (key-event? e)
|
||||
(eq? (send e get-key-code) 'escape)))
|
||||
#f]
|
||||
[(and (key-event? e)
|
||||
(eq? (send e get-key-code) #\space))
|
||||
(spin layer (fxmodulo (fx+ 1 color) (length COLORS)) f x y)]
|
||||
[(mouse-event? e)
|
||||
(spin layer color f
|
||||
(send e get-x)
|
||||
(send e get-y))]
|
||||
[(and (key-event? e)
|
||||
(eq? (send e get-key-code) #\return))
|
||||
(spin-it (add1 layer))
|
||||
w]
|
||||
[else
|
||||
w]))
|
||||
(define (word-output w)
|
||||
(match-define (spin layer ks ms color f) w)
|
||||
(define x (mouse-state-x ms))
|
||||
(define y (mouse-state-y ms))
|
||||
(match-define (spin layer color f x y) w)
|
||||
(lambda (width height dc)
|
||||
(send dc set-background (list-ref COLORS color))
|
||||
(send dc clear)
|
||||
|
|
@ -47,19 +44,16 @@
|
|||
(send dc set-origin x y)
|
||||
(send dc draw-text (format "~a: Spinning!" layer) 0 0)))
|
||||
(define (word-tick w)
|
||||
(match-define (spin layer ks ms color f) w)
|
||||
(spin layer ks ms color (fxmodulo (fx+ f 1) 360)))])
|
||||
(match-define (spin layer color f x y) w)
|
||||
(spin layer color (fxmodulo (fx+ f 1) 360) x y))])
|
||||
|
||||
(define (spin-it! layer)
|
||||
(define (spin-it layer)
|
||||
(define s
|
||||
(spin layer
|
||||
(make-key-state)
|
||||
(make-mouse-state)
|
||||
0 0))
|
||||
(spin layer 0 0 0 0))
|
||||
(fiat-lux s))
|
||||
|
||||
(module+ main
|
||||
(call-with-chaos
|
||||
(make-gui 60.0)
|
||||
(λ ()
|
||||
(spin-it! 0))))
|
||||
(spin-it 0))))
|
||||
|
|
|
|||
|
|
@ -7,47 +7,43 @@
|
|||
(prefix-in image: 2htdp/image)
|
||||
lux
|
||||
lux/chaos/gui
|
||||
lux/chaos/gui/val)
|
||||
lux/chaos/gui/val
|
||||
lux/chaos/gui/key)
|
||||
|
||||
(define MODES
|
||||
'(pict image))
|
||||
|
||||
(struct demo
|
||||
(mode)
|
||||
(g/v mode)
|
||||
#:methods gen:word
|
||||
[(define (word-label s ft)
|
||||
(lux-standard-label "Values" ft))
|
||||
(define (word-output w)
|
||||
(match-define (demo mode-n) w)
|
||||
(match (list-ref MODES mode-n)
|
||||
['pict
|
||||
(pict:arrowhead 30 0)]
|
||||
['image
|
||||
(image:add-line
|
||||
(image:rectangle 100 100 "solid" "darkolivegreen")
|
||||
25 25 75 75
|
||||
(image:make-pen "goldenrod" 30 "solid" "round" "round"))]))
|
||||
(match-define (demo g/v mode-n) w)
|
||||
(g/v
|
||||
(match (list-ref MODES mode-n)
|
||||
['pict
|
||||
(pict:arrowhead 30 0)]
|
||||
['image
|
||||
(image:add-line
|
||||
(image:rectangle 100 100 "solid" "darkolivegreen")
|
||||
25 25 75 75
|
||||
(image:make-pen "goldenrod" 30 "solid" "round" "round"))])))
|
||||
(define (word-event w e)
|
||||
;; xxx remove mutation
|
||||
(match-define (demo mode-n) w)
|
||||
(match-define (demo g/v mode-n) w)
|
||||
(define closed? #f)
|
||||
(match e
|
||||
['close
|
||||
(set! closed? #t)]
|
||||
[(? (λ (x) (is-a? x key-event%)) ke)
|
||||
(unless (eq? 'release (send ke get-key-code))
|
||||
(set! mode-n (fxmodulo (fx+ 1 mode-n) (length MODES))))]
|
||||
[_
|
||||
(void)])
|
||||
(match closed?
|
||||
[#t
|
||||
#f]
|
||||
[#f
|
||||
(demo mode-n)]))
|
||||
(cond
|
||||
[(eq? e 'close)
|
||||
#f]
|
||||
[(and (key-event? e)
|
||||
(not (eq? 'release (send e get-key-code))))
|
||||
(demo g/v (fxmodulo (fx+ 1 mode-n) (length MODES)))]
|
||||
[else
|
||||
(demo g/v mode-n)]))
|
||||
(define (word-tick w)
|
||||
w)])
|
||||
|
||||
(module+ main
|
||||
(call-with-chaos
|
||||
(make-gui/value (make-gui 60.0))
|
||||
(λ () (fiat-lux (demo 0)))))
|
||||
(make-gui 60.0)
|
||||
(λ () (fiat-lux (demo (make-gui/val) 0)))))
|
||||
|
|
|
|||
55
word.rkt
55
word.rkt
|
|
@ -49,45 +49,42 @@
|
|||
(define (factum-fiat-lux c w)
|
||||
(define fps (chaos-fps c))
|
||||
(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)
|
||||
(chaos-yield
|
||||
c
|
||||
;; xxx merge these
|
||||
(choice-evt
|
||||
(handle-evt
|
||||
(chaos-event c)
|
||||
(λ (e)
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(define new-w (word-event w e))
|
||||
(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)
|
||||
(body tick-evt new-w)])))
|
||||
(update-word w
|
||||
(λ (start-time)
|
||||
tick-evt)
|
||||
(λ (w)
|
||||
(word-event w e)))))
|
||||
(handle-evt
|
||||
tick-evt
|
||||
(λ (_)
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(define new-w (word-tick 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-time (fl+ start-time time-incr))
|
||||
(define next-tick-evt (alarm-evt next-time))
|
||||
(body next-tick-evt new-w)]))))))
|
||||
(update-word w
|
||||
(λ (start-time)
|
||||
(define next-time (fl+ start-time time-incr))
|
||||
(define next-tick-evt (alarm-evt next-time))
|
||||
next-tick-evt)
|
||||
word-tick))))))
|
||||
(chaos-swap! c (λ () (body always-evt w))))
|
||||
|
||||
(provide
|
||||
|
|
|
|||
Loading…
Reference in New Issue