fix mouse enter/leave handling with overlapping gadgets

TODO.FACTOR.txt

@@ -2,15 +2,14 @@
 ---
 
 - i/o: don't keep creating new sbufs
-- rollovers broken with menus
-- menu dragging
-- fix up the min thumb size hack
-- gaps in pack layout
 - fix listener prompt display after presentation commands invoked
 - theme abstraction in ui
 
 + ui:
 
+- menu dragging
+- fix up the min thumb size hack
+- gaps in pack layout
 - find out why so many small bignums get consed
 - repaint only dirty regions of the screen
 - faster mouse tracking

library/help/tutorial.factor

@@ -333,4 +333,4 @@ M: general-list tutorial-line
     <book-browser> ;
 
 : tutorial ( -- )
-    ensure-ui <tutorial> gadget. ;
+    <tutorial> gadget. ;

library/ui/gestures.factor

@@ -35,42 +35,8 @@ SYMBOL: motion
 SYMBOL: drag
 SYMBOL: button-up
 SYMBOL: button-down
+SYMBOL: mouse-enter
+SYMBOL: mouse-leave
 
-: hierarchy-gesture ( gadget ? gesture -- ? )
-    swap [ 2drop f ] [ swap handle-gesture* drop t ] ifte ;
-
-: 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.
-    [
-        [ rectangle-loc v+ ] keep
-        2dup inside? [ mouse-enter ] hierarchy-gesture
-    ] each-parent 2drop ;
-
-: 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.
-    [
-        [ rectangle-loc v+ ] keep
-        2dup inside? [ mouse-leave ] hierarchy-gesture
-    ] each-parent 2drop ;
-
-: lose-focus ( new old -- )
-    #! If the old focus owner is a child of the new owner, do
-    #! not fire a focus lost gesture, since the focus was not
-    #! lost. Otherwise, fire a focus lost gesture and go to the
-    #! parent.
-    [
-        2dup child? [ lose-focus ] hierarchy-gesture
-    ] each-parent 2drop ;
-
-: gain-focus ( old new -- )
-    #! If the old focus owner is a child of the new owner, do
-    #! not fire a focus gained gesture, since the focus was not
-    #! gained. Otherwise, fire a focus gained gesture and go on
-    #! to the parent.
-    [
-        2dup child? [ gain-focus ] hierarchy-gesture
-    ] each-parent 2drop ;
+SYMBOL: lose-focus
+SYMBOL: gain-focus

library/ui/hand.factor

@@ -46,16 +46,7 @@ C: hand ( world -- hand )
 : button\ ( n hand -- )
     [ hand-buttons remove ] keep set-hand-buttons ;
 
-: fire-leave ( hand gadget -- )
-    [ swap rectangle-loc swap screen-loc v- ] keep mouse-leave ;
-
-: fire-enter ( oldpos hand -- )
-    hand-gadget [ screen-loc v- ] keep mouse-enter ;
-
-: update-hand-gadget ( hand -- )
-    [ rectangle-loc world get pick-up ] keep set-hand-gadget ;
-
-: motion-gesture ( hand gadget gesture -- )
+: drag-gesture ( hand gadget gesture -- )
     #! Send a gesture like [ drag 2 ].
     rot hand-buttons car add swap handle-gesture drop ;
 
@@ -65,24 +56,36 @@ C: hand ( world -- hand )
     #! gadget that was clicked.
     [ motion ] over hand-gadget handle-gesture drop
     dup hand-buttons
-    [ dup hand-clicked [ drag ] motion-gesture ] [ drop ] ifte ;
+    [ dup hand-clicked [ drag ] drag-gesture ] [ drop ] ifte ;
+
+: drop-prefix ( l1 l2 -- l1 l2 )
+    2dup and [ 2dup 2car eq? [ 2cdr drop-prefix ] when ] when ;
+
+: each-gesture ( gesture seq -- )
+    [ handle-gesture* drop ] each-with ;
+
+: hand-gestures ( hand new old -- )
+    drop-prefix
+    reverse [ mouse-leave ] swap each-gesture
+    swap fire-motion
+    [ mouse-enter ] swap each-gesture ;
 
 : move-hand ( loc hand -- )
-    dup rectangle-loc >r
-    [ set-rectangle-loc ] keep
-    dup hand-gadget >r
-    dup update-hand-gadget
-    dup r> fire-leave
-    dup fire-motion
-    r> swap fire-enter ;
+    dup hand-gadget parents-down >r
+    2dup set-rectangle-loc
+    [ >r world get pick-up r> set-hand-gadget ] keep
+    dup hand-gadget parents-down r> hand-gestures ;
 
 : update-hand ( hand -- )
     #! Called when a gadget is removed or added.
     dup rectangle-loc swap move-hand ;
 
+: focus-gestures ( new old -- )
+    drop-prefix
+    reverse [ lose-focus ] swap each-gesture
+    [ gain-focus ] swap each-gesture ;
+
 : request-focus ( gadget -- )
     focusable-child
-    hand hand-focus
-    2dup lose-focus
-    swap dup hand set-hand-focus
-    gain-focus ;
+    hand dup hand-focus parents-down >r
+    dupd set-hand-focus parents-down r> focus-gestures ;

