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