basis/ui/gadgets/sliders/sliders.factor

   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 fry ;
   8 IN: ui.gadgets.sliders
   9
  10 TUPLE: elevator < gadget direction ;
  11
  12 : find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
  13
  14 TUPLE: slider < frame elevator thumb saved line ;
  15
  16 : find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
  17
  18 : elevator-length ( slider -- n )
  19   [ elevator>> dim>> ] [ orientation>> ] bi v. ;
  20
  21 : min-thumb-dim 15 ;
  22
  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*    ;
  27
  28 : thumb-dim ( slider -- h )
  29     [
  30         [ [ slider-page ] [ slider-max 1 max ] bi / 1 min ]
  31         [ elevator-length ] bi * min-thumb-dim max
  32     ]
  33     [ [ elevator>> dim>> ] [ orientation>> ] bi v. ] bi min ;
  34
  35 : slider-scale ( slider -- n )
  36     #! A scaling factor such that if x is a slider co-ordinate,
  37     #! x*n is the screen position of the thumb, and conversely
  38     #! for x/n. The '1 max' calls avoid division by zero.
  39     [ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
  40     [ slider-max* 1 max ]
  41     bi / ;
  42
  43 : slider>screen ( m scale -- n ) slider-scale * ;
  44 : screen>slider ( m scale -- n ) slider-scale / ;
  45
  46 M: slider model-changed nip elevator>> relayout-1 ;
  47
  48 TUPLE: thumb < gadget ;
  49
  50 : begin-drag ( thumb -- )
  51     find-slider dup slider-value >>saved drop ;
  52
  53 : do-drag ( thumb -- )
  54     find-slider drag-loc over orientation>> v.
  55     over screen>slider swap [ saved>> + ] keep
  56     model>> set-range-value ;
  57
  58 thumb H{
  59     { T{ button-down } [ begin-drag ] }
  60     { T{ button-up } [ drop ] }
  61     { T{ drag } [ do-drag ] }
  62 } set-gestures
  63
  64 : thumb-theme ( thumb -- thumb )
  65     plain-gradient >>interior
  66     faint-boundary ; inline
  67
  68 : <thumb> ( vector -- thumb )
  69     thumb new-gadget
  70         swap >>orientation
  71         t >>root?
  72     thumb-theme ;
  73
  74 : slide-by ( amount slider -- ) model>> move-by ;
  75
  76 : slide-by-page ( amount slider -- ) model>> move-by-page ;
  77
  78 : compute-direction ( elevator -- -1/1 )
  79     dup find-slider swap hand-click-rel
  80     over orientation>> v.
  81     over screen>slider
  82     swap slider-value - sgn ;
  83
  84 : elevator-hold ( elevator -- )
  85     dup direction>> swap find-slider slide-by-page ;
  86
  87 : elevator-click ( elevator -- )
  88     dup compute-direction >>direction
  89     elevator-hold ;
  90
  91 elevator H{
  92     { T{ drag } [ elevator-hold ] }
  93     { T{ button-down } [ elevator-click ] }
  94 } set-gestures
  95
  96 : <elevator> ( vector -- elevator )
  97   elevator new-gadget
  98     swap             >>orientation
  99     lowered-gradient >>interior ;
 100
 101 : (layout-thumb) ( slider n -- n thumb )
 102     over orientation>> n*v swap thumb>> ;
 103
 104 : thumb-loc ( slider -- loc )
 105     dup slider-value swap slider>screen ;
 106
 107 : layout-thumb-loc ( slider -- )
 108     dup thumb-loc (layout-thumb)
 109     [ [ floor ] map ] dip (>>loc) ;
 110
 111 : layout-thumb-dim ( slider -- )
 112     dup dup thumb-dim (layout-thumb)
 113     [
 114         [ [ rect-dim ] dip ] [ drop orientation>> ] 2bi set-axis
 115         [ ceiling ] map
 116     ] dip (>>dim) ;
 117
 118 : layout-thumb ( slider -- )
 119     dup layout-thumb-loc layout-thumb-dim ;
 120
 121 M: elevator layout*
 122     find-slider layout-thumb ;
 123
 124 : slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
 125
 126 : <slide-button> ( vector polygon amount -- button )
 127     [ gray swap <polygon-gadget> ] dip
 128     '[ _ swap find-slider slide-by-line ] <repeat-button>
 129     swap >>orientation ;
 130
 131 : elevator, ( gadget orientation -- gadget )
 132     tuck <elevator> >>elevator
 133     swap <thumb> >>thumb
 134     dup elevator>> over thumb>> add-gadget
 135     @center grid-add ;
 136
 137 : <left-button>  ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
 138 : <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
 139 : <up-button>    ( -- button ) { 1 0 } arrow-up   -1 <slide-button> ;
 140 : <down-button>  ( -- button ) { 1 0 } arrow-down  1 <slide-button> ;
 141
 142 : <slider> ( range orientation -- slider )
 143     slider new-frame
 144         swap >>orientation
 145         swap >>model
 146         32 >>line ;
 147
 148 : <x-slider> ( range -- slider )
 149     { 1 0 } <slider>
 150         <left-button> @left grid-add
 151         { 0 1 } elevator,
 152         <right-button> @right grid-add ;
 153
 154 : <y-slider> ( range -- slider )
 155     { 0 1 } <slider>
 156         <up-button> @top grid-add
 157         { 1 0 } elevator,
 158         <down-button> @bottom grid-add ;
 159
 160 M: slider pref-dim*
 161     dup call-next-method
 162     swap orientation>> [ 40 v*n ] keep
 163     set-axis ;