division of labor

chaos.rkt

@@ -0,0 +1,37 @@
+#lang racket/base
+(require racket/contract/base
+         data/queue
+         racket/generic)
+
+(define-generics chaos
+  (chaos-fps chaos)
+  (chaos-yield chaos evt)
+  (chaos-inputs chaos)
+  (chaos-output! chaos outputs)
+  (chaos-label! chaos label)
+  (chaos-swap! chaos thunk)
+  #:fallbacks
+  [(define (chaos-fps c)
+     60.0)
+   (define (chaos-yield c e)
+     (sync e))
+   (define iq (make-queue))
+   (define (chaos-inputs c)
+     iq)
+   (define (chaos-output! c os)
+     (void))
+   (define (chaos-label! c l)
+     (void))
+   (define (chaos-swap! chaos thunk)
+     (thunk))])
+
+(provide
+ gen:chaos
+ (contract-out
+  [chaos? (-> any/c boolean?)]
+  [chaos-fps (-> chaos? flonum?)]
+  [chaos-yield (-> chaos? evt? any)]
+  [chaos-inputs (-> chaos? queue?)]
+  [chaos-output! (-> chaos? vector? any)]
+  [chaos-label! (-> chaos? string? any)]
+  [chaos-swap! (-> chaos? (-> any) any)]))

main.rkt

@@ -4,7 +4,8 @@
          racket/contract/base
          racket/flonum
          racket/format
-         racket/generic)
+         racket/generic
+         lux/chaos)
 
 ;; xxx abstract away sources (input events) and sinks (gui and sound)?
 (define draw-mode/c
@@ -12,26 +13,11 @@
 
 (define-generics word
   (word-label word frame-time)
-  (word-fps word)
   (word-tick word events)
-  (word-draw-mode word)
-  (word-draw! word width height dc)
-  (word-pause word)
-  (word-resume word state)
-  (word-stop? word)
-  (word-value word)
   #:fallbacks
   [(define (word-label w frame-time)
      (lux-standard-label "Lux" frame-time))
-   (define (word-fps w)
-     60.0)
-   (define (word-tick w es) w)
-   (define (word-draw-mode w) 'draw)
-   (define (word-draw! w width height dc) (void))
-   (define (word-pause w) w)
-   (define (word-resume w) w)
-   (define (word-stop? w) #f)
-   (define (word-value w) w)])
+   (define (word-tick w es) (values w empty))])
 
 (define (lux-standard-label l frame-time)
   (~a l
@@ -46,97 +32,53 @@
           #:min-width 7
           #:precision 2)))
 
-(define current-world (make-parameter #f))
-(struct world (t ch))
-(struct message (w pmz return-t return-ch time-evt))
-(define-syntax-rule (call pmz e)
-  (call-with-continuation-barrier
-   (λ () (call-with-parameterization pmz (λ () e)))))
-(define (start-world)
-  (define submit-ch (make-channel))
-  (define the-gui (start-gui))
-  (define (body old-stack)
-    ;; xxx i dislike that i don't know if old-stack is '()
-    (gui-yield
-     the-gui
-     (choice-evt
-      (match old-stack
-        ['()
-         never-evt]
-        [(cons old-m stack)
-         (match-define (message w pmz return-t return-ch time-evt) old-m)
+(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
-          time-evt
+      tick-evt
       (λ (_)
         (define start-time (current-inexact-milliseconds))
-            (define es (gui-events the-gui))
-            ;; I fear that (call pmz e) is slow and I do it a lot
-            ;; here. So maybe change tick to return all this stuff?
-            (define new-w (call pmz (word-tick w es)))
-            (gui-draw!
-             the-gui
-             (call pmz (word-draw-mode new-w))
-             (λ (width height dc)
-               (call pmz (word-draw! new-w width height dc))))
+        (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
-              (call pmz (word-label new-w frame-time)))
-            (gui-label! the-gui new-label)
-            (match (call pmz (word-stop? new-w))
-              [#f
-               (define fps (call pmz (word-fps new-w)))
-               (define next-time (fl+ start-time (fl* (fl/ 1.0 fps) 1000.0)))
-               (define next-time-evt (alarm-evt next-time))
-               (define new-m
-                 (message new-w pmz return-t return-ch next-time-evt))
-               (body (cons new-m stack))]
-              [#t
-               (thread-resume return-t)
-               (channel-put return-ch (word-value w))
-               (body
-                (match stack
-                  ['()
-                   stack]
-                  [(cons old-m stack)
-                   (match-define (message w pmz return-t return-ch time-evt) old-m)
-                   (cons (message (call pmz (word-resume w))
-                                  pmz return-t return-ch time-evt)
-                         stack)]))])))])
-      (handle-evt
-       submit-ch
-       (λ (new-m)
-         (body
-          (cons new-m
-                (match old-stack
-                  ['()
-                   old-stack]
-                  [(cons old-m stack)
-                   (match-define (message w pmz return-t return-ch time-evt) old-m)
-                   (cons (message (call pmz (word-pause w))
-                                  pmz return-t return-ch time-evt)
-                         stack)]))))))))
-  (define world-t
-    (thread
-     (λ ()
-       (body empty))))
-  (world world-t submit-ch))
+             (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))))
 
-(define (fiat-lux w)
-  (if (current-world)
-      (fictio-fiat-lux w)
-      (factum-fiat-lux w)))
-
-(define (factum-fiat-lux w)
-  (parameterize ([current-world (start-world)])
-    (fictio-fiat-lux w)))
-;; xxx this isn't going to work because the server won't be listening inside tick
-(define (fictio-fiat-lux w)
-  (define return-ch (make-channel))
-  (match-define (world world-t submit-ch) (current-world))
-  (thread-resume world-t)
-  (define m (message w (current-parameterization)
-                     (current-thread) return-ch
-                     always-evt))
-  (channel-put! submit-ch m)
-  (channel-get return-ch))
+(provide gen:word
+         (contract-out
+          [lux-standard-label
+           (-> string? flonum?
+               string?)]
+          [call-with-chaos
+           (-> chaos? (-> any)
+               any)]
+          [fiat-lux
+           (-> word?
+               any)]))