Model-ize scrollers

library/ui/gadgets/scrolling.factor

@@ -1,18 +1,13 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-scrolling
-USING: arrays gadgets gadgets-theme gadgets-viewports generic
+USING: arrays gadgets gadgets-theme gadgets-viewports
-kernel math namespaces sequences ;
+gadgets-sliders generic kernel math namespaces sequences
+models ;
 
 ! A scroller combines a viewport with two x and y sliders.
-! The follows slot is a boolean, if true scroller will scroll
+! The follows slot is t or a gadget
-! down on the next relayout.
+TUPLE: scroller viewport x y follows model ;
-TUPLE: scroller viewport x y follows ;
-
-: scroller-origin ( scroller -- point )
-    dup scroller-x slider-value
-    swap scroller-y slider-value
-    2array ;
 
 : find-scroller [ scroller? ] find-parent ;
 
@@ -31,49 +26,55 @@ TUPLE: scroller viewport x y follows ;
 
 scroller H{
     { T{ mouse-scroll } [ do-mouse-scroll ] }
-    { T{ slider-changed } [ relayout-1 ] }
 } set-gestures
 
+: init-scroller-model ( scroller -- point )
+    dup scroller-x control-model
+    over scroller-y control-model
+    2array <compose> swap set-scroller-model ;
+
+: scroller-value scroller-model model-value ;
+
 C: scroller ( gadget -- scroller )
-    #! Wrap a scrolling pane around the gadget.
     {
-        { [ <viewport> ] set-scroller-viewport f @center }
+        { [ <x-slider> ] set-scroller-x f @bottom }
-        { [ <x-slider> ] set-scroller-x        f @bottom }
+        { [ <y-slider> ] set-scroller-y f @right  }
-        { [ <y-slider> ] set-scroller-y        f @right  }
+        {
+            [
+                gadget get
+                dup init-scroller-model
+                scroller-model <viewport>
+            ]
+            set-scroller-viewport f @center
+        }
     } make-frame*
     t over set-gadget-root?
     dup faint-boundary ;
 
 : set-slider ( value page max slider -- )
-    #! page/max/value are 3-vectors.
+    #! page/max/value are 2-vectors.
     [ [ gadget-orientation v. ] keep set-slider-max ] keep
     [ [ gadget-orientation v. ] keep set-slider-page ] keep
-    [ [ gadget-orientation v. ] keep set-slider-value* ] keep
+    [ gadget-orientation v. ] keep set-slider-value ;
-    slider-elevator relayout-1 ;
 
 : update-slider ( scroller value slider -- )
     >r swap scroller-viewport dup rect-dim swap viewport-dim
     r> set-slider ;
 
-: position-viewport ( scroller -- )
-    dup scroller-origin vneg viewport-gap v+
-    swap scroller-viewport gadget-child
-    set-rect-loc ;
-
 : scroll ( scroller value -- )
-    2dup over scroller-x update-slider
+    2dup
-    dupd over scroller-y update-slider
+    over scroller-x update-slider
-    position-viewport ;
+    over scroller-y update-slider ;
 
 : (scroll>rect) ( rect scroller -- )
     [
-        scroller-origin vneg offset-rect
+        scroller-value vneg offset-rect
         viewport-gap offset-rect
     ] keep
     [
         scroller-viewport 2rect-extent
         >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
-    ] keep dup scroller-origin rot v+ scroll ;
+    ] keep dup scroller-value rot v+ scroll ;
 
 : relative-scroll-rect ( rect gadget scroller -- rect )
     #! Adjust rect for the case where the gadget is not the
@@ -91,8 +92,7 @@ C: scroller ( gadget -- scroller )
 
 : scroll>bottom ( gadget -- )
     find-scroller [
-        t over set-scroller-follows
+        t over set-scroller-follows relayout
-        relayout
     ] when* ;
 
 : (scroll>bottom) ( scroller -- )
@@ -110,7 +110,7 @@ C: scroller ( gadget -- scroller )
         ] if
         f swap set-scroller-follows
     ] [
-        dup scroller-origin scroll
+        dup scroller-value scroll
     ] if ;
 
 M: scroller layout*

library/ui/gadgets/viewports.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-viewports
 USING: arrays gadgets gadgets-borders generic kernel math
-namespaces sequences ;
+namespaces sequences models ;
 
 : viewport-gap { 3 3 } ;
 
@@ -13,10 +13,11 @@ TUPLE: viewport ;
 : viewport-dim ( viewport -- dim )
     gadget-child pref-dim viewport-gap 2 v*n v+ ;
 
-C: viewport ( content -- viewport )
+C: viewport ( content model -- viewport )
-    dup delegate>gadget
+    dup rot <gadget> delegate>control
+    t over set-gadget-clipped?
     [ add-gadget ] keep
-    t over set-gadget-clipped? ;
+    [ model-changed ] keep ;
 
 M: viewport layout*
     dup rect-dim viewport-gap 2 v*n v-
@@ -27,3 +28,7 @@ M: viewport focusable-child*
     gadget-child ;
 
 M: viewport pref-dim* viewport-dim ;
+
+M: viewport model-changed
+    dup control-value vneg viewport-gap v+
+    swap gadget-child set-rect-loc ;

library/ui/test/scrolling.factor

@@ -1,5 +1,6 @@
 IN: temporary
-USING: gadgets gadgets-scrolling namespaces test ;
+USING: gadgets gadgets-scrolling namespaces test kernel
+models gadgets-viewports math ;
 
 [ ] [
     <gadget> "g" set
@@ -13,3 +14,22 @@ USING: gadgets gadgets-scrolling namespaces test ;
 
 [ ] [ "s" get scroll>bottom ] unit-test
 [ t ] [ "s" get scroller-follows ] unit-test
+
+[ ] [
+    <gadget> dup "g" set { 10 20 } <model> <viewport> "v" set 
+] unit-test
+
+[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+
+[ ] [
+    <gadget> { 100 100 } over set-rect-dim
+    dup "g" set <scroller> "s" set
+] unit-test
+
+[ ] [ "s" get graft ] unit-test
+
+[ ] [ "s" get { 10 20 } scroll ] unit-test
+
+[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+
+[ ] [ "s" get ungraft ] unit-test