1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs kernel math namespaces sequences
4 vectors models models.range math.vectors math.functions quotations
5 colors colors.constants math.rectangles fry combinators ui.gestures
6 ui.pens ui.gadgets ui.gadgets.buttons ui.gadgets.tracks math.order
7 ui.gadgets.icons ui.gadgets.theme ui.pens.tile ui.pens.image ;
10 TUPLE: slider < track elevator thumb saved line ;
12 : slider-value ( gadget -- n ) model>> range-value ;
13 : slider-page ( gadget -- n ) model>> range-page-value ;
14 : slider-min ( gadget -- n ) model>> range-min-value ;
15 : slider-max ( gadget -- n ) model>> range-max-value ;
16 : slider-max* ( gadget -- n ) model>> range-max-value* ;
18 : slider-length ( gadget -- n ) [ slider-max ] [ slider-min ] bi - ;
19 : slider-length* ( gadget -- n ) [ slider-max* ] [ slider-min ] bi - ;
21 : slide-by ( amount slider -- ) model>> move-by ;
22 : slide-by-page ( amount slider -- ) model>> move-by-page ;
24 : slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
28 TUPLE: elevator < gadget direction ;
30 : find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
32 CONSTANT: elevator-padding 4
34 : elevator-length ( slider -- n )
35 [ elevator>> dim>> ] [ orientation>> ] bi v.
36 elevator-padding 2 * - ;
38 CONSTANT: min-thumb-dim 30
40 : visible-portion ( slider -- n )
42 [ slider-length 1 max ]
45 : thumb-dim ( slider -- h )
47 [ visible-portion ] [ elevator-length ] bi *
50 [ elevator-length ] bi min ;
52 : slider-scale ( slider -- n )
53 #! A scaling factor such that if x is a slider co-ordinate,
54 #! x*n is the screen position of the thumb, and conversely
55 #! for x/n. The '1 max' calls avoid division by zero.
56 [ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
57 [ slider-length* 1 max ]
60 : slider>screen ( m slider -- n ) slider-scale * ;
61 : screen>slider ( m slider -- n ) slider-scale / ;
63 M: slider model-changed nip elevator>> relayout-1 ;
65 TUPLE: thumb < track ;
67 : begin-drag ( thumb -- )
68 find-slider dup slider-value >>saved drop ;
70 : do-drag ( thumb -- )
72 [ orientation>> drag-loc v. ]
75 [ model>> set-range-value ]
79 { T{ button-down } [ begin-drag ] }
80 { T{ button-up } [ drop ] }
81 { T{ drag } [ do-drag ] }
84 CONSTANT: horizontal-thumb-tiles
86 { "horizontal-scroller-handle-left" f }
87 { "horizontal-scroller-handle-middle" 1/2 }
88 { "horizontal-scroller-handle-grip" f }
89 { "horizontal-scroller-handle-middle" 1/2 }
90 { "horizontal-scroller-handle-right" f }
93 CONSTANT: vertical-thumb-tiles
95 { "vertical-scroller-handle-top" f }
96 { "vertical-scroller-handle-middle" 1/2 }
97 { "vertical-scroller-handle-grip" f }
98 { "vertical-scroller-handle-middle" 1/2 }
99 { "vertical-scroller-handle-bottom" f }
102 : build-thumb ( thumb -- thumb )
104 { horizontal [ horizontal-thumb-tiles ] }
105 { vertical [ vertical-thumb-tiles ] }
107 [ [ theme-image <icon> ] dip track-add ] assoc-each ;
109 : <thumb> ( orientation -- thumb )
116 : compute-direction ( elevator -- -1/1 )
117 [ hand-click-rel ] [ find-slider ] bi
120 [ slider-value - sgn ]
123 : elevator-hold ( elevator -- )
124 [ direction>> ] [ find-slider ] bi slide-by-page ;
126 : elevator-click ( elevator -- )
127 dup compute-direction >>direction
131 { T{ drag } [ elevator-hold ] }
132 { T{ button-down } [ elevator-click ] }
135 : <elevator> ( vector -- elevator )
139 : thumb-loc ( slider -- loc )
142 [ slider>screen elevator-padding + ] tri ;
144 : layout-thumb-loc ( thumb slider -- )
145 [ thumb-loc ] [ orientation>> ] bi n*v
146 [ floor ] map >>loc drop ;
148 : layout-thumb-dim ( thumb slider -- )
149 [ dim>> ] [ thumb-dim ] [ orientation>> ] tri [ n*v ] keep set-axis
150 [ ceiling ] map >>dim drop ;
152 : slider-enabled? ( slider -- ? )
153 visible-portion 1 = not ;
155 : layout-thumb ( slider -- )
157 [ slider-enabled? >>visible? drop ]
163 find-slider layout-thumb ;
165 : add-thumb-to-elevator ( object -- object )
166 [ elevator>> ] [ thumb>> ] bi add-gadget ;
168 : <slide-button-pen> ( orientation left right -- pen )
169 [ horizontal = ] 2dip ?
170 [ f f ] [ theme-image <image-pen> f f ] bi* <button-pen> ;
172 TUPLE: slide-button < repeat-button ;
174 : <slide-button> ( orientation amount left right -- button )
178 '[ _ swap find-slider slide-by-line ]
179 slide-button new-button
181 <slide-button-pen> >>interior ;
183 M: slide-button pref-dim* dup interior>> pen-pref-dim ;
185 : <up-button> ( orientation -- button )
187 "horizontal-scroller-leftarrow-clicked"
188 "vertical-scroller-uparrow-clicked"
191 : <down-button> ( orientation -- button )
193 "horizontal-scroller-rightarrow-clicked"
194 "vertical-scroller-downarrow-clicked"
197 TUPLE: slider-pen enabled disabled ;
199 : <slider-pen> ( orientation -- pen )
202 "horizontal-scroller-left" theme-image
203 "horizontal-scroller-middle" theme-image
204 "horizontal-scroller-right" theme-image
205 "horizontal-scroller-right-disabled" theme-image
208 "vertical-scroller-top" theme-image
209 "vertical-scroller-middle" theme-image
210 "vertical-scroller-bottom" theme-image
211 "vertical-scroller-bottom-disabled" theme-image
214 [ f f <tile-pen> ] bi-curry@ 2bi \ slider-pen boa ;
216 : slider-pen ( slider pen -- pen )
217 [ slider-enabled? ] [ [ enabled>> ] [ disabled>> ] bi ] bi* ? ;
219 M: slider-pen draw-interior
220 dupd slider-pen draw-interior ;
222 M: slider-pen draw-boundary
223 dupd slider-pen draw-boundary ;
225 M: slider-pen pen-pref-dim
226 enabled>> pen-pref-dim ;
229 [ dup interior>> pen-pref-dim ] [ drop { 100 100 } ] [ orientation>> ] tri
234 : <slider> ( range orientation -- slider )
239 [ <slider-pen> >>interior ]
241 [ <elevator> >>elevator ]
242 [ drop dup add-thumb-to-elevator 1 track-add ]
243 [ <up-button> f track-add ]
244 [ <down-button> f track-add ]
245 [ drop <gadget> { 1 1 } >>dim f track-add ]