Wheel mouse support

TODO.FACTOR.txt

@@ -21,6 +21,7 @@
 
 + ui/help:
 
+- collapsing an outliner is broken
 - x11:
   - dealloc glx context, call xfree, etc
   - input methods
@@ -30,6 +31,7 @@
   - expired aliens in view hash
   - don't multiplex in the event loop if there is no pending i/o
 - hand is broken by design
+  - maybe eliminate mouse-overs...?
 - speed up ideas:
   - only do clipping for certain gadgets
   - use glRect

library/ui/hand.factor

@@ -39,7 +39,7 @@ V{ } clone hand-buttons set-global
     dup hand-buttons get-global delete
     [ button-up ] button-gesture ;
 
-: send-scroll-wheel ( up/down -- )
+: send-wheel ( up/down -- )
     [ wheel-up ] [ wheel-down ] ?
     hand-gadget get-global handle-gesture drop ;
 

library/x11/events.factor

@@ -10,6 +10,8 @@ GENERIC: button-down-event ( event window -- )
 
 GENERIC: button-up-event ( event window -- )
 
+GENERIC: wheel-event ( event window -- )
+
 GENERIC: motion-event ( event window -- )
 
 GENERIC: key-down-event ( event window -- )
@@ -33,11 +35,19 @@ GENERIC: client-event ( event window -- )
     QueuedAfterFlush events-queued 0 >
     [ next-event ] [ ui-step wait-event ] if ;
 
+: wheel? ( event -- ? ) XButtonEvent-button { 4 5 } member? ;
+
+: button-down-event$ ( event window -- )
+    over wheel? [ wheel-event ] [ button-down-event ] if ;
+
+: button-up-event$ ( event window -- )
+    over wheel? [ 2drop ] [ button-up-event ] if ;
+
 : handle-event ( event window -- )
     over XAnyEvent-type {
         { [ dup ConfigureNotify = ] [ drop resize-event ] }
-        { [ dup ButtonPress = ] [ drop button-down-event ] }
-        { [ dup ButtonRelease = ] [ drop button-up-event ] }
+        { [ dup ButtonPress = ] [ drop button-down-event$ ] }
+        { [ dup ButtonRelease = ] [ drop button-up-event$ ] }
         { [ dup MotionNotify = ] [ drop motion-event ] }
         { [ dup KeyPress = ] [ drop key-down-event ] }
         { [ dup KeyRelease = ] [ drop key-up-event ] }

library/x11/ui.factor

@@ -22,6 +22,9 @@ M: world button-down-event ( event world -- )
 M: world button-up-event ( event world -- )
     drop XButtonEvent-button send-button-up ;
 
+M: world wheel-event ( event world -- )
+    drop XButtonEvent-button H{ { 4 -1 } { 5 1 } } send-wheel ;
+
 M: world motion-event ( event world -- )
     >r dup XMotionEvent-x swap XMotionEvent-y 0 3array r>
     move-hand ;