From 5eccb2537955ea08ccc732db57ab530ecbb76123 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay.mccarthy@gmail.com>
Date: Wed, 19 Nov 2014 22:10:46 -0500
Subject: [PATCH] mouse wrapper

---
 README              |  3 --
 chaos/gui/mouse.rkt | 89 +++++++++++++++++++++++++++++++++++++++++++++
 examples/spin.rkt   | 11 +++---
 3 files changed, 95 insertions(+), 8 deletions(-)
 create mode 100644 chaos/gui/mouse.rkt

diff --git a/README b/README
index ccf5327..c8185b6 100644
--- a/README
+++ b/README
@@ -1,7 +1,4 @@
 lux - a simple library for creating real-time graphical apps
 
 TODO
-xxx chaos/gui/mouse (take gui)
 xxx chaos/gui/key (take gui)
-xxx chaos/srpnt
-xxx chaos/gui/mode-lambda
diff --git a/chaos/gui/mouse.rkt b/chaos/gui/mouse.rkt
new file mode 100644
index 0000000..9784242
--- /dev/null
+++ b/chaos/gui/mouse.rkt
@@ -0,0 +1,89 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/syntax)
+         racket/match
+         racket/class
+         racket/gui/base
+         racket/generic
+         racket/contract/base
+         data/queue
+         lux/chaos)
+
+(struct mouse-state
+  (_
+   x y
+   left? right? middle?
+   shift? control? meta? alt?
+   mod3? mod4? mod5?)
+  #:mutable)
+
+(define-syntax (set-mouse-state stx)
+  (syntax-case stx ()
+    [(_ ms me id)
+     (with-syntax ([set-mouse-state-id?!
+                    (format-id #'id "set-mouse-state-~a?!" #'id)]
+                   [get-id-down
+                    (format-id #'id "get-~a-down" #'id)])
+       (syntax/loc stx
+         (set-mouse-state-id?! ms (send me get-id-down))))]))
+(define-syntax-rule (set-mouse-states ms me (id ...))
+  (begin (set-mouse-state ms me id) ...))
+
+(struct gui/mouse (ms g)
+        #:methods gen:chaos
+        [(define/generic super-fps chaos-fps)
+         (define/generic super-yield chaos-yield)
+         (define/generic super-inputs chaos-inputs)
+         (define/generic super-output! chaos-output!)
+         (define/generic super-label! chaos-label!)
+         (define/generic super-swap! chaos-swap!)
+         (define (chaos-fps c)
+           (super-fps (gui/mouse-g c)))
+         (define (chaos-yield c e)
+           (super-yield (gui/mouse-g c) e))
+         (define (chaos-inputs c)
+           (define ms (gui/mouse-ms c))
+           (define inner (super-inputs (gui/mouse-g c)))
+           (define q (make-queue))
+           (for ([e inner])
+             (match e
+               [(? (λ (x) (is-a? x mouse-event%)) me)
+                (set-mouse-state-x! ms (send me get-x))
+                (set-mouse-state-y! ms (send me get-y))
+                (set-mouse-states
+                 ms me
+                 (left right middle shift control meta alt mod3 mod4 mod5))]
+               [_
+                (enqueue! q e)]))
+           (enqueue! q ms)
+           (in-queue q))
+         (define (chaos-output! c o)
+           (super-output! (gui/mouse-g c) o))
+         (define (chaos-label! c l)
+           (super-label! (gui/mouse-g c) l))
+         (define (chaos-swap! c t)
+           (super-swap! (gui/mouse-g c) t))])
+
+(define (make-gui/mouse g)
+  (define ms
+    (mouse-state (gensym) 0 0 #f #f #f #f #f #f #f #f #f #f))
+  (gui/mouse ms g))
+(provide
+ (contract-out
+  [struct mouse-state
+    ([_ symbol?]
+     [x exact-integer?]
+     [y exact-integer?]
+     [left? boolean?]
+     [right? boolean?]
+     [middle? boolean?]
+     [shift? boolean?]
+     [control? boolean?]
+     [meta? boolean?]
+     [alt? boolean?]
+     [mod3? boolean?]
+     [mod4? boolean?]
+     [mod5? boolean?])]
+  [make-gui/mouse
+   (-> chaos?
+       chaos?)]))
diff --git a/examples/spin.rkt b/examples/spin.rkt
index 0a34d7b..5ab3404 100644
--- a/examples/spin.rkt
+++ b/examples/spin.rkt
@@ -5,7 +5,8 @@
          racket/gui/base
          racket/class
          lux
-         lux/chaos/gui)
+         lux/chaos/gui
+         lux/chaos/gui/mouse)
 
 (define COLORS
   '("red" "orange" "yellow" "green" "blue" "indigo" "violet"))
@@ -21,9 +22,9 @@
              (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))]
+               [(? mouse-state? ms)
+                (set! x (mouse-state-x ms))
+                (set! y (mouse-state-y ms))]
                [(? (λ (x) (is-a? x key-event%)) ke)
                 (set! color (fxmodulo (fx+ 1 color) (length COLORS)))]))
            (match closed?
@@ -42,5 +43,5 @@
 
 (module+ main
   (call-with-chaos
-   (make-gui 60.0)
+   (make-gui/mouse (make-gui 60.0))
    (λ () (fiat-lux (spin 0 0 400 300)))))