Model-ize scrollers

slava 2006-11-27 02:13:03 +00:00
parent 5c3dde4f0f
commit 33b3acf90b
3 changed files with 61 additions and 36 deletions

View File

@ -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 <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 }
{ [ <y-slider> ] set-scroller-y f @right }
{ [ <x-slider> ] set-scroller-x f @bottom }
{ [ <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
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*

View File

@ -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 <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 ;

View File

@ -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