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.sliders
5 ui.gestures kernel math namespaces sequences models models.range
6 models.product combinators math.vectors classes.tuple
7 math.rectangles combinators.short-circuit ;
8 IN: ui.gadgets.scrollers
10 TUPLE: scroller < frame column-header viewport x y follows ;
12 ! Scrollable gadget protocol; optional
13 GENERIC: pref-viewport-dim ( gadget -- dim )
15 M: gadget pref-viewport-dim pref-dim ;
17 GENERIC: viewport-column-header ( gadget -- gadget/f )
19 M: gadget viewport-column-header drop f ;
21 : find-scroller ( gadget -- scroller/f )
22 [ scroller? ] find-parent ;
24 : scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
26 : scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
28 : scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
30 : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
34 : do-mouse-scroll ( scroller -- )
35 scroll-direction get-global
36 [ first swap x>> slide-by-line ]
37 [ second swap y>> slide-by-line ]
41 { mouse-scroll [ do-mouse-scroll ] }
44 : <scroller-model> ( -- model )
45 0 0 0 0 <range> 0 0 0 0 <range> 2array <product> ;
47 M: viewport pref-dim* gadget-child pref-viewport-dim ;
49 : scroll ( value scroller -- )
51 viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
54 2dup control-value = [ 2drop ] [ set-control-value ] if ;
56 : (scroll>rect) ( rect scroller -- )
57 [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
59 [ scroller-value vneg offset-rect ]
60 [ viewport>> dim>> rect-min ]
61 [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
66 : relative-scroll-rect ( rect gadget scroller -- newrect )
67 viewport>> gadget-child relative-loc offset-rect ;
69 : find-scroller* ( gadget -- scroller/f )
71 { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
74 : (update-scroller) ( scroller -- )
75 [ scroller-value ] keep scroll ;
77 : (scroll>gadget) ( gadget scroller -- )
79 [ [ [ { 0 0 } ] dip pref-dim <rect> ] keep ] dip
80 [ relative-scroll-rect ] keep
82 ] [ f >>follows (update-scroller) drop ] if ;
84 : (scroll>bottom) ( scroller -- )
85 [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ;
87 GENERIC: update-scroller ( scroller follows -- )
89 M: t update-scroller drop (scroll>bottom) ;
91 M: gadget update-scroller swap (scroll>gadget) ;
93 M: rect update-scroller swap (scroll>rect) ;
95 M: f update-scroller drop (update-scroller) ;
98 [ call-next-method ] [
100 [ update-scroller ] [ >>follows drop ] 2bi
103 M: scroller focusable-child*
106 M: scroller model-changed
109 : build-scroller ( scroller -- scroller )
110 dup x>> { 0 1 } grid-add
111 dup y>> { 1 0 } grid-add
112 dup viewport>> { 0 0 } grid-add ; inline
114 : <column-header-viewport> ( scroller -- viewport )
115 [ column-header>> ] [ model>> ] bi
116 <viewport> horizontal >>constraint ;
118 : build-header-scroller ( scroller -- scroller )
119 dup <column-header-viewport> { 0 0 } grid-add
120 dup x>> { 0 2 } grid-add
121 dup y>> { 1 1 } grid-add
122 dup viewport>> { 0 1 } grid-add ; inline
124 : init-scroller ( column-header scroller -- scroller )
126 over { 0 1 } { 0 0 } ? >>filled-cell
128 <scroller-model> >>model
129 swap >>column-header ; inline
131 : build-children ( gadget scroller -- scroller )
132 dup model>> dependencies>>
133 [ first horizontal <slider> >>x ]
134 [ second vertical <slider> >>y ] bi
135 [ nip ] [ model>> <viewport> ] 2bi >>viewport ; inline
139 : <scroller> ( gadget -- scroller )
140 dup viewport-column-header
141 dup [ 2 3 ] [ 2 2 ] if scroller new-frame
145 [ build-header-scroller ] [ build-scroller ] if ;
147 : scroll>rect ( rect gadget -- )
148 dup find-scroller* dup [
149 [ relative-scroll-rect ] keep
154 : scroll>gadget ( gadget -- )
155 dup find-scroller* dup [
162 : scroll>bottom ( gadget -- )
163 find-scroller [ t >>follows relayout-1 ] when* ;
165 : scroll>top ( gadget -- )
166 <zero-rect> swap scroll>rect ;