working on UI gestures

library/lists.factor

@@ -93,9 +93,14 @@ DEFER: tree-contains?
     swap [ with rot ] map 2nip ; inline
 
 : remove ( obj list -- list )
-    #! Remove all occurrences of the object from the list.
+    #! Remove all occurrences of objects equal to this one from
+    #! the list.
     [ = not ] subset-with ;
 
+: remq ( obj list -- list )
+    #! Remove all occurrences of the object from the list.
+    [ eq? not ] subset-with ;
+
 : length ( list -- length )
     0 swap [ drop 1 + ] each ;
 

library/ui/boxes.factor

@@ -50,7 +50,8 @@ M: box pick-up* ( point box -- gadget )
     ] with-translation ;
 
 : box- ( gadget box -- )
-    2dup box-contents remove swap tuck set-box-contents redraw
+    [ 2dup box-contents remq swap set-box-contents ] keep
+    redraw
     f swap set-gadget-parent ;
 
 : (box+) ( gadget box -- )

library/ui/gadgets.factor

@@ -5,20 +5,21 @@ USING: generic hashtables kernel lists namespaces ;
 
 ! Gadget protocol.
 GENERIC: pick-up* ( point gadget -- gadget/t )
-GENERIC: handle-gesture* ( gesture gadget -- ? )
 
 : pick-up ( point gadget -- gadget )
     #! pick-up* returns t to mean 'this gadget', avoiding the
     #! exposed facade issue.
     tuck pick-up* dup t = [ drop ] [ nip ] ifte ;
 
-! A gadget is a shape together with paint, and a reference to
-! the gadget's parent. A gadget delegates to its shape.
-TUPLE: gadget paint parent delegate ;
+! A gadget is a shape, a paint, a mapping of gestures to
+! actions, and a reference to the gadget's parent. A gadget
+! delegates to its shape.
+TUPLE: gadget paint gestures parent delegate ;
 
 C: gadget ( shape -- gadget )
     [ set-gadget-delegate ] keep
-    [ <namespace> swap set-gadget-paint ] keep ;
+    [ <namespace> swap set-gadget-paint ] keep
+    [ <namespace> swap set-gadget-gestures ] keep ;
 
 : paint-property ( gadget key -- value )
     swap gadget-paint hash ;
@@ -26,6 +27,12 @@ C: gadget ( shape -- gadget )
 : set-paint-property ( gadget value key -- )
     rot gadget-paint set-hash ;
 
+: action ( gadget gesture -- quot )
+    swap gadget-gestures hash ;
+
+: set-action ( gadget quot gesture -- )
+    rot gadget-gestures set-hash ;
+
 : with-gadget ( gadget quot -- )
     #! All drawing done inside the quotation is done with the
     #! gadget's paint. If the gadget does not have any custom
@@ -37,9 +44,7 @@ M: gadget draw ( gadget -- )
 
 M: gadget pick-up* inside? ;
 
-M: gadget handle-gesture* 2drop t ;
-
-GENERIC: redraw ( gadget -- )
+DEFER: redraw ( gadget -- )
 
 : move-gadget ( x y gadget -- )
     [ move-shape ] keep
@@ -55,3 +60,4 @@ GENERIC: redraw ( gadget -- )
 WRAPPER: ghost
 M: ghost draw drop ;
 M: ghost pick-up* 2drop f ;
+M: ghost draw drop ;

library/ui/gestures.factor

@@ -1,7 +1,14 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists sdl-event ;
+USING: alien generic hashtables kernel lists sdl-event ;
+
+: handle-gesture* ( gesture gadget -- ? )
+    tuck gadget-gestures hash* dup [
+        cdr call f
+    ] [
+        2drop t
+    ] ifte ;
 
 : handle-gesture ( gesture gadget -- )
     #! If a gadget's handle-gesture* generic returns t, the
@@ -17,8 +24,11 @@ USING: generic kernel lists sdl-event ;
         2drop
     ] ifte ;
 
-TUPLE: redraw-gesture ;
-C: redraw-gesture ;
+! Redraw gesture. Don't handle this yourself.
+: redraw ( gadget -- )
+    \ redraw swap handle-gesture ;
 
-M: object redraw ( gadget -- )
-    <redraw-gesture> swap handle-gesture ;
+! Mouse gestures are lists where the first element is one of:
+SYMBOL: motion
+SYMBOL: button-up
+SYMBOL: button-down

library/ui/hand.factor

@@ -4,37 +4,33 @@ IN: gadgets
 USING: alien generic kernel lists math namespaces sdl sdl-event
 sdl-video ;
 
+SYMBOL: world
+
 ! The hand is a special gadget that holds mouse position and
 ! mouse button click state. The hand's parent is the world, but
 ! it is special in that the world does not list it as part of
 ! its contents.
 TUPLE: hand click-pos clicked buttons delegate ;
 
-C: hand ( -- hand )
+C: hand ( world -- hand )
     0 <gadget> <ghost> <box>
-    over set-hand-delegate ;
+    over set-hand-delegate
+    [ set-gadget-parent ] keep ;
 
-GENERIC: hand-gesture ( hand gesture -- )
+: motion-gesture ( gesture hand -- )
+    #! Send the gesture to the gadget at the hand's position in
+    #! the world.
+    world get pick-up handle-gesture ;
 
-M: object hand-gesture ( hand gesture -- ) 2drop ;
+: button-gesture ( gesture hand -- )
+    #! Send the gesture to the gadget at the hand's last click
+    #! position in the world. This is used to send a button up
+    #! to the gadget that was clicked, regardless of the mouse
+    #! position at the time of the button up.
+    hand-clicked handle-gesture ;
 
 : button/ ( n hand -- )
     [ hand-buttons unique ] keep set-hand-buttons ;
 
 : button\ ( n hand -- )
     [ hand-buttons remove ] keep set-hand-buttons ;
-
-M: button-down-event hand-gesture ( hand gesture -- )
-    2dup
-    dup button-event-x swap button-event-y rect>
-    swap set-hand-click-pos
-    button-event-button swap button/ ;
-
-M: button-up-event hand-gesture ( hand gesture -- )
-    button-event-button swap button\ ;
-
-M: motion-event hand-gesture ( hand gesture -- )
-    dup motion-event-x swap motion-event-y rot move-gadget ;
-
-M: hand redraw ( hand -- )
-    drop world get redraw ;

library/ui/paint.factor

@@ -21,9 +21,6 @@ SYMBOL: filled ! is the interior of the shape filled?
 
 GENERIC: draw ( obj -- )
 
-M: ghost draw ( ghost -- )
-    drop ;
-
 M: number draw ( point -- )
     >r surface get r> >rect rgb-color pixelColor ;
 

library/ui/world.factor

@@ -9,10 +9,6 @@ sdl-video ;
 ! world variable.
 TUPLE: world running? hand delegate redraw? ;
 
-M: hand handle-gesture* ( gesture hand -- ? )
-    2dup swap hand-gesture
-    world get pick-up handle-gesture* ;
-
 : <world-box> ( -- box )
     0 0 0 0 <rectangle> <everywhere> <gadget>
     dup blue 3list color set-paint-property
@@ -23,27 +19,7 @@ C: world ( -- world )
     <world-box> over set-world-delegate
     t over set-world-running?
     t over set-world-redraw?
-    <hand> over set-world-hand ;
-
-GENERIC: world-gesture ( world gesture -- )
-
-M: alien world-gesture ( world gesture -- ) 2drop ;
-
-M: quit-event world-gesture ( world gesture -- )
-    drop f swap set-world-running? ;
-
-M: resize-event world-gesture ( world gesture -- ? )
-    dup resize-event-w swap resize-event-h
-    [ rot resize-gadget ] 2keep
-    0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
-    world get redraw ;
-
-M: redraw-gesture world-gesture ( world gesture -- )
-
-    drop t swap set-world-redraw? ;
-
-M: world handle-gesture* ( gesture world -- ? )
-    swap world-gesture f ;
+    dup <hand> over set-world-hand ;
 
 : my-hand ( -- hand ) world get world-hand ;
 
@@ -58,10 +34,12 @@ M: world handle-gesture* ( gesture world -- ? )
         drop
     ] ifte ;
 
+DEFER: handle-event
+
 : run-world ( -- )
     world get world-running? [
         <event> dup SDL_WaitEvent 1 = [
-            my-hand handle-gesture draw-world run-world
+            handle-event draw-world run-world
         ] [
             drop
         ] ifte
@@ -70,6 +48,7 @@ M: world handle-gesture* ( gesture world -- ? )
 : init-world ( w h -- )
     t world get set-world-running?
     t world get set-world-redraw?
+    world get [ t swap set-world-redraw? ] \ redraw set-action
     world get resize-gadget ;
 
 : world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ;