basis/ui/gadgets/sliders/sliders.factor

   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 ;
   8 IN: ui.gadgets.sliders
   9
  10 TUPLE: slider < track elevator thumb saved line ;
  11
  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* ;
  17
  18 : slider-length ( gadget -- n ) [ slider-max ] [ slider-min ] bi - ;
  19 : slider-length* ( gadget -- n ) [ slider-max* ] [ slider-min ] bi - ;
  20
  21 : slide-by ( amount slider -- ) model>> move-by ;
  22 : slide-by-page ( amount slider -- ) model>> move-by-page ;
  23
  24 : slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
  25
  26 <PRIVATE
  27
  28 TUPLE: elevator < gadget direction ;
  29
  30 : find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
  31
  32 CONSTANT: elevator-padding 4
  33
  34 : elevator-length ( slider -- n )
  35     [ elevator>> dim>> ] [ orientation>> ] bi v.
  36     elevator-padding 2 * - ;
  37
  38 CONSTANT: min-thumb-dim 30
  39
  40 : visible-portion ( slider -- n )
  41     [ slider-page ]
  42     [ slider-length 1 max ]
  43     bi / 1 min ;
  44
  45 : thumb-dim ( slider -- h )
  46     [
  47         [ visible-portion ] [ elevator-length ] bi *
  48         min-thumb-dim max
  49     ]
  50     [ elevator-length ] bi min ;
  51
  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 ]
  58     bi / ;
  59
  60 : slider>screen ( m slider -- n ) slider-scale * ;
  61 : screen>slider ( m slider -- n ) slider-scale / ;
  62
  63 M: slider model-changed nip elevator>> relayout-1 ;
  64
  65 TUPLE: thumb < track ;
  66
  67 : begin-drag ( thumb -- )
  68     find-slider dup slider-value >>saved drop ;
  69
  70 : do-drag ( thumb -- )
  71     find-slider {
  72         [ orientation>> drag-loc v. ]
  73         [ screen>slider ]
  74         [ saved>> + ]
  75         [ model>> set-range-value ]
  76     } cleave ;
  77
  78 thumb H{
  79     { T{ button-down } [ begin-drag ] }
  80     { T{ button-up } [ drop ] }
  81     { T{ drag } [ do-drag ] }
  82 } set-gestures
  83
  84 CONSTANT: horizontal-thumb-tiles
  85     {
  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 }
  91     }
  92
  93 CONSTANT: vertical-thumb-tiles
  94     {
  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 }
 100     }
 101
 102 : build-thumb ( thumb -- thumb )
 103     dup orientation>> {
 104         { horizontal [ horizontal-thumb-tiles ] }
 105         { vertical [ vertical-thumb-tiles ] }
 106     } case
 107     [ [ theme-image <icon> ] dip track-add ] assoc-each ;
 108
 109 : <thumb> ( orientation -- thumb )
 110     thumb new-track
 111         0 >>fill
 112         1/2 >>align
 113         build-thumb
 114         t >>root? ;
 115
 116 : compute-direction ( elevator -- -1/1 )
 117     [ hand-click-rel ] [ find-slider ] bi
 118     [ orientation>> v. ]
 119     [ screen>slider ]
 120     [ slider-value - sgn ]
 121     tri ;
 122
 123 : elevator-hold ( elevator -- )
 124     [ direction>> ] [ find-slider ] bi slide-by-page ;
 125
 126 : elevator-click ( elevator -- )
 127     dup compute-direction >>direction
 128     elevator-hold ;
 129
 130 elevator H{
 131     { T{ drag } [ elevator-hold ] }
 132     { T{ button-down } [ elevator-click ] }
 133 } set-gestures
 134
 135 : <elevator> ( vector -- elevator )
 136     elevator new
 137         swap >>orientation ;
 138
 139 : thumb-loc ( slider -- loc )
 140     [ slider-value ]
 141     [ slider-min - ]
 142     [ slider>screen elevator-padding + ] tri ;
 143
 144 : layout-thumb-loc ( thumb slider -- )
 145     [ thumb-loc ] [ orientation>> ] bi n*v vfloor >>loc drop ;
 146
 147 : layout-thumb-dim ( thumb slider -- )
 148     [ dim>> ] [ thumb-dim ] [ orientation>> ] tri [ n*v ] keep set-axis
 149     vceiling >>dim drop ;
 150
 151 : slider-enabled? ( slider -- ? )
 152     visible-portion 1 = not ;
 153
 154 : layout-thumb ( slider -- )
 155     [ thumb>> ] keep
 156     [ slider-enabled? >>visible? drop ]
 157     [ layout-thumb-loc ]
 158     [ layout-thumb-dim ]
 159     2tri ;
 160
 161 M: elevator layout*
 162     find-slider layout-thumb ;
 163
 164 : add-thumb-to-elevator ( object -- object )
 165     [ elevator>> ] [ thumb>> ] bi add-gadget ;
 166
 167 : <slide-button-pen> ( orientation left right -- pen )
 168     [ horizontal = ] 2dip ?
 169     [ f f ] [ theme-image <image-pen> f f ] bi* <button-pen> ;
 170
 171 TUPLE: slide-button < repeat-button ;
 172
 173 : <slide-button> ( orientation amount left right -- button )
 174     [ swap ] 2dip
 175     [
 176         [ <gadget> ] dip
 177         '[ _ swap find-slider slide-by-line ]
 178         slide-button new-button
 179     ] 3dip
 180     <slide-button-pen> >>interior ;
 181
 182 M: slide-button pref-dim* dup interior>> pen-pref-dim ;
 183
 184 : <up-button> ( orientation -- button )
 185     -1
 186     "horizontal-scroller-leftarrow-clicked"
 187     "vertical-scroller-uparrow-clicked"
 188     <slide-button> ;
 189
 190 : <down-button> ( orientation -- button )
 191     1
 192     "horizontal-scroller-rightarrow-clicked"
 193     "vertical-scroller-downarrow-clicked"
 194     <slide-button> ;
 195
 196 TUPLE: slider-pen enabled disabled ;
 197
 198 : <slider-pen> ( orientation -- pen )
 199     {
 200         { horizontal [
 201             "horizontal-scroller-left" theme-image
 202             "horizontal-scroller-middle" theme-image
 203             "horizontal-scroller-right" theme-image
 204             "horizontal-scroller-right-disabled" theme-image
 205         ] }
 206         { vertical [
 207             "vertical-scroller-top" theme-image
 208             "vertical-scroller-middle" theme-image
 209             "vertical-scroller-bottom" theme-image
 210             "vertical-scroller-bottom-disabled" theme-image
 211         ] }
 212     } case
 213     [ f f <tile-pen> ] bi-curry@ 2bi \ slider-pen boa ;
 214
 215 : slider-pen ( slider pen -- pen )
 216     [ slider-enabled? ] [ [ enabled>> ] [ disabled>> ] bi ] bi* ? ;
 217
 218 M: slider-pen draw-interior
 219     dupd slider-pen draw-interior ;
 220
 221 M: slider-pen draw-boundary
 222     dupd slider-pen draw-boundary ;
 223
 224 M: slider-pen pen-pref-dim
 225     enabled>> pen-pref-dim ;
 226
 227 M: slider pref-dim*
 228     [ dup interior>> pen-pref-dim ] [ drop { 100 100 } ] [ orientation>> ] tri
 229     set-axis ;
 230
 231 PRIVATE>
 232
 233 : <slider> ( range orientation -- slider )
 234     slider new-track
 235         swap >>model
 236         16 >>line
 237         dup orientation>> {
 238             [ <slider-pen> >>interior ]
 239             [ <thumb> >>thumb ]
 240             [ <elevator> >>elevator ]
 241             [ drop dup add-thumb-to-elevator 1 track-add ]
 242             [ <up-button> f track-add ]
 243             [ <down-button> f track-add ]
 244             [ drop <gadget> { 1 1 } >>dim f track-add ]
 245         } cleave ;
 246