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