Fix issue with scroll>rect where the gadget is not the immediate child of the scroller

TODO.FACTOR.txt

@@ -1,14 +1,16 @@
 + 0.87:
 
 - "ker" C+u: for a moment, full vocab list is shown
-- : foo \ each reload foo ; foo  eventually crashes
+- some module operations don't work on module-links
+- list operations: what if nothing is selected?
+- menu should stay up if mouse button released
+- bogus compile errors?
+
 - list usability
   - popup: -- close button
   - popup: -- pin button
-- some module operations don't work on module-links
 - modules: core/ libs/ apps/
 - top level window positioning on ms windows
-- scroll>rect broken if there are gadgets in between
 - completion is not ideal: eg, C+e "buttons"
 - crashes:
   - windows gcc issue
@@ -24,7 +26,6 @@
   - 10000 [ dup number>string ] map describe in the UI
   - available-modules
   - :trace
-- menu should stay up if mouse button released
 - roundoff is still not quite right with tracks
 - slider needs to be modelized
 - variable width word wrap
@@ -32,7 +33,6 @@
 - auto-update browser and help when sources reload
 - mac intel: struct returns from objc methods
 - new windows don't always have focus, eg focus follows mouse
-- bogus compile errors?
 - recompile get/set/>n/n>/ndrop if needed
 - cross-word type inference
 - ui docs

library/ui/gadgets.factor

@@ -65,6 +65,15 @@ C: gadget ( -- gadget )
 
 : delegate>gadget ( tuple -- ) <gadget> swap set-delegate ;
 
+: relative-loc ( fromgadget togadget -- loc )
+    2dup eq? [
+        2drop { 0 0 }
+    ] [
+        over rect-loc >r
+        >r gadget-parent r> relative-loc
+        r> v+
+    ] if ;
+
 GENERIC: user-input* ( str gadget -- ? )
 
 M: gadget user-input* 2drop t ;

library/ui/gadgets/scrolling.factor

@@ -75,14 +75,25 @@ C: scroller ( gadget -- scroller )
         >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
     ] keep dup scroller-origin rot v+ scroll ;
 
+: relative-scroll-rect ( rect gadget scroller -- rect )
+    #! Adjust rect for the case where the gadget is not the
+    #! immediate child of the scroller's viewport.
+    scroller-viewport gadget-child relative-loc offset-rect ;
+
 : scroll>rect ( rect gadget -- )
-    find-scroller dup [
+    dup find-scroller dup [
-        [ set-scroller-follows ] keep relayout
+        [ relative-scroll-rect ] keep
+        [ set-scroller-follows ] keep
+        relayout
     ] [
-        2drop
+        3drop
     ] if ;
 
-: scroll>bottom ( gadget -- ) t swap scroll>rect ;
+: scroll>bottom ( gadget -- )
+    find-scroller [
+        t over set-scroller-follows
+        relayout
+    ] when* ;
 
 : (scroll>bottom) ( scroller -- )
     dup scroller-viewport viewport-dim { 0 1 } v* scroll ;

library/ui/gestures.factor

@@ -148,10 +148,10 @@ SYMBOL: double-click-timeout
     hand-loc get-global hand-click-loc get-global v- ;
 
 : hand-rel ( gadget -- loc )
-    hand-loc get-global relative-loc ;
+    hand-loc get-global swap screen-loc v- ;
 
 : hand-click-rel ( gadget -- loc )
-    hand-click-loc get-global relative-loc ;
+    hand-click-loc get-global swap screen-loc v- ;
 
 : multi-click? ( button -- ? )
     millis hand-last-time get - double-click-timeout get <=

library/ui/hierarchy.factor

@@ -99,8 +99,6 @@ M: gadget ungraft* drop ;
     #! The position of the gadget on the screen.
     parents { 0 0 } [ rect-loc v+ ] reduce ;
 
-: relative-loc ( g1 point -- point-g1 ) swap screen-loc v- ;
-
 : child? ( parent child -- ? ) parents memq? ;
 
 GENERIC: focusable-child* ( gadget -- gadget/t )

library/ui/load.factor

@@ -61,6 +61,7 @@ PROVIDE: library/ui
     "test/commands.factor"
     "test/panes.factor"
     "test/presentations.factor"
+    "test/scrolling.factor"
     "test/search.factor"
     "test/sliders.factor"
     "test/tracks.factor"

library/ui/test/gadgets.factor

@@ -1,7 +1,27 @@
 IN: temporary
-USING: gadgets test ;
+USING: gadgets test namespaces ;
 
 TUPLE: fooey ;
 
 [ ] [ <gadget> <fooey> set-gadget-delegate ] unit-test
 [ ] [ f <fooey> set-gadget-delegate ] unit-test
+
+[ { 300 300 } ]
+[
+    ! c contains b contains a
+    <gadget> "a" set
+    <gadget> "b" set
+    "a" get "b" get add-gadget
+    <gadget> "c" set
+    "b" get "c" get add-gadget
+    
+    ! position a and b
+    { 100 200 } "a" get set-rect-loc
+    { 200 100 } "b" get set-rect-loc
+    
+    ! give c a loc, it doesn't matter
+    { -1000 23 } "c" get set-rect-loc
+
+    ! what is the location of a inside c?
+    "a" get "c" get relative-loc
+] unit-test

library/ui/test/scrolling.factor

@@ -0,0 +1,15 @@
+IN: temporary
+USING: gadgets gadgets-scrolling namespaces test ;
+
+[ ] [
+    <gadget> "g" set
+    "g" get <scroller> "s" set
+] unit-test
+
+[ { 100 200 } ] [
+    { 100 200 } "g" get scroll>rect
+    "s" get scroller-follows rect-loc
+] unit-test
+
+[ ] [ "s" get scroll>bottom ] unit-test
+[ t ] [ "s" get scroller-follows ] unit-test