From 074e3238f3367cb459e5e136b9d893198342d3ce Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 15 Feb 2009 03:59:50 -0600
Subject: [PATCH] Scrollers: add pref-viewport-dim word that child gadgets can
implement; clean up layout
---
.../gadgets/scrollers/scrollers-tests.factor | 22 ++---
basis/ui/gadgets/scrollers/scrollers.factor | 93 +++++++++----------
basis/ui/gadgets/viewports/viewports.factor | 31 +------
3 files changed, 60 insertions(+), 86 deletions(-)
diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor
index c05474ba5d..9a8460c90e 100644
--- a/basis/ui/gadgets/scrollers/scrollers-tests.factor
+++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor
@@ -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
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index d655cc474e..5162e2c635 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -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 ;
diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor
index 7f783e5573..d5581f2c23 100644
--- a/basis/ui/gadgets/viewports/viewports.factor
+++ b/basis/ui/gadgets/viewports/viewports.factor
@@ -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>> ;