basis/ui/gadgets/buttons/buttons.factor

   1 ! Copyright (C) 2005, 2009 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 colors.constants
   5 classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
   6 ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks
   7 ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid
   8 ui.pens.image ui.pens.tile math.rectangles locals fry
   9 combinators.smart ;
  10 IN: ui.gadgets.buttons
  11
  12 TUPLE: button < border pressed? selected? quot ;
  13
  14 <PRIVATE
  15
  16 : find-button ( gadget -- button )
  17     [ button? ] find-parent ;
  18
  19 : buttons-down? ( -- ? )
  20     hand-buttons get-global empty? not ;
  21
  22 : button-rollover? ( button -- ? )
  23     hand-gadget get-global child? ;
  24
  25 : mouse-clicked? ( gadget -- ? )
  26     hand-clicked get-global child? ;
  27
  28 PRIVATE>
  29
  30 : button-update ( button -- )
  31     dup
  32     [ mouse-clicked? ] [ button-rollover? ] bi and
  33     buttons-down? and
  34     >>pressed?
  35     relayout-1 ;
  36
  37 : button-clicked ( button -- )
  38     dup button-update
  39     dup button-rollover?
  40     [ dup quot>> call( button -- ) ] [ drop ] if ;
  41
  42 button H{
  43     { T{ button-up } [ button-clicked ] }
  44     { T{ button-down } [ button-update ] }
  45     { mouse-leave [ button-update ] }
  46     { mouse-enter [ button-update ] }
  47 } set-gestures
  48
  49 : new-button ( label quot class -- button )
  50     [ swap >label ] dip new-border swap >>quot ; inline
  51
  52 : <button> ( label quot -- button )
  53     button new-button ;
  54
  55 TUPLE: button-pen
  56 plain rollover
  57 pressed selected pressed-selected ;
  58
  59 C: <button-pen> button-pen
  60
  61 : button-pen ( button pen -- button pen )
  62     over find-button {
  63         { [ dup [ pressed?>> ] [ selected?>> ] bi and ] [ drop pressed-selected>> ] }
  64         { [ dup pressed?>> ] [ drop pressed>> ] }
  65         { [ dup selected?>> ] [ drop selected>> ] }
  66         { [ dup button-rollover? ] [ drop rollover>> ] }
  67         [ drop plain>> ]
  68     } cond ;
  69
  70 M: button-pen draw-interior
  71     button-pen dup [ draw-interior ] [ 2drop ] if ;
  72
  73 M: button-pen draw-boundary
  74     button-pen dup [ draw-boundary ] [ 2drop ] if ;
  75
  76 M: button-pen pen-pref-dim
  77     [
  78         {
  79             [ plain>> pen-pref-dim ]
  80             [ rollover>> pen-pref-dim ]
  81             [ pressed>> pen-pref-dim ]
  82             [ selected>> pen-pref-dim ]
  83         } 2cleave
  84     ] [ vmax ] reduce-outputs ;
  85
  86 M: button-pen pen-background
  87     button-pen pen-background ;
  88
  89 M: button-pen pen-foreground
  90     button-pen pen-foreground ;
  91
  92 <PRIVATE
  93
  94 : align-left ( button -- button )
  95     { 0 1/2 } >>align ; inline
  96
  97 : roll-button-theme ( button -- button )
  98     f COLOR: black <solid> dup f f <button-pen> >>boundary
  99     f f COLOR: dark-gray <solid> f f <button-pen> >>interior
 100     align-left ; inline
 101
 102 PRIVATE>
 103
 104 : <roll-button> ( label quot -- button )
 105     <button> roll-button-theme ;
 106
 107 <PRIVATE
 108
 109 : <border-button-state-pen> ( prefix background foreground -- pen )
 110     [
 111         "-left" "-middle" "-right"
 112         [ append theme-image ] tri-curry@ tri
 113     ] 2dip <tile-pen> ;
 114
 115 CONSTANT: button-background
 116     T{ rgba
 117          f
 118          0.8901960784313725
 119          0.8862745098039215
 120          0.8588235294117647
 121          1.0
 122     }
 123
 124 CONSTANT: button-clicked-background
 125     T{ rgba
 126          f
 127          0.2156862745098039
 128          0.2431372549019608
 129          0.2823529411764706
 130          1.0
 131     }
 132
 133 : <border-button-pen> ( -- pen )
 134     "button" button-background COLOR: black <border-button-state-pen> dup
 135     "button-clicked" button-clicked-background COLOR: white <border-button-state-pen> dup dup
 136     <button-pen> ;
 137
 138 : border-button-theme ( gadget -- gadget )
 139     horizontal >>orientation
 140     <border-button-pen> >>interior
 141     dup dup interior>> pen-pref-dim >>min-dim
 142     { 10 0 } >>size ; inline
 143
 144 PRIVATE>
 145
 146 : <border-button> ( label quot -- button )
 147     <button> border-button-theme ;
 148
 149 TUPLE: repeat-button < button ;
 150
 151 repeat-button H{
 152     { T{ button-down } [ button-clicked ] }
 153     { T{ drag } [ button-clicked ] }
 154     { T{ button-up } [ button-update ] }
 155 } set-gestures
 156
 157 : <repeat-button> ( label quot -- button )
 158     #! Button that calls the quotation every 100ms as long as
 159     #! the mouse is held down.
 160     repeat-button new-button border-button-theme ;
 161
 162 <PRIVATE
 163
 164 : <checkmark-pen> ( -- pen )
 165     "checkbox" theme-image <image-pen>
 166     "checkbox" theme-image <image-pen>
 167     "checkbox-clicked" theme-image <image-pen>
 168     "checkbox-set" theme-image <image-pen>
 169     "checkbox-set-clicked" theme-image <image-pen>
 170     <button-pen> ;
 171
 172 : <checkmark> ( -- gadget )
 173     <gadget>
 174     <checkmark-pen> >>interior
 175     dup dup interior>> pen-pref-dim >>dim ;
 176
 177 : toggle-model ( model -- )
 178     [ not ] change-model ;
 179
 180 PRIVATE>
 181
 182 TUPLE: checkbox < button ;
 183
 184 : <checkbox> ( model label -- checkbox )
 185     <checkmark> label-on-right
 186     [ model>> toggle-model ]
 187     checkbox new-button
 188         swap >>model
 189         align-left ;
 190
 191 M: checkbox model-changed
 192     swap value>> >>selected? relayout-1 ;
 193
 194 <PRIVATE
 195
 196 : <radio-pen> ( -- pen )
 197     "radio" theme-image <image-pen>
 198     "radio" theme-image <image-pen>
 199     "radio-clicked" theme-image <image-pen>
 200     "radio-set" theme-image <image-pen>
 201     "radio-set-clicked" theme-image <image-pen>
 202     <button-pen> ;
 203
 204 : <radio-knob> ( -- gadget )
 205     <gadget>
 206     <radio-pen> >>interior
 207     dup dup interior>> pen-pref-dim >>dim ;
 208
 209 TUPLE: radio-control < button value ;
 210
 211 : <radio-control> ( value model label -- control )
 212     [ [ value>> ] keep set-control-value ]
 213     radio-control new-button
 214         swap >>model
 215         swap >>value
 216         align-left ; inline
 217
 218 M: radio-control model-changed
 219     2dup [ value>> ] bi@ = >>selected? relayout-1 drop ;
 220
 221 :: <radio-controls> ( parent model assoc quot: ( value model label -- gadget ) -- parent )
 222     assoc model [ parent swap quot call add-gadget ] assoc-each ; inline
 223
 224 PRIVATE>
 225
 226 : <radio-button> ( value model label -- gadget )
 227     <radio-knob> label-on-right <radio-control> ;
 228
 229 : <radio-buttons> ( model assoc -- gadget )
 230     <filled-pile>
 231         [ <radio-button> ] <radio-controls>
 232         { 5 5 } >>gap ;
 233
 234 : command-button-quot ( target command -- quot )
 235     '[ _ _ invoke-command ] ;
 236
 237 : <command-button> ( target gesture command -- button )
 238     [ command-string swap ] keep command-button-quot
 239     '[ drop @ ] <border-button> ;
 240
 241 : <toolbar> ( target -- toolbar )
 242     <shelf>
 243         1 >>fill
 244         { 5 5 } >>gap
 245         swap
 246         [ [ "toolbar" ] dip class command-map commands>> ]
 247         [ '[ [ _ ] 2dip <command-button> add-gadget ] ]
 248         bi assoc-each ;
 249
 250 : add-toolbar ( track -- track )
 251     dup <toolbar> { 3 3 } <border> align-left f track-add ;