Fix some scrollers problems

basis/ui/gadgets/scrollers/scrollers-tests.factor

@@ -2,7 +2,8 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
 kernel models models.compose models.range ui.gadgets.viewports
 ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
 ui.gadgets.sliders math math.vectors arrays sequences
-tools.test.ui math.geometry.rect accessors ;
+tools.test.ui math.geometry.rect accessors ui.gadgets.buttons
+ui.gadgets.packs ;
 IN: ui.gadgets.scrollers.tests
 
 [ ] [
@@ -74,7 +75,7 @@ dup layout
         "g2" get scroll>gadget
         "s" get layout
         "s" get scroller-value
-    ] map [ { 3 0 } = ] all?
+    ] map [ { 2 0 } = ] all?
 ] unit-test
 
 [ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
@@ -86,4 +87,22 @@ dup layout
 [ t ] [ "s" get @right grid-child slider? ] unit-test
 [ f ] [ "s" get @right grid-child find-scroller* ] unit-test
 
+[ ] [
+    "Click Me" [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
+    [ <pile> swap add-gadget <scroller> ] keep
+    dup quot>> call
+    layout
+] unit-test
+
+[ t ] [
+    <gadget> { 200 200 } >>dim
+    [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
+    dup
+    <pile> swap add-gadget <scroller> { 100 100 } >>dim dup layout
+    swap dup quot>> call
+    dup layout
+    model>> dependencies>> [ range-max value>> ] map
+    viewport-gap 2 v*n =
+] unit-test
+
 \ <scroller> must-infer

basis/ui/gadgets/scrollers/scrollers.factor

@@ -3,9 +3,8 @@
 USING: accessors arrays ui.gadgets ui.gadgets.viewports
 ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
 ui.gadgets.sliders ui.gestures kernel math namespaces sequences
-models models.range models.compose
+models models.range models.compose combinators math.vectors
-combinators math.vectors classes.tuple math.geometry.rect
+classes.tuple math.geometry.rect combinators.short-circuit ;
-combinators.short-circuit ;
 IN: ui.gadgets.scrollers
 
 TUPLE: scroller < frame viewport x y follows ;
@@ -22,9 +21,10 @@ TUPLE: scroller < frame viewport x y follows ;
 : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
 
 : do-mouse-scroll ( scroller -- )
-    scroll-direction get-global first2
+    scroll-direction get-global
-    pick y>> slide-by-line
+    [ first swap x>> slide-by-line ]
-    swap x>> slide-by-line ;
+    [ second swap y>> slide-by-line ]
+    2bi ;
 
 scroller H{
     { T{ mouse-scroll } [ do-mouse-scroll ] }
@@ -49,8 +49,8 @@ scroller H{
 
 : scroll ( value scroller -- )
     [
-        dup viewport>> rect-dim { 0 0 }
+        viewport>> [ rect-dim { 0 0 } ] [ viewport-dim ] bi
-        rot viewport>> viewport-dim 4array flip
+        4array flip
     ] keep
     2dup control-value = [ 2drop ] [ set-control-value ] if ;
 
@@ -58,15 +58,14 @@ scroller H{
     [ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
 
 : (scroll>rect) ( rect scroller -- )
-    [
+    [ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
-        scroller-value vneg offset-rect
+    {
-        viewport-gap offset-rect
+        [ scroller-value vneg offset-rect viewport-gap offset-rect ]
-    ] keep
+        [ viewport>> dim>> rect-min ]
-    [ viewport>> dim>> rect-min ] keep
+        [ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
-    [
+        [ scroller-value v+ ]
-        viewport>> 2rect-extent
+        [ scroll ]
-        [ v- { 1 1 } v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+
+    } cleave ;
-    ] keep dup scroller-value rot v+ swap scroll ;
 
 : relative-scroll-rect ( rect gadget scroller -- newrect )
     viewport>> gadget-child relative-loc offset-rect ;
@@ -81,14 +80,17 @@ scroller H{
         [ relative-scroll-rect ] keep
         swap >>follows
         relayout
-    ] [
+    ] [ 3drop ] if ;
-        3drop
+
-    ] if ;
+: (update-scroller) ( scroller -- )
+    [ scroller-value ] keep scroll ;
 
 : (scroll>gadget) ( gadget scroller -- )
-    >r { 0 0 } over pref-dim <rect> swap r>
+    2dup swap child? [
-    [ relative-scroll-rect ] keep
+        [ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
-    (scroll>rect) ;
+        [ relative-scroll-rect ] keep
+        (scroll>rect)
+    ] [ f >>follows (update-scroller) drop ] if ;
 
 : scroll>gadget ( gadget -- )
     dup find-scroller* dup [
@@ -99,7 +101,7 @@ scroller H{
     ] if ;
 
 : (scroll>bottom) ( scroller -- )
-    dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
+    [ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
 
 : scroll>bottom ( gadget -- )
     find-scroller [ t >>follows relayout-1 ] when* ;
@@ -115,19 +117,19 @@ M: gadget update-scroller swap (scroll>gadget) ;
 
 M: rect update-scroller swap (scroll>rect) ;
 
-M: f update-scroller drop dup scroller-value swap scroll ;
+M: f update-scroller drop (update-scroller) ;
 
 M: scroller layout*
-    dup call-next-method
+    [ call-next-method ] [
-    dup follows>>
+        dup follows>>
-    2dup update-scroller
+        [ update-scroller ] [ >>follows drop ] 2bi
-    >>follows drop ;
+    ] bi ; 
 
 M: scroller focusable-child*
     viewport>> ;
 
 M: scroller model-changed
-    nip f >>follows drop ;
+    f >>follows 2drop ;
 
 TUPLE: limited-scroller < scroller
 { min-dim initial: { 0 0 } }