diff --git a/chaos.rkt b/chaos.rkt index f09204d..648d9b4 100644 --- a/chaos.rkt +++ b/chaos.rkt @@ -1,12 +1,11 @@ #lang racket/base (require racket/contract/base - racket/sequence racket/generic) (define-generics chaos (chaos-fps chaos) (chaos-yield chaos evt) - (chaos-inputs chaos) + (chaos-event chaos) (chaos-output! chaos outputs) (chaos-label! chaos label) (chaos-swap! chaos thunk) @@ -15,8 +14,8 @@ 60.0) (define (chaos-yield c e) (sync e)) - (define (chaos-inputs c) - empty-sequence) + (define (chaos-event c) + never-evt) (define (chaos-output! c os) (void)) (define (chaos-label! c l) @@ -30,7 +29,7 @@ [chaos? (-> any/c boolean?)] [chaos-fps (-> chaos? flonum?)] [chaos-yield (-> chaos? evt? any)] - [chaos-inputs (-> chaos? sequence?)] + [chaos-event (-> chaos? evt?)] [chaos-output! (-> chaos? any/c any)] [chaos-label! (-> chaos? string? any)] [chaos-swap! (-> chaos? (-> any) any)])) diff --git a/chaos/gui.rkt b/chaos/gui.rkt index 53128ac..e2f6841 100644 --- a/chaos/gui.rkt +++ b/chaos/gui.rkt @@ -3,34 +3,17 @@ racket/class racket/contract/base racket/gui/base - data/queue + racket/async-channel lux/chaos) -(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!) +(struct gui (depth-box event-ch 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-sbox c)) - (define new-q (make-queue)) - (define q (sbox-swap! eb new-q)) - (in-queue q)) + (yield e)) + (define (chaos-event c) + (gui-event-ch c)) (define (chaos-output! c o) (set-box! (gui-drawer c) o) ((gui-refresh! c))) @@ -49,17 +32,17 @@ #:mode [mode 'draw] #:width [init-w 800] #:height [init-h 600]) - (define events-box (sbox (make-queue))) + (define events-ch (make-async-channel)) (define gframe% (class frame% (define/override (on-size w h) (refresh!)) (define/augment (on-close) - (sbox-poke events-box (λ (q) (enqueue! q 'close)))) + (async-channel-put events-ch 'close)) (define/override (on-subwindow-char w ke) - (sbox-poke events-box (λ (q) (enqueue! q ke)))) + (async-channel-put events-ch ke)) (define/override (on-subwindow-event w me) - (sbox-poke events-box (λ (q) (enqueue! q me)))) + (async-channel-put events-ch me)) (super-new))) (define drawer (box void)) @@ -101,7 +84,7 @@ (define depth-box (box 0)) - (gui depth-box events-box fps drawer f refresh!)) + (gui depth-box events-ch fps drawer f refresh!)) (provide (contract-out diff --git a/chaos/gui/val.rkt b/chaos/gui/val.rkt index 3e75bc3..bb0d202 100644 --- a/chaos/gui/val.rkt +++ b/chaos/gui/val.rkt @@ -10,7 +10,7 @@ #:methods gen:chaos [(define/generic super-fps chaos-fps) (define/generic super-yield chaos-yield) - (define/generic super-inputs chaos-inputs) + (define/generic super-event chaos-event) (define/generic super-output! chaos-output!) (define/generic super-label! chaos-label!) (define/generic super-swap! chaos-swap!) @@ -18,8 +18,9 @@ (super-fps (gui/val-g c))) (define (chaos-yield c e) (super-yield (gui/val-g c) e)) - (define (chaos-inputs c) - (super-inputs (gui/val-g c))) + (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) diff --git a/examples/spin.rkt b/examples/spin.rkt index 6cddda8..9789703 100644 --- a/examples/spin.rkt +++ b/examples/spin.rkt @@ -15,19 +15,17 @@ #:methods gen:word [(define (word-label s ft) (lux-standard-label "Spin!" ft)) - (define (word-tick w es) + (define (word-event w e) + ;; xxx remove mutation (match-define (spin layer ks ms color f) w) (define closed? #f) - (for ([e es]) - (match e - ['close - (set! closed? #t)] - [(? mouse-event? me) - (mouse-state-update! ms me)] - [(? key-event? ke) - (key-state-update! ks ke)])) - (define x (mouse-state-x ms)) - (define y (mouse-state-y ms)) + (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) @@ -35,15 +33,22 @@ (match (or closed? (key-state-set?! ks 'escape)) [#t - (values #f w)] + #f] [#f - (values (spin layer ks ms color (fxmodulo (fx+ f 1) 360)) - (lambda (width height dc) - (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 (format "~a: Spinning!" layer) 0 0)))]))]) + (spin layer ks ms color f)])) + (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)) + (lambda (width height dc) + (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 (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)))]) (define (spin-it! layer) (define s diff --git a/examples/val-demo.rkt b/examples/val-demo.rkt index 96dbb1c..1001190 100644 --- a/examples/val-demo.rkt +++ b/examples/val-demo.rkt @@ -17,32 +17,35 @@ #:methods gen:word [(define (word-label s ft) (lux-standard-label "Values" ft)) - (define (word-tick w es) + (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"))])) + (define (word-event w e) + ;; xxx remove mutation (match-define (demo mode-n) w) (define closed? #f) - (for ([e es]) - (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 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 - (values #f w)] + #f] [#f - (values - (demo mode-n) - (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"))]))]))]) + (demo mode-n)])) + (define (word-tick w) + w)]) (module+ main (call-with-chaos diff --git a/word.rkt b/word.rkt index b191907..4ef026a 100644 --- a/word.rkt +++ b/word.rkt @@ -9,11 +9,17 @@ (define-generics word (word-label word frame-time) - (word-tick word events) + (word-event word evt) + (word-tick word) + (word-output word) + (word-return word) #:fallbacks [(define (word-label w frame-time) (lux-standard-label "Lux" frame-time)) - (define (word-tick w es) (values w empty))]) + (define (word-event w e) w) + (define (word-tick w) w) + (define (word-output w) empty) + (define (word-return w) w)]) (define (lux-standard-label l frame-time) (~a l @@ -46,25 +52,42 @@ (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)]))))) + ;; 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)]))) + (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)])))))) (chaos-swap! c (λ () (body always-evt w)))) (provide