Model-ize scrollers
parent
5c3dde4f0f
commit
33b3acf90b
|
@ -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*
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue