From 4af2592369d2ddeb41436398b84be36e45a09a6f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 19 Nov 2008 21:58:45 -0600
Subject: [PATCH] Fix some scrollers problems
---
.../gadgets/scrollers/scrollers-tests.factor | 23 ++++++-
basis/ui/gadgets/scrollers/scrollers.factor | 62 ++++++++++---------
2 files changed, 53 insertions(+), 32 deletions(-)
diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor
index 625bfd7880..d6792abd49 100644
--- a/basis/ui/gadgets/scrollers/scrollers-tests.factor
+++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor
@@ -2,7 +2,8 @@ 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.sliders math math.vectors arrays sequences
-tools.test.ui math.geometry.rect accessors ;
+tools.test.ui math.geometry.rect accessors ui.gadgets.buttons
+ui.gadgets.packs ;
IN: ui.gadgets.scrollers.tests
[ ] [
@@ -74,7 +75,7 @@ dup layout
"g2" get scroll>gadget
"s" get layout
"s" get scroller-value
- ] map [ { 3 0 } = ] all?
+ ] map [ { 2 0 } = ] all?
] unit-test
[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
@@ -86,4 +87,22 @@ dup layout
[ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
+[ ] [
+ "Click Me" [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
+ [ <pile> swap add-gadget <scroller> ] keep
+ dup quot>> call
+ layout
+] unit-test
+
+[ t ] [
+ <gadget> { 200 200 } >>dim
+ [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
+ dup
+ <pile> swap add-gadget <scroller> { 100 100 } >>dim dup layout
+ swap dup quot>> call
+ dup layout
+ model>> dependencies>> [ range-max value>> ] map
+ viewport-gap 2 v*n =
+] unit-test
+
\ <scroller> must-infer
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 045ecc7990..37f6e83e0c 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -3,9 +3,8 @@
USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
-models models.range models.compose
-combinators math.vectors classes.tuple math.geometry.rect
-combinators.short-circuit ;
+models models.range models.compose combinators math.vectors
+classes.tuple math.geometry.rect combinators.short-circuit ;
IN: ui.gadgets.scrollers
TUPLE: scroller < frame viewport x y follows ;
@@ -22,9 +21,10 @@ TUPLE: scroller < frame viewport x y follows ;
: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
: do-mouse-scroll ( scroller -- )
- scroll-direction get-global first2
- pick y>> slide-by-line
- swap x>> slide-by-line ;
+ scroll-direction get-global
+ [ first swap x>> slide-by-line ]
+ [ second swap y>> slide-by-line ]
+ 2bi ;
scroller H{
{ T{ mouse-scroll } [ do-mouse-scroll ] }
@@ -49,8 +49,8 @@ scroller H{
: scroll ( value scroller -- )
[
- dup viewport>> rect-dim { 0 0 }
- rot viewport>> viewport-dim 4array flip
+ viewport>> [ rect-dim { 0 0 } ] [ viewport-dim ] bi
+ 4array flip
] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ;
@@ -58,15 +58,14 @@ scroller H{
[ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
: (scroll>rect) ( rect scroller -- )
- [
- scroller-value vneg offset-rect
- viewport-gap offset-rect
- ] keep
- [ viewport>> dim>> rect-min ] keep
- [
- viewport>> 2rect-extent
- [ v- { 1 1 } v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+
- ] keep dup scroller-value rot v+ swap scroll ;
+ [ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
+ {
+ [ scroller-value vneg offset-rect viewport-gap offset-rect ]
+ [ viewport>> dim>> rect-min ]
+ [ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
+ [ scroller-value v+ ]
+ [ scroll ]
+ } cleave ;
: relative-scroll-rect ( rect gadget scroller -- newrect )
viewport>> gadget-child relative-loc offset-rect ;
@@ -81,14 +80,17 @@ scroller H{
[ relative-scroll-rect ] keep
swap >>follows
relayout
- ] [
- 3drop
- ] if ;
+ ] [ 3drop ] if ;
+
+: (update-scroller) ( scroller -- )
+ [ scroller-value ] keep scroll ;
: (scroll>gadget) ( gadget scroller -- )
- >r { 0 0 } over pref-dim <rect> swap r>
- [ relative-scroll-rect ] keep
- (scroll>rect) ;
+ 2dup swap child? [
+ [ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
+ [ relative-scroll-rect ] keep
+ (scroll>rect)
+ ] [ f >>follows (update-scroller) drop ] if ;
: scroll>gadget ( gadget -- )
dup find-scroller* dup [
@@ -99,7 +101,7 @@ scroller H{
] if ;
: (scroll>bottom) ( scroller -- )
- dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
+ [ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
: scroll>bottom ( gadget -- )
find-scroller [ t >>follows relayout-1 ] when* ;
@@ -115,19 +117,19 @@ M: gadget update-scroller swap (scroll>gadget) ;
M: rect update-scroller swap (scroll>rect) ;
-M: f update-scroller drop dup scroller-value swap scroll ;
+M: f update-scroller drop (update-scroller) ;
M: scroller layout*
- dup call-next-method
- dup follows>>
- 2dup update-scroller
- >>follows drop ;
+ [ call-next-method ] [
+ dup follows>>
+ [ update-scroller ] [ >>follows drop ] 2bi
+ ] bi ;
M: scroller focusable-child*
viewport>> ;
M: scroller model-changed
- nip f >>follows drop ;
+ f >>follows 2drop ;
TUPLE: limited-scroller < scroller
{ min-dim initial: { 0 0 } }