Adding word-event

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)
+   (define (chaos-event c)
-     empty-sequence)
+     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)]))

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))
+(struct gui (depth-box event-ch fps drawer frame refresh!)
-(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!)
         #:methods gen:chaos
         [(define (chaos-fps c)
            (gui-fps c))
          (define (chaos-yield c e)
            (yield e))         
-         (define (chaos-inputs c)
+         (define (chaos-event c)
-           (define eb (gui-events-sbox c))
+           (gui-event-ch c))
-           (define new-q (make-queue))
-           (define q (sbox-swap! eb new-q))
-           (in-queue q))
          (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

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)
+         (define (chaos-event c)
-           (super-inputs (gui/val-g 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)

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)]))
+              (key-state-update! ks ke)])
-           (define x (mouse-state-x ms))
-           (define y (mouse-state-y ms))
            (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))
+              (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)))]))])
+             (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

examples/val-demo.rkt

@@ -17,24 +17,8 @@
   #: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)
-     (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 closed?
-       [#t
-        (values #f w)]
-       [#f
-        (values
-         (demo mode-n)
      (match (list-ref MODES mode-n)
        ['pict
         (pict:arrowhead 30 0)]
@@ -42,7 +26,26 @@
         (image:add-line
          (image:rectangle 100 100 "solid" "darkolivegreen")
          25 25 75 75
-             (image:make-pen "goldenrod" 30 "solid" "round" "round"))]))]))])
+         (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)
+     (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)]))
+   (define (word-tick w)
+     w)])
 
 (module+ main
   (call-with-chaos

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,17 +52,34 @@
   (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)])))
       (handle-evt
        tick-evt
        (λ (_)
          (define start-time (current-inexact-milliseconds))
-        (define inputs (chaos-inputs c))
+         (define new-w (word-tick w))
-        (define-values (new-w outputs) (word-tick w inputs))
          (match new-w
            [#f
-           outputs]
+            (word-return w)]
            [_
-           (chaos-output! c outputs)
+            (chaos-output! c (word-output w))
             (define end-time (current-inexact-milliseconds))
             (define frame-time (fl- end-time start-time))
             (define new-label
@@ -64,7 +87,7 @@
             (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)])))))
+            (body next-tick-evt new-w)]))))))
   (chaos-swap! c (λ () (body always-evt w))))
 
 (provide