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