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

initial gui

This commit is contained in:
Jay McCarthy 2014-11-19 17:48:05 -05:00
parent 64c9e54fdf
commit ca7bf32c8e
5 changed files with 226 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
chaos.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/contract/base (require racket/contract/base
data/queue racket/sequence
racket/generic) racket/generic)
(define-generics chaos (define-generics chaos
@ -15,9 +15,8 @@
60.0) 60.0)
(define (chaos-yield c e) (define (chaos-yield c e)
(sync e)) (sync e))
(define iq (make-queue))
(define (chaos-inputs c) (define (chaos-inputs c)
iq) empty-sequence)
(define (chaos-output! c os) (define (chaos-output! c os)
(void)) (void))
(define (chaos-label! c l) (define (chaos-label! c l)
@ -31,7 +30,7 @@
[chaos? (-> any/c boolean?)] [chaos? (-> any/c boolean?)]
[chaos-fps (-> chaos? flonum?)] [chaos-fps (-> chaos? flonum?)]
[chaos-yield (-> chaos? evt? any)] [chaos-yield (-> chaos? evt? any)]
[chaos-inputs (-> chaos? queue?)] [chaos-inputs (-> chaos? sequence?)]
[chaos-output! (-> chaos? vector? any)] [chaos-output! (-> chaos? any/c any)]
[chaos-label! (-> chaos? string? any)] [chaos-label! (-> chaos? string? any)]
[chaos-swap! (-> chaos? (-> any) any)])) [chaos-swap! (-> chaos? (-> any) any)]))

93
chaos/gui.rkt Normal file
View File

