basis/ui/gadgets/sliders/sliders.factor

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