1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays ui.gadgets ui.gadgets.viewports
4 ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
5 ui.gadgets.sliders ui.gestures kernel math namespaces sequences
6 models models.range models.compose combinators math.vectors
7 classes.tuple math.geometry.rect combinators.short-circuit ;
8 IN: ui.gadgets.scrollers
10 TUPLE: scroller < frame viewport x y follows ;
12 : find-scroller ( gadget -- scroller/f )
13 [ scroller? ] find-parent ;
15 : scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
17 : scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
19 : scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
21 : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
23 : do-mouse-scroll ( scroller -- )
24 scroll-direction get-global
25 [ first swap x>> slide-by-line ]
26 [ second swap y>> slide-by-line ]
30 { mouse-scroll [ do-mouse-scroll ] }
33 : <scroller-model> ( -- model )
34 0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
36 : new-scroller ( gadget class -- scroller )
39 <scroller-model> >>model
41 dup model>> dependencies>>
42 [ first <x-slider> [ >>x ] [ @bottom grid-add ] bi ]
43 [ second <y-slider> [ >>y ] [ @right grid-add ] bi ] bi
45 tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi
47 faint-boundary ; inline
49 : <scroller> ( gadget -- scroller ) scroller new-scroller ;
51 : scroll ( value scroller -- )
53 viewport>> [ dim>> { 0 0 } ] [ viewport-dim ] bi
56 2dup control-value = [ 2drop ] [ set-control-value ] if ;
58 : rect-min ( rect dim -- rect' )
59 [ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
61 : (scroll>rect) ( rect scroller -- )
62 [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
64 [ scroller-value vneg offset-rect viewport-gap offset-rect ]
65 [ viewport>> dim>> rect-min ]
66 [ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
71 : relative-scroll-rect ( rect gadget scroller -- newrect )
72 viewport>> gadget-child relative-loc offset-rect ;
74 : find-scroller* ( gadget -- scroller/f )
76 { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
79 : scroll>rect ( rect gadget -- )
80 dup find-scroller* dup [
81 [ relative-scroll-rect ] keep
86 : (update-scroller) ( scroller -- )
87 [ scroller-value ] keep scroll ;
89 : (scroll>gadget) ( gadget scroller -- )
91 [ [ [ { 0 0 } ] dip pref-dim <rect> ] keep ] dip
92 [ relative-scroll-rect ] keep
94 ] [ f >>follows (update-scroller) drop ] if ;
96 : scroll>gadget ( gadget -- )
97 dup find-scroller* dup [
104 : (scroll>bottom) ( scroller -- )
105 [ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
107 : scroll>bottom ( gadget -- )
108 find-scroller [ t >>follows relayout-1 ] when* ;
110 : scroll>top ( gadget -- )
111 <zero-rect> swap scroll>rect ;
113 GENERIC: update-scroller ( scroller follows -- )
115 M: t update-scroller drop (scroll>bottom) ;
117 M: gadget update-scroller swap (scroll>gadget) ;
119 M: rect update-scroller swap (scroll>rect) ;
121 M: f update-scroller drop (update-scroller) ;
124 [ call-next-method ] [
126 [ update-scroller ] [ >>follows drop ] 2bi
129 M: scroller focusable-child*
132 M: scroller model-changed
135 TUPLE: limited-scroller < scroller
136 { min-dim initial: { 0 0 } }
137 { max-dim initial: { 1/0. 1/0. } } ;
139 : <limited-scroller> ( gadget -- scroller )
140 limited-scroller new-scroller ;
142 M: limited-scroller pref-dim*
143 [ call-next-method ] [ min-dim>> vmax ] [ max-dim>> vmin ] tri ;