steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Scrollers: add pref-viewport-dim word that child gadgets can implement; clean up layout

db4
Slava Pestov 2009-02-15 03:59:50 -06:00
parent 1b41f85395
commit 074e3238f3
3 changed files with 60 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
basis/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -1,9 +1,9 @@
USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
kernel models models.compose models.range ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.labels ui.gadgets.grids
ui.gadgets.sliders math math.vectors arrays sequences
tools.test.ui math.rectangles accessors ui.gadgets.buttons
ui.gadgets.packs ;
ui.gadgets.packs ui.gadgets.scrollers.private ;
IN: ui.gadgets.scrollers.tests
[ ] [
@ -28,7 +28,7 @@ IN: ui.gadgets.scrollers.tests
"v" get [
[ { 10 20 } ] [ "v" get model>> range-value ] unit-test
[ { 10 20 } ] [ "g" get loc>> vneg viewport-gap v+ scroller-border v+ ] unit-test
[ { 10 20 } ] [ "g" get loc>> vneg ] unit-test
] with-grafted-gadget
[ ] [
@ -41,15 +41,15 @@ IN: ui.gadgets.scrollers.tests
[ ] [ "s" get layout ] unit-test
"s" get [
[ { 34 34 } ] [ "s" get viewport>> dim>> ] unit-test
[ { 31 31 } ] [ "s" get viewport>> dim>> ] unit-test
[ { 107 107 } ] [ "s" get viewport>> viewport-dim ] unit-test
[ { 100 100 } ] [ "s" get viewport>> gadget-child pref-dim ] unit-test
[ ] [ { 0 0 } "s" get scroll ] unit-test
[ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test
[ { 107 107 } ] [ "s" get model>> range-max-value ] unit-test
[ { 100 100 } ] [ "s" get model>> range-max-value ] unit-test
[ ] [ { 10 20 } "s" get scroll ] unit-test
@ -57,7 +57,7 @@ IN: ui.gadgets.scrollers.tests
[ { 10 20 } ] [ "s" get viewport>> model>> range-value ] unit-test
[ { 10 20 } ] [ "g" get loc>> vneg viewport-gap v+ scroller-border v+ ] unit-test
[ { 10 20 } ] [ "g" get loc>> vneg ] unit-test
] with-grafted-gadget
<gadget> { 600 400 } >>dim "g1" set
@ -75,7 +75,7 @@ dup layout
"g2" get scroll>gadget
"s" get layout
"s" get scroller-value
] map [ { 3 0 } = ] all?
] map [ { 0 0 } = ] all?
] unit-test
[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
@ -84,8 +84,8 @@ dup layout
[ t ] [ "l" get dup find-scroller viewport>> swap child? ] unit-test
[ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
[ f ] [ "s" get viewport>> find-scroller* ] unit-test
[ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
[ t ] [ "s" get { 1 0 } grid-child slider? ] unit-test
[ f ] [ "s" get { 1 0 } grid-child find-scroller* ] unit-test
[ ] [
"Click Me" [ [ scroll>gadget ] [ unparent ] bi ] <border-button>
@ -102,7 +102,7 @@ dup layout
swap dup quot>> call
dup layout
model>> dependencies>> [ range-max value>> ] map
viewport-padding =
{ 0 0 } =
] unit-test
\ <scroller> must-infer

93
basis/ui/gadgets/scrollers/scrollers.factor
View File

@ -9,6 +9,11 @@ IN: ui.gadgets.scrollers
TUPLE: scroller < frame viewport x y follows ;
! Scrollable gadget protocol; optional
GENERIC: pref-viewport-dim ( gadget -- dim )
M: gadget pref-viewport-dim pref-dim ;
: find-scroller ( gadget -- scroller/f )
[ scroller? ] find-parent ;
@ -20,6 +25,8 @@ TUPLE: scroller < frame viewport x y follows ;
: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
<PRIVATE
: do-mouse-scroll ( scroller -- )
scroll-direction get-global
[ first swap x>> slide-by-line ]
@ -33,33 +40,19 @@ scroller H{
: <scroller-model> ( -- model )
0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
: new-scroller ( gadget class -- scroller )
new-frame
t >>root?
<scroller-model> >>model
dup model>> dependencies>>
[ first horizontal <slider> [ >>x ] [ @bottom grid-add ] bi ]
[ second vertical <slider> [ >>y ] [ @right grid-add ] bi ] bi
tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi ; inline
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
M: viewport pref-dim* gadget-child pref-viewport-dim ;
: scroll ( value scroller -- )
[
viewport>> [ dim>> { 0 0 } ] [ viewport-dim ] bi
viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
4array flip
] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ;
: rect-min ( rect dim -- rect' )
[ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
: (scroll>rect) ( rect scroller -- )
[ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
[ [ loc>> ] [ dim>> ] bi <rect> ] dip
{
[ scroller-value vneg offset-rect viewport-gap offset-rect ]
[ scroller-value vneg offset-rect ]
[ viewport>> dim>> rect-min ]
[ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
[ scroller-value v+ ]
@ -74,14 +67,6 @@ scroller H{
{ [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
2&& ;
: scroll>rect ( rect gadget -- ) USING: prettyprint io io.streams.c ;
global [ over unparse show .c flush ] bind
dup find-scroller* dup [
[ relative-scroll-rect ] keep
swap >>follows
relayout
] [ 3drop ] if ;
: (update-scroller) ( scroller -- )
[ scroller-value ] keep scroll ;
@ -92,22 +77,8 @@ scroller H{
(scroll>rect)
] [ f >>follows (update-scroller) drop ] if ;
: scroll>gadget ( gadget -- )
dup find-scroller* dup [
swap >>follows
relayout
] [
2drop
] if ;
: (scroll>bottom) ( scroller -- )
[ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
: scroll>bottom ( gadget -- )
find-scroller [ t >>follows relayout-1 ] when* ;
: scroll>top ( gadget -- )
<zero-rect> swap scroll>rect ;
[ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ;
GENERIC: update-scroller ( scroller follows -- )
@ -131,12 +102,38 @@ M: scroller focusable-child*
M: scroller model-changed
f >>follows 2drop ;
TUPLE: limited-scroller < scroller
{ min-dim initial: { 0 0 } }
{ max-dim initial: { 1/0. 1/0. } } ;
PRIVATE>
: <limited-scroller> ( gadget -- scroller )
limited-scroller new-scroller ;
: <scroller> ( gadget -- scroller )
2 2 scroller new-frame
{ 1 1 } >>gap
{ 0 0 } >>filled-cell
t >>root?
<scroller-model> >>model
M: limited-scroller pref-dim*
[ call-next-method ] [ min-dim>> vmax ] [ max-dim>> vmin ] tri ;
dup model>> dependencies>>
[ first horizontal <slider> [ >>x ] [ { 0 1 } grid-add ] bi ]
[ second vertical <slider> [ >>y ] [ { 1 0 } grid-add ] bi ] bi
tuck model>> <viewport> [ >>viewport ] [ { 0 0 } grid-add ] bi ; inline
: scroll>rect ( rect gadget -- )
dup find-scroller* dup [
[ relative-scroll-rect ] keep
swap >>follows
relayout
] [ 3drop ] if ;
: scroll>gadget ( gadget -- )
dup find-scroller* dup [
swap >>follows
relayout
] [
2drop
] if ;
: scroll>bottom ( gadget -- )
find-scroller [ t >>follows relayout-1 ] when* ;
: scroll>top ( gadget -- )
<zero-rect> swap scroll>rect ;

31
basis/ui/gadgets/viewports/viewports.factor
View File

@ -5,20 +5,11 @@ kernel math namespaces sequences models math.vectors
math.rectangles ;
IN: ui.gadgets.viewports
CONSTANT: viewport-gap { 3 3 }
CONSTANT: scroller-border { 1 1 }
TUPLE: viewport < gadget ;
: find-viewport ( gadget -- viewport )
[ viewport? ] find-parent ;
: viewport-padding ( -- padding )
viewport-gap 2 v*n scroller-border v+ ;
: viewport-dim ( viewport -- dim )
gadget-child pref-dim viewport-padding v+ ;
: <viewport> ( content model -- viewport )
viewport new-gadget
swap >>model
@ -26,33 +17,19 @@ TUPLE: viewport < gadget ;
swap add-gadget ;
M: viewport layout*
[ gadget-child ] [
[ dim>> viewport-padding v- ]
[ gadget-child pref-dim ]
bi vmax
] bi >>dim drop ;
[ gadget-child ]
[ [ dim>> ] [ gadget-child pref-dim ] bi vmax ] bi >>dim drop ;
M: viewport focusable-child*
gadget-child ;
M: viewport pref-dim* viewport-dim ;
: scroller-value ( scroller -- loc )
model>> range-value [ >fixnum ] map ;
M: viewport model-changed
nip
[ relayout-1 ]
[
[ gadget-child ]
[
scroller-value vneg
viewport-gap v+
scroller-border v+
] bi
>>loc drop
] bi ;
[ [ gadget-child ] [ scroller-value vneg ] bi >>loc drop ] bi ;
: visible-dim ( gadget -- dim )
dup parent>> viewport?
[ parent>> dim>> viewport-gap 2 v*n v- ] [ dim>> ] if ;
dup parent>> viewport? [ parent>> ] when dim>> ;