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 math.vectors
   6        ui.commands ui.gadgets ui.gadgets.borders
   7        ui.gadgets.labels ui.gadgets.theme
   8        ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
   9        ui.render math.geometry.rect ;
  10
  11 IN: ui.gadgets.buttons
  12
  13 TUPLE: button < border pressed? selected? quot ;
  14
  15 : buttons-down? ( -- ? )
  16     hand-buttons get-global empty? not ;
  17
  18 : button-rollover? ( button -- ? )
  19     hand-gadget get-global child? ;
  20
  21 : mouse-clicked? ( gadget -- ? )
  22     hand-clicked get-global child? ;
  23
  24 : button-update ( button -- )
  25     dup mouse-clicked?
  26     over button-rollover? and
  27     buttons-down? and
  28     >>pressed?
  29     relayout-1 ;
  30
  31 : if-clicked ( button quot -- )
  32     >r dup button-update dup button-rollover? r> [ drop ] if ;
  33
  34 : button-clicked ( button -- ) dup quot>> if-clicked ;
  35
  36 button H{
  37     { T{ button-up } [ button-clicked ] }
  38     { T{ button-down } [ button-update ] }
  39     { T{ mouse-leave } [ button-update ] }
  40     { T{ mouse-enter } [ button-update ] }
  41 } set-gestures
  42
  43 : new-button ( label quot class -- button )
  44     [ swap >label ] dip new-border swap >>quot ; inline
  45
  46 : <button> ( label quot -- button )
  47     button new-button ;
  48
  49 TUPLE: button-paint plain rollover pressed selected ;
  50
  51 C: <button-paint> button-paint
  52
  53 : find-button ( gadget -- button )
  54     [ button? ] find-parent ;
  55
  56 : button-paint ( button paint -- button paint )
  57     over find-button {
  58         { [ dup pressed?>> ] [ drop pressed>> ] }
  59         { [ dup selected?>> ] [ drop selected>> ] }
  60         { [ dup button-rollover? ] [ drop rollover>> ] }
  61         [ drop plain>> ]
  62     } cond ;
  63
  64 M: button-paint draw-interior
  65     button-paint draw-interior ;
  66
  67 M: button-paint draw-boundary
  68     button-paint draw-boundary ;
  69
  70 : align-left ( button -- button )
  71     { 0 1/2 } >>align ; inline
  72
  73 : roll-button-theme ( button -- button )
  74     f black <solid> dup f <button-paint> >>boundary
  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 color ;
 107
 108 C: <checkmark-paint> checkmark-paint
 109
 110 M: checkmark-paint draw-interior
 111     color>> set-color
 112     origin get [
 113         rect-dim
 114         { 0 0 } over gl-line
 115         dup { 0 1 } v* swap { 1 0 } v* gl-line
 116     ] with-translation ;
 117
 118 : checkmark-theme ( gadget -- gadget )
 119     f
 120     f
 121     black <solid>
 122     black <checkmark-paint>
 123     <button-paint> >>interior
 124     black <solid> >>boundary ;
 125
 126 : <checkmark> ( -- gadget )
 127     <gadget>
 128     checkmark-theme
 129     { 14 14 } >>dim ;
 130
 131 : toggle-model ( model -- )
 132     [ not ] change-model ;
 133
 134 : checkbox-theme ( gadget -- gadget )
 135     f >>interior
 136     { 5 5 } >>gap
 137     1/2 >>align ; inline
 138
 139 TUPLE: checkbox < button ;
 140
 141 : <checkbox> ( model label -- checkbox )
 142     <checkmark> label-on-right checkbox-theme
 143     [ model>> toggle-model ]
 144     checkbox new-button
 145         swap >>model
 146         align-left ;
 147
 148 M: checkbox model-changed
 149     swap value>> >>selected? relayout-1 ;
 150
 151 TUPLE: radio-paint color ;
 152
 153 C: <radio-paint> radio-paint
 154
 155 M: radio-paint draw-interior
 156     color>> set-color
 157     origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
 158
 159 M: radio-paint draw-boundary
 160     color>> set-color
 161     origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
 162
 163 : radio-knob-theme ( gadget -- gadget )
 164     f
 165     f
 166     black <radio-paint>
 167     black <radio-paint>
 168     <button-paint> >>interior
 169     black <radio-paint> >>boundary ;
 170
 171 : <radio-knob> ( -- gadget )
 172     <gadget>
 173     radio-knob-theme
 174     { 16 16 } >>dim ;
 175
 176 TUPLE: radio-control < button value ;
 177
 178 : <radio-control> ( value model label -- control )
 179     [ [ value>> ] keep set-control-value ]
 180     radio-control new-button
 181         swap >>model
 182         swap >>value
 183         align-left ; inline
 184
 185 M: radio-control model-changed
 186     swap value>>
 187     over value>> = >>selected?
 188     relayout-1 ;
 189
 190 : <radio-controls> ( parent model assoc quot -- parent )
 191     #! quot has stack effect ( value model label -- )
 192     swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
 193
 194 : radio-button-theme ( gadget -- gadget )
 195     { 5 5 } >>gap
 196     1/2 >>align ; inline
 197
 198 : <radio-button> ( value model label -- gadget )
 199     <radio-knob> label-on-right radio-button-theme <radio-control> ;
 200
 201 : <radio-buttons> ( model assoc -- gadget )
 202     <filled-pile>
 203         -rot
 204         [ <radio-button> ] <radio-controls>
 205         { 5 5 } >>gap ;
 206
 207 : <toggle-button> ( value model label -- gadget )
 208     <radio-control> bevel-button-theme ;
 209
 210 : <toggle-buttons> ( model assoc -- gadget )
 211     <shelf>
 212         -rot
 213         [ <toggle-button> ] <radio-controls> ;
 214
 215 : command-button-quot ( target command -- quot )
 216     [ invoke-command drop ] 2curry ;
 217
 218 : <command-button> ( target gesture command -- button )
 219     [ command-string ] keep
 220     swapd
 221     command-button-quot
 222     <bevel-button> ;
 223
 224 : <toolbar> ( target -- toolbar )
 225     <shelf>
 226         swap
 227         "toolbar" over class command-map commands>> swap
 228         [ -rot <command-button> add-gadget ] curry assoc-each ;