basis/ui/gadgets/buttons/buttons.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays kernel math models namespaces sequences
   4 strings quotations assocs combinators classes colors
   5 classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
   6 ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
   7 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
   8 ui.render math.geometry.rect locals alien.c-types
   9 specialized-arrays.float fry combinators.smart ;
  10 IN: ui.gadgets.buttons
  11
  12 TUPLE: button < border pressed? selected? quot ;
  13
  14 : buttons-down? ( -- ? )
  15     hand-buttons get-global empty? not ;
  16
  17 : button-rollover? ( button -- ? )
  18     hand-gadget get-global child? ;
  19
  20 : mouse-clicked? ( gadget -- ? )
  21     hand-clicked get-global child? ;
  22
  23 : button-update ( button -- )
  24     dup mouse-clicked?
  25     over button-rollover? and
  26     buttons-down? and
  27     >>pressed?
  28     relayout-1 ;
  29
  30 : if-clicked ( button quot -- )
  31     [ dup button-update dup button-rollover? ] dip [ drop ] if ;
  32
  33 : button-clicked ( button -- ) dup quot>> if-clicked ;
  34
  35 button H{
  36     { T{ button-up } [ button-clicked ] }
  37     { T{ button-down } [ button-update ] }
  38     { T{ mouse-leave } [ button-update ] }
  39     { T{ mouse-enter } [ button-update ] }
  40 } set-gestures
  41
  42 : new-button ( label quot class -- button )
  43     [ swap >label ] dip new-border swap >>quot ; inline
  44
  45 : <button> ( label quot -- button )
  46     button new-button ;
  47
  48 TUPLE: button-paint plain rollover pressed selected ;
  49
  50 C: <button-paint> button-paint
  51
  52 : find-button ( gadget -- button )
  53     [ button? ] find-parent ;
  54
  55 : button-paint ( button paint -- button paint )
  56     over find-button {
  57         { [ dup pressed?>> ] [ drop pressed>> ] }
  58         { [ dup selected?>> ] [ drop selected>> ] }
  59         { [ dup button-rollover? ] [ drop rollover>> ] }
  60         [ drop plain>> ]
  61     } cond ;
  62
  63 M: button-paint draw-interior
  64     button-paint dup [ draw-interior ] [ 2drop ] if ;
  65
  66 M: button-paint draw-boundary
  67     button-paint dup [ draw-boundary ] [ 2drop ] if ;
  68
  69 : align-left ( button -- button )
  70     { 0 1/2 } >>align ; inline
  71
  72 : roll-button-theme ( button -- button )
  73     f black <solid> dup f <button-paint> >>boundary
  74     f f pressed-gradient f <button-paint> >>interior
  75     align-left ; inline
  76
  77 : <roll-button> ( label quot -- button )
  78     <button> roll-button-theme ;
  79
  80 : <bevel-button-paint> ( -- paint )
  81     plain-gradient
  82     rollover-gradient
  83     pressed-gradient
  84     selected-gradient
  85     <button-paint> ;
  86
  87 : bevel-button-theme ( gadget -- gadget )
  88     <bevel-button-paint> >>interior
  89     { 5 5 } >>size
  90     faint-boundary ; inline
  91
  92 : <bevel-button> ( label quot -- button )
  93     <button> bevel-button-theme ;
  94
  95 TUPLE: repeat-button < button ;
  96
  97 repeat-button H{
  98     { T{ drag } [ button-clicked ] }
  99 } set-gestures
 100
 101 : <repeat-button> ( label quot -- button )
 102     #! Button that calls the quotation every 100ms as long as
 103     #! the mouse is held down.
 104     repeat-button new-button bevel-button-theme ;
 105
 106 TUPLE: checkmark-paint < caching-pen color last-vertices ;
 107
 108 : <checkmark-paint> ( color -- paint )
 109     checkmark-paint new swap >>color ;
 110
 111 <PRIVATE
 112
 113 : checkmark-points ( dim -- points )
 114     [
 115         {
 116             [ { 0 0 } v* { 0.5 0.5 } v+ ]
 117             [ { 1 1 } v* { 0.5 0.5 } v+ ]
 118             [ { 1 0 } v* { -0.3 0.5 } v+ ]
 119             [ { 0 1 } v* { -0.3 0.5 } v+ ]
 120         } cleave
 121     ] output>array ;
 122
 123 : checkmark-vertices ( dim -- vertices )
 124     checkmark-points concat >float-array ;
 125
 126 PRIVATE>
 127
 128 M: checkmark-paint recompute-pen
 129     swap dim>> checkmark-vertices >>last-vertices drop ;
 130
 131 M: checkmark-paint draw-interior
 132     [ compute-pen ]
 133     [ color>> gl-color ]
 134     [ last-vertices>> gl-vertex-pointer ] tri
 135     GL_LINES 0 4 glDrawArrays ;
 136
 137 : checkmark-theme ( gadget -- gadget )
 138     f
 139     f
 140     black <solid>
 141     black <checkmark-paint>
 142     <button-paint> >>interior
 143     black <solid> >>boundary ;
 144
 145 : <checkmark> ( -- gadget )
 146     <gadget>
 147     checkmark-theme
 148     { 14 14 } >>dim ;
 149
 150 : toggle-model ( model -- )
 151     [ not ] change-model ;
 152
 153 : checkbox-theme ( gadget -- gadget )
 154     f >>interior
 155     { 5 5 } >>gap
 156     1/2 >>align ; inline
 157
 158 TUPLE: checkbox < button ;
 159
 160 : <checkbox> ( model label -- checkbox )
 161     <checkmark> label-on-right checkbox-theme
 162     [ model>> toggle-model ]
 163     checkbox new-button
 164         swap >>model
 165         align-left ;
 166
 167 M: checkbox model-changed
 168     swap value>> >>selected? relayout-1 ;
 169
 170 TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
 171
 172 : <radio-paint> ( color -- paint ) radio-paint new swap >>color ;
 173
 174 <PRIVATE
 175
 176 CONSTANT: circle-steps 8
 177
 178 PRIVATE>
 179
 180 M: radio-paint recompute-pen
 181     swap dim>>
 182     [ { 4 4 } swap { 9 9 } v- circle-steps fill-circle-vertices >>interior-vertices ]
 183     [ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
 184     drop ;
 185
 186 <PRIVATE
 187
 188 : (radio-paint) ( gadget paint -- )
 189     [ compute-pen ] [ color>> gl-color ] bi ;
 190
 191 PRIVATE>
 192
 193 M: radio-paint draw-interior
 194     [ (radio-paint) ] [ interior-vertices>> gl-vertex-pointer ] bi
 195     GL_POLYGON 0 circle-steps glDrawArrays ;
 196
 197 M: radio-paint draw-boundary
 198     [ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
 199     GL_LINE_STRIP 0 circle-steps 1+ glDrawArrays ;
 200
 201 :: radio-knob-theme ( gadget -- gadget )
 202     [let | radio-paint [ black <radio-paint> ] |
 203         gadget
 204         f f radio-paint radio-paint <button-paint> >>interior
 205         radio-paint >>boundary
 206         { 16 16 } >>dim
 207     ] ;
 208
 209 : <radio-knob> ( -- gadget )
 210     <gadget> radio-knob-theme ;
 211
 212 TUPLE: radio-control < button value ;
 213
 214 : <radio-control> ( value model label -- control )
 215     [ [ value>> ] keep set-control-value ]
 216     radio-control new-button
 217         swap >>model
 218         swap >>value
 219         align-left ; inline
 220
 221 M: radio-control model-changed
 222     swap value>>
 223     over value>> = >>selected?
 224     relayout-1 ;
 225
 226 : <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
 227     '[ _ swap _ call add-gadget ] assoc-each ; inline
 228
 229 : radio-button-theme ( gadget -- gadget )
 230     { 5 5 } >>gap
 231     1/2 >>align ; inline
 232
 233 : <radio-button> ( value model label -- gadget )
 234     <radio-knob> label-on-right radio-button-theme <radio-control> ;
 235
 236 : <radio-buttons> ( model assoc -- gadget )
 237     <filled-pile>
 238         spin [ <radio-button> ] <radio-controls>
 239         { 5 5 } >>gap ;
 240
 241 : <toggle-button> ( value model label -- gadget )
 242     <radio-control> bevel-button-theme ;
 243
 244 : <toggle-buttons> ( model assoc -- gadget )
 245     <shelf>
 246         spin [ <toggle-button> ] <radio-controls> ;
 247
 248 : command-button-quot ( target command -- quot )
 249     '[ _ _ invoke-command drop ] ;
 250
 251 : <command-button> ( target gesture command -- button )
 252     [ command-string swap ] keep command-button-quot <bevel-button> ;
 253
 254 : <toolbar> ( target -- toolbar )
 255     <shelf>
 256         swap
 257         "toolbar" over class command-map commands>> swap
 258         '[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ;
 259
 260 : add-toolbar ( track -- track )
 261     dup <toolbar> f track-add ;