mouse enter/leave events

library/test/gadgets.factor

@@ -5,21 +5,21 @@ USING: gadgets kernel lists math namespaces test ;
     [
         2000 x set
         2000 y set
-        2030 2040 <point> 10 20 300 400 <rectangle> inside?
+        2030 2040 rect> 10 20 300 400 <rectangle> inside?
     ] with-scope
 ] unit-test
 [ f ] [
     [
         2000 x set
         2000 y set
-        2500 2040 <point> 10 20 300 400 <rectangle> inside?
+        2500 2040 rect> 10 20 300 400 <rectangle> inside?
     ] with-scope
 ] unit-test
 [ t ] [
     [
         -10 x set
         -20 y set
-        0 0 <point> 10 20 300 400 <rectangle> inside?
+        0 0 rect> 10 20 300 400 <rectangle> inside?
     ] with-scope
 ] unit-test
 [ 11 11 41 41 ] [
@@ -33,7 +33,7 @@ USING: gadgets kernel lists math namespaces test ;
 ] unit-test
 [ t ] [
     default-paint [
-        0 0 <point> -10 -10 20 20 <rectangle> <gadget> [ pick-up ] keep =
+        0 0 rect> -10 -10 20 20 <rectangle> <gadget> [ pick-up ] keep =
     ] bind
 ] unit-test
 