library/ui/hierarchy.factor

@@ -35,27 +35,31 @@ sequences vectors ;
     #! Add a gadget to a parent gadget.
     [ (add-gadget) ] keep relayout ;
 
-: parents ( gadget -- list )
+: (parents-down) ( list gadget -- list )
+    [ [ swons ] keep gadget-parent (parents-down) ] when* ;
+
+: parents-down ( gadget -- list )
+    #! A list of all parents of the gadget, the last element
+    #! is the gadget itself.
+    f swap (parents-down) ;
+
+: parents-up ( gadget -- list )
     #! A list of all parents of the gadget, the first element
     #! is the gadget itself.
-    dup [ dup gadget-parent parents cons ] when ;
+    dup [ dup gadget-parent parents-up cons ] when ;
 
 : each-parent ( gadget quot -- ? )
-    >r parents r> all? ; inline
+    >r parents-up r> all? ; inline
 
 : find-parent ( gadget quot -- ? )
-    >r parents r> find nip ; inline
+    >r parents-up r> find nip ; inline
 
 : screen-loc ( gadget -- point )
     #! The position of the gadget on the screen.
-    parents { 0 0 0 } [ rectangle-loc v+ ] reduce ;
+    parents-up { 0 0 0 } [ rectangle-loc v+ ] reduce ;
 
 : relative ( g1 g2 -- g2-g1 )
     screen-loc swap screen-loc v- ;
 
 : child? ( parent child -- ? )
-    dup [
-        2dup eq? [ 2drop t ] [ gadget-parent child? ] ifte
-    ] [
-        2drop f
-    ] ifte ;
+    parents-down memq? ;

library/ui/presentations.factor

@@ -43,14 +43,15 @@ global [ 100 <vector> commands set ] bind
     [ 2nip ] [ drop <styled-label> dup init-commands ] ifte ;
 
 : gadget. ( gadget -- )
-    gadget swons unit "" swap write-attr terpri ;
+    gadget swons unit
+    "This stream does not support live gadgets"
+    swap write-attr terpri ;
 
 [ drop t ] "Prettyprint" [ prettyprint ] define-command
 [ drop t ] "Inspect" [ inspect ] define-command
 [ drop t ] "References" [ references inspect ] define-command
 
 [ word? ] "See" [ see ] define-command
-[ word? ] "Execute" [ execute ] define-command
 [ word? ] "Usage" [ usage . ] define-command
 [ word? ] "jEdit" [ jedit ] define-command
 

library/ui/scrolling.factor

@@ -5,9 +5,14 @@ USING: generic kernel lists math matrices namespaces sequences
 threads vectors styles ;
 
 ! A viewport can be scrolled.
-
 TUPLE: viewport origin bottom? ;
 
+! A slider scrolls a viewport.
+TUPLE: slider thumb vector ;
+
+! A scroller combines a viewport with two x and y sliders.
+TUPLE: scroller viewport x y ;
+
 : viewport-dim gadget-child pref-dim ;
 
 : fix-scroll ( origin viewport -- origin )
@@ -46,12 +51,6 @@ M: viewport focusable-child* ( viewport -- gadget )
     swap viewport-dim { 1 1 1 } vmax
     v/ { 1 1 1 } vmin ;
 
-! A slider scrolls a viewport.
-
-! The offset slot is the y co-ordinate of the mouse relative to
-! the thumb when it was clicked.
-TUPLE: slider thumb vector ;
-
 : slider-scroller ( slider -- scroller )
     [ scroller? ] find-parent ;
 
@@ -128,8 +127,6 @@ M: slider layout* ( slider -- )
     dup thumb-dim over slider-vector v* slider-dim vmax
     swap slider-thumb set-gadget-dim ;
 
-TUPLE: scroller viewport x y ;
-
 : add-viewport 2dup set-scroller-viewport add-center ;
 
 : add-x-slider 2dup set-scroller-x add-bottom ;

library/ui/world.factor

@@ -12,10 +12,10 @@ vectors ;
 TUPLE: world running? hand glass invalid ;
 
 DEFER: <hand>
+DEFER: update-hand
 
 C: world ( -- world )
     f <stack> over set-delegate
-    t over set-world-running?
     t over set-gadget-root?
     dup <hand> over set-world-hand ;
 
@@ -54,7 +54,7 @@ DEFER: handle-event
 
 : world-step ( -- ? )
     world get dup world-invalid >r layout-world r>
-    [ hand update-hand draw-world ] [ drop ] ifte ;
+    [ dup world-hand update-hand draw-world ] [ drop ] ifte ;
 
 : next-event ( -- event ? )
     <event> dup SDL_PollEvent ;
@@ -69,11 +69,5 @@ DEFER: handle-event
         world get world-running? [ yield run-world ] when
     ] ifte ;
 
-: ensure-ui ( -- )
-    #! Raise an error if the UI is not running.
-    world get dup [ world-running? ] when [
-        "UI not running." throw
-    ] unless ;
-
 : start-world ( -- )
     world get t over set-world-running? relayout ;