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