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