Rename scroll word to set-scroll-position and make it public

db4
Slava Pestov 2009-04-05 23:18:25 -05:00
parent 687e9f90fe
commit 8bf5fde791
4 changed files with 20 additions and 19 deletions

View File

@ -11,11 +11,11 @@ HELP: find-scroller
{ $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
HELP: scroller-value
HELP: scroll-position
{ $values { "scroller" scroller } { "loc" "a pair of integers" } }
{ $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words
{ scroll-position scroll scroll>bottom scroll>top scroll>rect } related-words
HELP: <scroller>
{ $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } }
@ -48,8 +48,8 @@ ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets"
{ $subsection scroller }
{ $subsection <scroller> }
"Getting and setting the scroll position:"
{ $subsection scroller-value }
{ $subsection scroll }
{ $subsection scroll-position }
{ $subsection set-scroll-position }
"Writing scrolling-aware gadgets:"
{ $subsection scroll>bottom }
{ $subsection scroll>top }

View File

@ -74,7 +74,7 @@ dup layout
drop
"g2" get scroll>gadget
"s" get layout
"s" get scroller-value
"s" get scroll-position
] map [ { 0 0 } = ] all?
] unit-test

View File

@ -29,6 +29,13 @@ M: gadget viewport-column-header drop f ;
: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
: set-scroll-position ( value scroller -- )
[
viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
4array flip
] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ;
<PRIVATE
: do-mouse-scroll ( scroller -- )
@ -46,21 +53,14 @@ scroller H{
M: viewport pref-dim* gadget-child pref-viewport-dim ;
: scroll ( value scroller -- )
[
viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
4array flip
] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ;
: (scroll>rect) ( rect scroller -- )
{
[ scroller-value vneg offset-rect ]
[ scroll-position vneg offset-rect ]
[ viewport>> dim>> rect-min ]
[ viewport>> loc>> offset-rect ]
[ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
[ scroller-value v+ ]
[ scroll ]
[ scroll-position v+ ]
[ set-scroll-position ]
} cleave ;
: relative-scroll-rect ( rect gadget scroller -- newrect )
@ -72,7 +72,7 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
2&& ;
: (update-scroller) ( scroller -- )
[ scroller-value ] keep scroll ;
[ scroll-position ] keep set-scroll-position ;
: (scroll>gadget) ( gadget scroller -- )
2dup swap child? [
@ -82,7 +82,8 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
] [ f >>follows (update-scroller) drop ] if ;
: (scroll>bottom) ( scroller -- )
[ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ;
[ viewport>> gadget-child pref-dim { 0 1 } v* ] keep
set-scroll-position ;
GENERIC: update-scroller ( scroller follows -- )

View File

@ -23,7 +23,7 @@ M: viewport layout*
M: viewport focusable-child*
gadget-child ;
: scroller-value ( scroller -- loc )
: scroll-position ( scroller -- loc )
model>> range-value [ >integer ] map ;
M: viewport model-changed
@ -31,7 +31,7 @@ M: viewport model-changed
[ relayout-1 ]
[
[ gadget-child ]
[ scroller-value vneg ]
[ scroll-position vneg ]
[ constraint>> ]
tri v* >>loc drop
] bi ;