@@ -43,7 +43,7 @@ USING: gadgets kernel lists math namespaces test ;
     
 [ f ] [
     default-paint [
-        35 0 <point>
+        35 0 rect>
         [ 10 30 50 70 ] [ funny-rect ] map
         pick-up
     ] bind

library/ui/buttons.factor

@@ -14,4 +14,8 @@ USING: generic kernel lists math namespaces sdl ;
     dup [ dup button-released ] r> append
     [ button-up 1 ] set-action
     dup [ button-pressed ]
-    [ button-down 1 ] set-action ;
+    [ button-down 1 ] set-action
+    dup [ USE: prettyprint . "Mouse left" USE: stdio print ]
+    [ mouse-leave ] set-action
+    dup [ USE: prettyprint . "Mouse enter" USE: stdio print ]
+    [ mouse-enter ] set-action ;

library/ui/events.factor

@@ -18,23 +18,19 @@ M: resize-event handle-event ( event -- )
     0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
     world get redraw ;
 
-: button-event-pos ( event -- point )
+: button-gesture ( button gesture -- [ gesture button ] )
-    dup button-event-x swap button-event-y <point> ;
+    swap unit append my-hand hand-clicked handle-gesture ;
 
 M: button-down-event handle-event ( event -- )
-    dup button-event-pos my-hand set-hand-click-pos
-    my-hand hand-click-pos world get pick-up
-    my-hand set-hand-clicked
     button-event-button dup my-hand button/
-    button-down swap 2list my-hand button-gesture ;
+    [ button-down ] button-gesture ;
 
 M: button-up-event handle-event ( event -- )
-    button-event-button
+    button-event-button dup my-hand button\
-    dup my-hand button\
+    [ button-up ] button-gesture ;
-    button-up swap 2list my-hand button-gesture
+
-    f my-hand set-hand-clicked
+: motion-event-pos ( event -- x y )
-    f my-hand set-hand-click-pos ;
+    dup motion-event-x swap motion-event-y ;
 
 M: motion-event handle-event ( event -- )
-    dup motion-event-x swap motion-event-y my-hand move-gadget
+    motion-event-pos my-hand move-hand ;
-    [ motion ] my-hand motion-gesture ;

library/ui/gadgets.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic hashtables kernel lists namespaces ;
+USING: generic hashtables kernel lists math namespaces ;
 
 ! A gadget is a shape, a paint, a mapping of gestures to
 ! actions, and a reference to the gadget's parent. A gadget
@@ -18,18 +18,6 @@ C: gadget ( shape -- gadget )
     [ t swap set-gadget-relayout? ] keep
     [ t swap set-gadget-redraw? ] keep ;
 
-: paint-property ( gadget key -- value )
-    swap gadget-paint hash ;
-
-: 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 ;
-
 : redraw ( gadget -- )
     #! Redraw a gadget before the next iteration of the event
     #! loop.
@@ -50,20 +38,37 @@ C: gadget ( shape -- gadget )
 : resize-gadget ( w h gadget -- )
     [ resize-shape ] keep redraw ;
 
-: box- ( gadget box -- )
+: remove-gadget ( gadget box -- )
     [ 2dup gadget-children remq swap set-gadget-children ] keep
     relayout
     f swap set-gadget-parent ;
 
-: (box+) ( gadget box -- )
+: (add-gadget) ( gadget box -- )
     [ gadget-children cons ] keep set-gadget-children ;
 
 : unparent ( gadget -- )
-    dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
+    dup gadget-parent dup [ remove-gadget ] [ 2drop ] ifte ;
 
-: box+ ( gadget box -- )
+: add-gadget ( gadget box -- )
     #! Add a gadget to a box.
     over unparent
     dup pick set-gadget-parent
-    tuck (box+)
+    tuck (add-gadget)
     relayout ;
+
+: each-parent ( gadget quot -- )
+    #! Apply quotation to each parent of the gadget in turn,
+    #! stopping when the quotation returns f.
+    [ call ] 2keep rot [
+        >r gadget-parent dup [
+            r> each-parent
+        ] [
+            r> 2drop
+        ] ifte
+    ] [
+        2drop
+    ] ifte ;
+
+: screen-pos ( gadget -- point )
+    #! The position of the gadget on the screen.
+    0 swap [ shape-pos + t ] each-parent ;

library/ui/gestures.factor

@@ -1,7 +1,13 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: alien generic hashtables kernel lists sdl-event ;
+USING: alien generic hashtables kernel lists math sdl-event ;
+
+: action ( gadget gesture -- quot )
+    swap gadget-gestures hash ;
+
+: set-action ( gadget quot gesture -- )
+    rot gadget-gestures set-hash ;
 
 : handle-gesture* ( gesture gadget -- ? )
     tuck gadget-gestures hash* dup [
@@ -14,17 +20,35 @@ USING: alien generic hashtables kernel lists sdl-event ;
     #! If a gadget's handle-gesture* generic returns t, the
     #! event was not consumed and is passed on to the gadget's
     #! parent.
-    dup [
+    [ dupd handle-gesture* ] each-parent drop ;
-        2dup handle-gesture* [
-            gadget-parent handle-gesture
-        ] [
-            2drop
-        ] ifte
-    ] [
-        2drop
-    ] ifte ;
 
 ! Mouse gestures are lists where the first element is one of:
 SYMBOL: motion
 SYMBOL: button-up
 SYMBOL: button-down
+
+: mouse-enter ( point gadget -- )
+    #! If the old point is inside the new gadget, do not fire an
+    #! enter gesture, since the mouse did not enter. Otherwise,
+    #! fire an enter gesture and go on to the parent.
+    [
+        [ shape-pos + ] keep
+        2dup inside? [
+            drop f
+        ] [
+            [ mouse-enter ] swap handle-gesture* drop t
+        ] ifte
+    ] each-parent drop ;
+
+: mouse-leave ( point gadget -- )
+    #! If the new point is inside the old gadget, do not fire a
+    #! leave gesture, since the mouse did not leave. Otherwise,
+    #! fire a leave gesture and go on to the parent.
+    [
+        [ shape-pos + ] keep
+        2dup inside? [
+            drop f
+        ] [
+            [ mouse-leave ] swap handle-gesture* drop t
+        ] ifte
+    ] each-parent drop ;

library/ui/hand.factor

@@ -44,27 +44,41 @@ DEFER: world
 ! 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 ;
+TUPLE: hand click-pos clicked buttons gadget delegate ;
 
 C: hand ( world -- hand )
-    0 0 <point> <gadget>
+    0 0 0 0 <rectangle> <gadget>
     over set-hand-delegate
-    [ set-gadget-parent ] keep ;
+    [ set-gadget-parent ] 2keep
-
+    [ set-hand-gadget ] keep ;
-: motion-gesture ( gesture hand -- )
-    #! Send the gesture to the gadget at the hand's position in
-    #! the world.
-    world get pick-up handle-gesture ;
-
-: 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 -- )
+    dup hand-gadget over set-hand-clicked
+    dup shape-pos over set-hand-click-pos
     [ hand-buttons unique ] keep set-hand-buttons ;
 
 : button\ ( n hand -- )
     [ hand-buttons remove ] keep set-hand-buttons ;
+
+: fire-leave ( hand -- )
+    dup hand-gadget [ swap shape-pos swap screen-pos - ] keep
+    mouse-leave ;
+
+: fire-enter ( oldpos hand -- )
+    hand-gadget [ screen-pos - ] keep
+    mouse-enter ;
+
+: gadget-at-hand ( hand -- gadget )
+    dup gadget-children [ car ] [ world get pick-up ] ?ifte ;
+
+: update-hand-gadget ( hand -- )
+    #! The hand gadget is the gadget under the hand right now.
+    dup gadget-at-hand [ swap set-hand-gadget ] keep ;
+
+: move-hand ( x y hand -- )
+    dup shape-pos >r
+    [ move-gadget ] keep
+    dup fire-leave
+    dup update-hand-gadget
+    [ motion ] swap handle-gesture
+    r> swap fire-enter ;

library/ui/layouts.factor

@@ -55,7 +55,7 @@ C: border ( delegate size -- border )
     [ set-border-size ] keep [ set-border-delegate ] keep ;
 
 : standard-border ( child delegate -- border )
-    5 <border> [ box+ ] keep ;
+    5 <border> [ add-gadget ] keep ;
 
 : empty-border ( child -- border )
     0 0 0 0 <rectangle> <gadget> standard-border ;
@@ -76,8 +76,8 @@ C: border ( delegate size -- border )
 
 : layout-border-w/h ( border -- )
     [
-        dup shape-h over border-size - >r
+        dup shape-h over border-size 2 * - >r
-        dup shape-w swap border-size - r>
+        dup shape-w swap border-size 2 * - r>
     ] keep
     gadget-children [ >r 2dup r> resize-gadget ] each 2drop ;
 

library/ui/paint.factor

@@ -1,13 +1,20 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl sdl-gfx ;
+USING: generic hashtables kernel lists math namespaces
+sdl sdl-gfx ;
 
 ! The painting protocol. Painting is controlled by various
 ! dynamically-scoped variables.
 
 ! "Paint" is a namespace containing some or all of these values.
 
+: paint-property ( gadget key -- value )
+    swap gadget-paint hash ;
+
+: set-paint-property ( gadget value key -- )
+    rot gadget-paint set-hash ;
+
 ! Colors are lists of three integers, 0..255.
 SYMBOL: foreground ! Used for text and outline shapes.
 SYMBOL: background ! Used for filled shapes.
@@ -27,10 +34,6 @@ GENERIC: draw-shape ( obj -- )
 
 M: rectangle draw-shape drop ;
 
-M: point draw-shape ( point -- )
-    >r surface get r> dup point-x swap point-y
-    foreground get rgb pixelColor ;
-
 TUPLE: hollow-rect delegate ;
 
 C: hollow-rect ( x y w h -- rect )

library/ui/shapes.factor

@@ -49,28 +49,23 @@ GENERIC: resize-shape ( w h shape -- )
     #! Compute a list of running sums of heights of shapes.
     [ 0 swap [ over , shape-h + ] each ] make-list ;
 
-! A point is the simplest shape.
+! A point, represented as a complex number, is the simplest
-TUPLE: point x y ;
+! shape. It is not mutable and cannot be used as the delegate of
+! a gadget.
+: shape-pos ( shape -- pos )
+    dup shape-x swap shape-y rect> ;
 
-C: point ( x y -- point )
+M: number inside? ( point point -- )
-    [ set-point-y ] keep [ set-point-x ] keep ;
+    >r shape-pos r> = ;
 
-M: point inside? ( point point -- )
+M: number shape-x real ;
-    over shape-x over point-x = >r
+M: number shape-y imaginary ;
-    swap shape-y swap point-y = r> and ;
+M: number shape-w drop 0 ;
-
+M: number shape-h drop 0 ;
-M: point shape-x point-x ;
-M: point shape-y point-y ;
-M: point shape-w drop 0 ;
-M: point shape-h drop 0 ;
-
-M: point move-shape ( x y point -- )
-    tuck set-point-y set-point-x ;
 
 : translate ( point shape -- point )
     #! Translate a point relative to the shape.
-    over shape-y over shape-y - >r
+    swap shape-pos swap shape-pos - ;
-    swap shape-x swap shape-x - r> <point> ;
 
 ! A rectangle maps trivially to the shape protocol.
 TUPLE: rectangle x y w h ;
@@ -97,10 +92,10 @@ M: rectangle resize-shape ( w h rect -- )
     tuck set-rectangle-h set-rectangle-w ;
 
 : rectangle-x-extents ( rect -- x1 x2 )
-    dup rectangle-x x get + swap rectangle-w dupd + ;
+    dup rectangle-x x get + swap rectangle-w 1 - dupd + ;
 
 : rectangle-y-extents ( rect -- x1 x2 )
-    dup rectangle-y y get + swap rectangle-h dupd + ;
+    dup rectangle-y y get + swap rectangle-h 1 - dupd + ;
 
 M: rectangle inside? ( point rect -- ? )
     over shape-x over rectangle-x-extents between? >r