Scrollers: add pref-viewport-dim word that child gadgets can implement; clean up layout

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

@@ -1,9 +1,9 @@
 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.labels ui.gadgets.grids
 ui.gadgets.sliders math math.vectors arrays sequences
 tools.test.ui math.rectangles accessors ui.gadgets.buttons
-ui.gadgets.packs ;
+ui.gadgets.packs ui.gadgets.scrollers.private ;
 IN: ui.gadgets.scrollers.tests
 
 [ ] [
@@ -28,7 +28,7 @@ IN: ui.gadgets.scrollers.tests
 "v" get [
     [ { 10 20 } ] [ "v" get model>> range-value ] unit-test
 
-    [ { 10 20 } ] [ "g" get loc>> vneg viewport-gap v+ scroller-border v+ ] unit-test
+    [ { 10 20 } ] [ "g" get loc>> vneg ] unit-test
 ] with-grafted-gadget
 
 [ ] [
@@ -41,15 +41,15 @@ IN: ui.gadgets.scrollers.tests
 [ ] [ "s" get layout ] unit-test
 
 "s" get [
-    [ { 34 34 } ] [ "s" get viewport>> dim>> ] unit-test
+    [ { 31 31 } ] [ "s" get viewport>> dim>> ] unit-test
 
-    [ { 107 107 } ] [ "s" get viewport>> viewport-dim ] unit-test
+    [ { 100 100 } ] [ "s" get viewport>> gadget-child pref-dim ] unit-test
 
     [ ] [ { 0 0 } "s" get scroll ] unit-test
 
     [ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test
 
-    [ { 107 107 } ] [ "s" get model>> range-max-value ] unit-test
+    [ { 100 100 } ] [ "s" get model>> range-max-value ] unit-test
 
     [ ] [ { 10 20 } "s" get scroll ] unit-test
 
@@ -57,7 +57,7 @@ IN: ui.gadgets.scrollers.tests
 
     [ { 10 20 } ] [ "s" get viewport>> model>> range-value ] unit-test
 
-    [ { 10 20 } ] [ "g" get loc>> vneg viewport-gap v+ scroller-border v+ ] unit-test
+    [ { 10 20 } ] [ "g" get loc>> vneg ] unit-test
 ] with-grafted-gadget
 
 <gadget> { 600 400 } >>dim "g1" set
@@ -75,7 +75,7 @@ dup layout
         "g2" get scroll>gadget
         "s" get layout
         "s" get scroller-value
-    ] map [ { 3 0 } = ] all?
+    ] map [ { 0 0 } = ] all?
 ] unit-test
 
 [ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
@@ -84,8 +84,8 @@ dup layout
 [ t ] [ "l" get dup find-scroller viewport>> swap child? ] unit-test
 [ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
 [ f ] [ "s" get viewport>> find-scroller* ] unit-test
-[ t ] [ "s" get @right grid-child slider? ] unit-test
+[ t ] [ "s" get { 1 0 } grid-child slider? ] unit-test
-[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
+[ f ] [ "s" get { 1 0 } grid-child find-scroller* ] unit-test
 
 [ ] [
     "Click Me" [ [ scroll>gadget ] [ unparent ] bi ] <border-button>
@@ -102,7 +102,7 @@ dup layout
     swap dup quot>> call
     dup layout
     model>> dependencies>> [ range-max value>> ] map
-    viewport-padding =
+    { 0 0 } =
 ] unit-test
 
 \ <scroller> must-infer

basis/ui/gadgets/scrollers/scrollers.factor

@@ -9,6 +9,11 @@ IN: ui.gadgets.scrollers
 
 TUPLE: scroller < frame viewport x y follows ;
 
+! Scrollable gadget protocol; optional
+GENERIC: pref-viewport-dim ( gadget -- dim )
+
+M: gadget pref-viewport-dim pref-dim ;
+
 : find-scroller ( gadget -- scroller/f )
     [ scroller? ] find-parent ;
 
@@ -20,6 +25,8 @@ TUPLE: scroller < frame viewport x y follows ;
 
 : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
 
+<PRIVATE
+
 : do-mouse-scroll ( scroller -- )
     scroll-direction get-global
     [ first swap x>> slide-by-line ]
@@ -33,33 +40,19 @@ scroller H{
 : <scroller-model> ( -- model )
     0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
 
-: new-scroller ( gadget class -- scroller )
+M: viewport pref-dim* gadget-child pref-viewport-dim ;
-    new-frame
-        t >>root?
-        <scroller-model> >>model
-
-        dup model>> dependencies>>
-        [ first horizontal <slider> [ >>x ] [ @bottom grid-add ] bi ]
-        [ second vertical <slider> [ >>y ] [ @right grid-add ] bi ] bi
-
-        tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi ; inline
-
-: <scroller> ( gadget -- scroller ) scroller new-scroller ;
 
 : scroll ( value scroller -- )
     [
-        viewport>> [ dim>> { 0 0 } ] [ viewport-dim ] bi
+        viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
         4array flip
     ] keep
     2dup control-value = [ 2drop ] [ set-control-value ] if ;
 
-: rect-min ( rect dim -- rect' )
-    [ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
-
 : (scroll>rect) ( rect scroller -- )
-    [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
+    [ [ loc>> ] [ dim>> ] bi <rect> ] dip
     {
-        [ scroller-value vneg offset-rect viewport-gap offset-rect ]
+        [ scroller-value vneg offset-rect ]
         [ viewport>> dim>> rect-min ]
         [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
         [ scroller-value v+ ]
@@ -74,14 +67,6 @@ scroller H{
     { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
     2&& ;
 
-: scroll>rect ( rect gadget -- ) USING: prettyprint io io.streams.c ;
-    global [ over unparse show .c flush ] bind
-    dup find-scroller* dup [
-        [ relative-scroll-rect ] keep
-        swap >>follows
-        relayout
-    ] [ 3drop ] if ;
-
 : (update-scroller) ( scroller -- )
     [ scroller-value ] keep scroll ;
 
@@ -92,22 +77,8 @@ scroller H{
         (scroll>rect)
     ] [ f >>follows (update-scroller) drop ] if ;
 
-: scroll>gadget ( gadget -- )
-    dup find-scroller* dup [
-        swap >>follows
-        relayout
-    ] [
-        2drop
-    ] if ;
-
 : (scroll>bottom) ( scroller -- )
-    [ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
+    [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ;
-
-: scroll>bottom ( gadget -- )
-    find-scroller [ t >>follows relayout-1 ] when* ;
-
-: scroll>top ( gadget -- )
-    <zero-rect> swap scroll>rect ;
 
 GENERIC: update-scroller ( scroller follows -- )
 
@@ -131,12 +102,38 @@ M: scroller focusable-child*
 M: scroller model-changed
     f >>follows 2drop ;
 
-TUPLE: limited-scroller < scroller
+PRIVATE>
-{ min-dim initial: { 0 0 } }
-{ max-dim initial: { 1/0. 1/0. } } ;
 
-: <limited-scroller> ( gadget -- scroller )
+: <scroller> ( gadget -- scroller )
-    limited-scroller new-scroller ;
+    2 2 scroller new-frame
+        { 1 1 } >>gap
+        { 0 0 } >>filled-cell
+        t >>root?
+        <scroller-model> >>model
 
-M: limited-scroller pref-dim*
+        dup model>> dependencies>>
-    [ call-next-method ] [ min-dim>> vmax ] [ max-dim>> vmin ] tri ;
+        [ first horizontal <slider> [ >>x ] [ { 0 1 } grid-add ] bi ]
+        [ second vertical <slider> [ >>y ] [ { 1 0 } grid-add ] bi ] bi
+
+        tuck model>> <viewport> [ >>viewport ] [ { 0 0 } grid-add ] bi ; inline
+
+: scroll>rect ( rect gadget -- )
+    dup find-scroller* dup [
+        [ relative-scroll-rect ] keep
+        swap >>follows
+        relayout
+    ] [ 3drop ] if ;
+
+: scroll>gadget ( gadget -- )
+    dup find-scroller* dup [
+        swap >>follows
+        relayout
+    ] [
+        2drop
+    ] if ;
+
+: scroll>bottom ( gadget -- )
+    find-scroller [ t >>follows relayout-1 ] when* ;
+
+: scroll>top ( gadget -- )
+    <zero-rect> swap scroll>rect ;

basis/ui/gadgets/viewports/viewports.factor

@@ -5,20 +5,11 @@ kernel math namespaces sequences models math.vectors
 math.rectangles ;
 IN: ui.gadgets.viewports
 
-CONSTANT: viewport-gap { 3 3 }
-CONSTANT: scroller-border { 1 1 }
-
 TUPLE: viewport < gadget ;
 
 : find-viewport ( gadget -- viewport )
     [ viewport? ] find-parent ;
 
-: viewport-padding ( -- padding )
-    viewport-gap 2 v*n scroller-border v+ ;
-
-: viewport-dim ( viewport -- dim )
-    gadget-child pref-dim viewport-padding v+ ;
-
 : <viewport> ( content model -- viewport )
     viewport new-gadget
         swap >>model
@@ -26,33 +17,19 @@ TUPLE: viewport < gadget ;
         swap add-gadget ;
 
 M: viewport layout*
-    [ gadget-child ] [
+    [ gadget-child ]
-        [ dim>> viewport-padding v- ]
+    [ [ dim>> ] [ gadget-child pref-dim ] bi vmax ] bi >>dim drop ;
-        [ gadget-child pref-dim ]
-        bi vmax
-    ] bi >>dim drop ;
 
 M: viewport focusable-child*
     gadget-child ;
 
-M: viewport pref-dim* viewport-dim ;
-
 : scroller-value ( scroller -- loc )
     model>> range-value [ >fixnum ] map ;
 
 M: viewport model-changed
     nip
     [ relayout-1 ]
-    [
+    [ [ gadget-child ] [ scroller-value vneg ] bi >>loc drop ] bi ;
-        [ gadget-child ]
-        [
-            scroller-value vneg
-            viewport-gap v+
-            scroller-border v+
-        ] bi
-        >>loc drop
-    ] bi ;
 
 : visible-dim ( gadget -- dim )
-    dup parent>> viewport?
+    dup parent>> viewport? [ parent>> ] when dim>> ;
-    [ parent>> dim>> viewport-gap 2 v*n v- ] [ dim>> ] if ;