From ca7bf32c8e034639bf867cf5e67592e7eb3be1a0 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay.mccarthy@gmail.com>
Date: Wed, 19 Nov 2014 17:48:05 -0500
Subject: [PATCH] initial gui

---
 chaos.rkt         |  9 ++---
 chaos/gui.rkt     | 93 +++++++++++++++++++++++++++++++++++++++++++++++
 examples/spin.rkt | 46 +++++++++++++++++++++++
 main.rkt          | 85 +------------------------------------------
 word.rkt          | 81 +++++++++++++++++++++++++++++++++++++++++
 5 files changed, 226 insertions(+), 88 deletions(-)
 create mode 100644 chaos/gui.rkt
 create mode 100644 examples/spin.rkt
 create mode 100644 word.rkt

diff --git a/chaos.rkt b/chaos.rkt
index 1feb8aa..f09204d 100644
--- a/chaos.rkt
+++ b/chaos.rkt
@@ -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)]))
diff --git a/chaos/gui.rkt b/chaos/gui.rkt
new file mode 100644
index 0000000..5b596b8
--- /dev/null
+++ b/chaos/gui.rkt
@@ -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?)]))
diff --git a/examples/spin.rkt b/examples/spin.rkt
new file mode 100644
index 0000000..0a34d7b
--- /dev/null
+++ b/examples/spin.rkt
@@ -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)))))
diff --git a/main.rkt b/main.rkt
index 5abf2e6..da13dcb 100644
--- a/main.rkt
+++ b/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))
diff --git a/word.rkt b/word.rkt
new file mode 100644
index 0000000..b191907
--- /dev/null
+++ b/word.rkt
@@ -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)]))