fix another scrolling bug in the UI

diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor
index fc287d4b0999dde6190cb506adf4aa52081ac140..9306a6816fa65bcc0b959cc0dfdafe5c941d78f4 100644 (file)
--- a/library/ui/gadgets.factor
+++ b/library/ui/gadgets.factor
@@ -18,20 +18,28 @@ M: array rect-dim drop @{ 0 0 0 }@ ;
 
 : rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
 
+: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
+    [ rect-extent ] 2apply swapd ;
+
 : |v-| ( vec vec -- vec ) v- [ 0 max ] map ;
 
+: <extent-rect> ( loc ext ) dupd swap |v-| <rect> ;
+
 : >absolute ( rect -- rect )
     rect-bounds >r origin get v+ r> <rect> ;
 
 : (rect-intersect) ( rect rect -- array array )
-    [ rect-extent ] 2apply swapd vmin >r vmax r> ;
+    2rect-extent vmin >r vmax r> ;
 
 : rect-intersect ( rect rect -- rect )
-    (rect-intersect) dupd swap |v-| <rect> ;
+    (rect-intersect) <extent-rect> ;
 
 : intersects? ( rect/point rect -- ? )
     (rect-intersect) v- [ 0 <= ] all? ;
 
+: rect-union ( rect rect -- rect )
+    2rect-extent vmax >r vmin r> <extent-rect> ;
+
 ! A gadget is a rectangle, a paint, a mapping of gestures to
 ! actions, and a reference to the gadget's parent.
 TUPLE: gadget

diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor
index a27334b58faa92a3b9983e0f10982ebd599c1e47..0f2d90bd84dfac4f13f4f8744280f5e668027f62 100644 (file)
--- a/library/ui/hierarchy.factor
+++ b/library/ui/hierarchy.factor
@@ -62,6 +62,9 @@ namespaces sequences vectors ;
 
 : relative ( g1 g2 -- g2-g1 ) screen-loc swap screen-loc v- ;
 
+: relative-rect ( g1 g2 -- rect )
+    [ relative ] keep rect-dim <rect> ;
+
 : child? ( parent child -- ? ) parents memq? ;
 
 GENERIC: focusable-child* ( gadget -- gadget/t )

diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor
index ff6dce07166c139ec85b998af7ecf4fd2853438a..a38838d9983cd620846ec9405bc3fee0729769d2 100644 (file)
--- a/library/ui/scrolling.factor
+++ b/library/ui/scrolling.factor
@@ -44,15 +44,22 @@ M: viewport pref-dim gadget-child pref-dim ;
     2dup over scroller-x update-slider
     over scroller-y update-slider ;
 
-: (scroll-to) ( scroller gadget -- point )
-    >r scroller-viewport gadget-child r> relative ;
+: pop-follows ( scroller -- follows )
+    dup scroller-follows f rot set-scroller-follows ;
 
-: update-scroller ( scroller -- )
-    dup dup scroller-follows dup [
-        f pick set-scroller-follows (scroll-to)
+: (do-scroll) ( gadget viewport -- point )
+    [ [ swap relative-rect ] keep rect-union ] keep
+    [ rect-extent v+ ] 2apply v- ;
+
+: do-scroll ( scroller -- delta )
+    dup pop-follows dup [
+        swap scroller-viewport (do-scroll)
     ] [
-        drop scroller-origin
-    ] if scroll ;
+        2drop @{ 0 0 0 }@
+    ] if ;
+
+: update-scroller ( scroller -- )
+    [ dup do-scroll ] keep scroller-origin v+ scroll ;
 
 : position-viewport ( viewport scroller -- )
     scroller-origin vneg swap gadget-child set-rect-loc ;