diff --git a/library/ui/gadgets/scrolling.factor b/library/ui/gadgets/scrolling.factor index 6ce714acb3..224e4db478 100644 --- a/library/ui/gadgets/scrolling.factor +++ b/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 -kernel math namespaces sequences ; +USING: arrays gadgets gadgets-theme gadgets-viewports +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 -! down on the next relayout. -TUPLE: scroller viewport x y follows ; - -: scroller-origin ( scroller -- point ) - dup scroller-x slider-value - swap scroller-y slider-value - 2array ; +! The follows slot is t or a gadget +TUPLE: scroller viewport x y follows model ; : 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 swap set-scroller-model ; + +: scroller-value scroller-model model-value ; + C: scroller ( gadget -- scroller ) - #! Wrap a scrolling pane around the gadget. { - { [ ] set-scroller-viewport f @center } - { [ ] set-scroller-x f @bottom } - { [ ] set-scroller-y f @right } + { [ ] set-scroller-x f @bottom } + { [ ] set-scroller-y f @right } + { + [ + gadget get + dup init-scroller-model + scroller-model + ] + 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 - slider-elevator relayout-1 ; + [ gadget-orientation v. ] keep set-slider-value ; : 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 - dupd over scroller-y update-slider - position-viewport ; + 2dup + over scroller-x update-slider + 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 - relayout + t over set-scroller-follows 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* diff --git a/library/ui/gadgets/viewports.factor b/library/ui/gadgets/viewports.factor index b0a305c076..ceaefe1707 100644 --- a/library/ui/gadgets/viewports.factor +++ b/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 ) - dup delegate>gadget +C: viewport ( content model -- viewport ) + dup rot 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 ; diff --git a/library/ui/test/scrolling.factor b/library/ui/test/scrolling.factor index 6a6e2213da..a94bb47a18 100644 --- a/library/ui/test/scrolling.factor +++ b/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 ; [ ] [ "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 + +[ ] [ + dup "g" set { 10 20 } "v" set +] unit-test + +[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test + +[ ] [ + { 100 100 } over set-rect-dim + dup "g" set "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