1 ! Copyright (C) 2005, 2007 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
4 ui.gadgets.frames ui.gadgets.grids math.order
5 ui.gadgets.theme ui.render kernel math namespaces sequences
6 vectors models models.range math.vectors math.functions
7 quotations colors math.geometry.rect ;
10 TUPLE: elevator < gadget direction ;
12 : find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
14 TUPLE: slider < frame elevator thumb saved line ;
16 : find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
18 : elevator-length ( slider -- n )
19 [ elevator>> dim>> ] [ orientation>> ] bi v. ;
23 : slider-value ( gadget -- n ) model>> range-value >fixnum ;
24 : slider-page ( gadget -- n ) model>> range-page-value ;
25 : slider-max ( gadget -- n ) model>> range-max-value ;
26 : slider-max* ( gadget -- n ) model>> range-max-value* ;
28 : thumb-dim ( slider -- h )
29 dup slider-page over slider-max 1 max / 1 min
30 over elevator-length * min-thumb-dim max
31 over elevator>> rect-dim
32 rot orientation>> v. min ;
34 : slider-scale ( slider -- n )
35 #! A scaling factor such that if x is a slider co-ordinate,
36 #! x*n is the screen position of the thumb, and conversely
37 #! for x/n. The '1 max' calls avoid division by zero.
38 dup elevator-length over thumb-dim - 1 max
39 swap slider-max* 1 max / ;
41 : slider>screen ( m scale -- n ) slider-scale * ;
42 : screen>slider ( m scale -- n ) slider-scale / ;
44 M: slider model-changed nip elevator>> relayout-1 ;
46 TUPLE: thumb < gadget ;
48 : begin-drag ( thumb -- )
49 find-slider dup slider-value >>saved drop ;
51 : do-drag ( thumb -- )
52 find-slider drag-loc over orientation>> v.
53 over screen>slider swap [ saved>> + ] keep
54 model>> set-range-value ;
57 { T{ button-down } [ begin-drag ] }
58 { T{ button-up } [ drop ] }
59 { T{ drag } [ do-drag ] }
62 : thumb-theme ( thumb -- thumb )
63 plain-gradient >>interior
64 faint-boundary ; inline
66 : <thumb> ( vector -- thumb )
72 : slide-by ( amount slider -- ) model>> move-by ;
74 : slide-by-page ( amount slider -- ) model>> move-by-page ;
76 : compute-direction ( elevator -- -1/1 )
77 dup find-slider swap hand-click-rel
80 swap slider-value - sgn ;
82 : elevator-hold ( elevator -- )
83 dup direction>> swap find-slider slide-by-page ;
85 : elevator-click ( elevator -- )
86 dup compute-direction >>direction
90 { T{ drag } [ elevator-hold ] }
91 { T{ button-down } [ elevator-click ] }
94 : <elevator> ( vector -- elevator )
97 lowered-gradient >>interior ;
99 : (layout-thumb) ( slider n -- n thumb )
100 over orientation>> n*v swap thumb>> ;
102 : thumb-loc ( slider -- loc )
103 dup slider-value swap slider>screen ;
105 : layout-thumb-loc ( slider -- )
106 dup thumb-loc (layout-thumb)
107 >r [ floor ] map r> (>>loc) ;
109 : layout-thumb-dim ( slider -- )
110 dup dup thumb-dim (layout-thumb) >r
112 rot orientation>> set-axis [ ceiling ] map
115 : layout-thumb ( slider -- )
116 dup layout-thumb-loc layout-thumb-dim ;
119 find-slider layout-thumb ;
121 : slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
123 : <slide-button> ( vector polygon amount -- button )
124 >r gray swap <polygon-gadget> r>
125 [ swap find-slider slide-by-line ] curry <repeat-button>
128 : elevator, ( gadget orientation -- gadget )
129 tuck <elevator> >>elevator
131 dup elevator>> over thumb>> add-gadget
134 : <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
135 : <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
136 : <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ;
137 : <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
139 : <slider> ( range orientation -- slider )
145 : <x-slider> ( range -- slider )
147 <left-button> @left grid-add
149 <right-button> @right grid-add ;
151 : <y-slider> ( range -- slider )
153 <up-button> @top grid-add
155 <down-button> @bottom grid-add ;
159 swap orientation>> [ 40 v*n ] keep