@ -0,0 +1,93 @@
#lang racket/base
(require racket/match
racket/class
racket/contract/base
racket/gui/base
data/queue
lux/chaos)
(struct gui (events-box 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 new-q (make-queue))
(define q (unbox eb))
(set-box! eb new-q)
(in-queue q))
(define (chaos-output! c o)
(set-box! (gui-drawer c) o)
((gui-refresh! c)))
(define (chaos-label! c l)
(send (gui-frame c) set-label l))])
(define (make-gui fps
#:mode [mode 'draw]
#:width [init-w 800]
#:height [init-h 600])
(define events-box (box (make-queue)))
(define gframe%
(class frame%
(define/override (on-size w h)
(refresh!))
(define/augment (on-close)
(enqueue! (unbox events-box) 'close))
(define/override (on-subwindow-char w ke)
(enqueue! (unbox events-box) ke))
(define/override (on-subwindow-event w me)
(enqueue! (unbox events-box) me))
(super-new)))
(define drawer (box void))
(define (paint-canvas c dc)
((unbox drawer)
(send c get-width)
(send c get-height)
dc))
(define f
(new gframe%
[label ""]
[width init-w]
[height init-h]
[style '(fullscreen-button)]))
(define gl-config
(match mode
['draw #f]
['compat-gl
(new gl-config%)]
['core-gl
(define gl-config (new gl-config%))
(send gl-config set-legacy? #f)]
[gl-config
gl-config]))
(define c
(new canvas% [parent f]
[paint-callback paint-canvas]
[style
(cons 'no-autoclear
(if gl-config '(gl) '()))]))
(define (refresh!)
(send c refresh))
(send f show #t)
(gui events-box fps drawer f refresh!))
(provide
(contract-out
[make-gui
(->* (flonum?)
(#:mode
(or/c (one-of/c 'draw 'compat-gl 'core-gl)
(is-a?/c gl-config%))
#:width
exact-nonnegative-integer?
#:height
exact-nonnegative-integer?)
chaos?)]))

46
examples/spin.rkt Normal file
View File

@ -0,0 +1,46 @@
#lang racket/base
(require racket/match
racket/fixnum
racket/draw
racket/gui/base
racket/class
lux
lux/chaos/gui)
(define COLORS
'("red" "orange" "yellow" "green" "blue" "indigo" "violet"))
(struct spin (color frame x y)
#:methods gen:word
[(define (word-label s ft)
(lux-standard-label "Spin!" ft))
(define (word-tick w es)
(match-define (spin color f x y) w)
(define closed? #f)
(for ([e es])
(match e
['close
(set! closed? #t)]
[(? (λ (x) (is-a? x mouse-event%)) me)
(set! x (send me get-x))
(set! y (send me get-y))]
[(? (λ (x) (is-a? x key-event%)) ke)
(set! color (fxmodulo (fx+ 1 color) (length COLORS)))]))
(match closed?
[#t
(values #f w)]
[#f
(values (spin color (fxmodulo (fx+ f 1) 360) x y)
(lambda (width height dc)
(set! x (fxmin width (fxmax x 0)))
(set! y (fxmin height (fxmax y 0)))
(send dc set-background (list-ref COLORS color))
(send dc clear)
(send dc set-rotation (* (/ f 360) 2 3.14))
(send dc set-origin x y)
(send dc draw-text "Spinning!" 0 0)))]))])
(module+ main
(call-with-chaos
(make-gui 60.0)
(λ () (fiat-lux (spin 0 0 400 300)))))

85
main.rkt
View File

@ -1,84 +1,3 @@
#lang racket/base #lang racket/base
(require racket/list (require lux/word)
racket/match (provide (all-from-out lux/word))
racket/contract/base
racket/flonum
racket/format
racket/generic
lux/chaos)
;; xxx abstract away sources (input events) and sinks (gui and sound)?
(define draw-mode/c
(one-of/c 'draw 'gl))
(define-generics word
(word-label word frame-time)
(word-tick word events)
#:fallbacks
[(define (word-label w frame-time)
(lux-standard-label "Lux" frame-time))
(define (word-tick w es) (values w empty))])
(define (lux-standard-label l frame-time)
(~a l
": "
"Frame time: "
(~r frame-time
#:min-width 5
#:precision 1)
"ms; "
"FPS: "
(~r (fl/ 1000.0 frame-time)
#:min-width 7
#:precision 2)))
(define current-chaos (make-parameter #f))
(define (call-with-chaos c t)
(parameterize ([current-chaos c])
(t)))
(define (fiat-lux w)
(define c (current-chaos))
(unless c
(error 'fiat-lux "Not called within call-with-chaos"))
(factum-fiat-lux c w))
(define (factum-fiat-lux c w)
(define fps (chaos-fps c))
(define time-incr (fl* (fl/ 1.0 fps) 1000.0))
(define (body tick-evt w)
(chaos-yield
c
(handle-evt
tick-evt
(λ (_)
(define start-time (current-inexact-milliseconds))
(define inputs (chaos-inputs c))
(define-values (new-w outputs) (word-tick w inputs))
(match new-w
[#f
(apply values outputs)]
[_
(chaos-output! c outputs)
(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))))
(provide gen:word
(contract-out
[lux-standard-label
(-> string? flonum?
string?)]
[call-with-chaos
(-> chaos? (-> any)
any)]
[fiat-lux
(-> word?
any)]))

81
word.rkt Normal file
View File

@ -0,0 +1,81 @@
#lang racket/base
(require racket/list
racket/match
racket/contract/base
racket/flonum
racket/format
racket/generic
lux/chaos)
(define-generics word
(word-label word frame-time)
(word-tick word events)
#:fallbacks
[(define (word-label w frame-time)
(lux-standard-label "Lux" frame-time))
(define (word-tick w es) (values w empty))])
(define (lux-standard-label l frame-time)
(~a l
": "
"Frame time: "
(~r frame-time
#:min-width 5
#:precision 1)
"ms; "
"FPS: "
(~r (fl/ 1000.0 frame-time)
#:min-width 10
#:precision 2)))
(define current-chaos (make-parameter #f))
(define (call-with-chaos c t)
(parameterize ([current-chaos c])
(t)))
(define (fiat-lux w)
(define c (current-chaos))
(unless c
(error 'fiat-lux "Not called within call-with-chaos"))
(factum-fiat-lux c w))
(define (factum-fiat-lux c w)
(define fps (chaos-fps c))
(define time-incr (fl* (fl/ 1.0 fps) 1000.0))
(define (body tick-evt w)
(chaos-yield
c
(handle-evt
tick-evt
(λ (_)
(define start-time (current-inexact-milliseconds))
(define inputs (chaos-inputs c))
(define-values (new-w outputs) (word-tick w inputs))
(match new-w
[#f
outputs]
[_
(chaos-output! c outputs)
(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))))
(provide
gen:word
(contract-out
[lux-standard-label
(-> string? flonum?
string?)]
[call-with-chaos
(-> chaos? (-> any)
any)]
[fiat-lux
(-> word?
any)]))