initial gui
This commit is contained in:
Jay McCarthy
parent
64c9e54fdf
commit
ca7bf32c8e
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
(require racket/contract/base
|
||||
data/queue
|
||||
racket/sequence
|
||||
racket/generic)
|
||||
|
||||
(define-generics chaos
|
||||
|
|
@ -15,9 +15,8 @@
|
|||
60.0)
|
||||
(define (chaos-yield c e)
|
||||
(sync e))
|
||||
(define iq (make-queue))
|
||||
(define (chaos-inputs c)
|
||||
iq)
|
||||
empty-sequence)
|
||||
(define (chaos-output! c os)
|
||||
(void))
|
||||
(define (chaos-label! c l)
|
||||
|
|
@ -31,7 +30,7 @@
|
|||
[chaos? (-> any/c boolean?)]
|
||||
[chaos-fps (-> chaos? flonum?)]
|
||||
[chaos-yield (-> chaos? evt? any)]
|
||||
[chaos-inputs (-> chaos? queue?)]
|
||||
[chaos-output! (-> chaos? vector? any)]
|
||||
[chaos-inputs (-> chaos? sequence?)]
|
||||
[chaos-output! (-> chaos? any/c any)]
|
||||
[chaos-label! (-> chaos? string? any)]
|
||||
[chaos-swap! (-> chaos? (-> any) any)]))
|
||||
|
|
|
|||
|
|
@ -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?)]))
|
||||
|
|
@ -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
85
main.rkt
|
|
@ -1,84 +1,3 @@
|
|||
#lang racket/base
|
||||
(require racket/list
|
||||
racket/match
|
||||
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)]))
|
||||
(require lux/word)
|
||||
(provide (all-from-out lux/word))
|
||||
|
|
|
|||
|
|
@ -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)]))
|
||||
Loading…
Reference in New Issue