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