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
10 FROM: models => change-model ;
11 IN: ui.gadgets.buttons
13 TUPLE: button < border pressed? selected? quot tooltip ;
17 : find-button ( gadget -- button )
18 [ button? ] find-parent ;
20 : buttons-down? ( -- ? )
21 hand-buttons get-global empty? not ;
23 : button-rollover? ( button -- ? )
24 hand-gadget get-global child? ;
26 : mouse-clicked? ( gadget -- ? )
27 hand-clicked get-global child? ;
31 : button-update ( button -- )
33 [ mouse-clicked? ] [ button-rollover? ] bi and
38 : button-enter ( button -- )
39 dup dup tooltip>> [ swap show-status ] [ drop ] if* button-update ;
41 : button-leave ( button -- )
42 dup "" swap show-status button-update ;
44 : button-clicked ( button -- )
47 [ dup quot>> call( button -- ) ] [ drop ] if ;
50 { T{ button-up } [ button-clicked ] }
51 { T{ button-down } [ button-update ] }
52 { mouse-leave [ button-leave ] }
53 { mouse-enter [ button-enter ] }
56 : new-button ( label quot class -- button )
57 [ swap >label ] dip new-border swap >>quot ; inline
59 : <button> ( label quot -- button )
64 pressed selected pressed-selected ;
66 C: <button-pen> button-pen
68 : button-pen ( button pen -- button pen )
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>> ] }
77 M: button-pen draw-interior
78 button-pen dup [ draw-interior ] [ 2drop ] if ;
80 M: button-pen draw-boundary
81 button-pen dup [ draw-boundary ] [ 2drop ] if ;
83 M: button-pen pen-pref-dim
86 [ plain>> pen-pref-dim ]
87 [ rollover>> pen-pref-dim ]
88 [ pressed>> pen-pref-dim ]
89 [ selected>> pen-pref-dim ]
91 ] [ vmax ] reduce-outputs ;
93 M: button-pen pen-background
94 button-pen pen-background ;
96 M: button-pen pen-foreground
97 button-pen pen-foreground ;
101 : align-left ( button -- button )
102 { 0 1/2 } >>align ; inline
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
111 : <roll-button> ( label quot -- button )
112 <button> roll-button-theme ;
116 : <border-button-state-pen> ( prefix background foreground -- pen )
118 "-left" "-middle" "-right"
119 [ append theme-image ] tri-curry@ tri
122 CONSTANT: button-background COLOR: FactorTan
123 CONSTANT: button-clicked-background COLOR: FactorDarkSlateBlue
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
132 : border-button-label-theme ( gadget -- )
133 dup label? [ [ clone t >>bold? ] change-font ] when drop ;
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
144 : <border-button> ( label quot -- button )
145 <button> border-button-theme ;
147 TUPLE: repeat-button < button ;
150 { T{ button-down } [ button-clicked ] }
151 { T{ drag } [ button-clicked ] }
152 { T{ button-up } [ button-update ] }
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 ;
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>
170 : <checkmark> ( -- gadget )
172 <checkmark-pen> >>interior
173 dup dup interior>> pen-pref-dim >>dim ;
175 : toggle-model ( model -- )
176 [ not ] change-model ;
180 TUPLE: checkbox < button ;
182 : <checkbox> ( model label -- checkbox )
183 <checkmark> label-on-right
184 [ model>> toggle-model ]
189 M: checkbox model-changed
190 swap value>> >>selected? relayout-1 ;
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>
202 : <radio-knob> ( -- gadget )
204 <radio-pen> >>interior
205 dup dup interior>> pen-pref-dim >>dim ;
207 TUPLE: radio-control < button value ;
209 : <radio-control> ( value model label -- control )
210 [ [ value>> ] keep set-control-value ]
211 radio-control new-button
216 M: radio-control model-changed
217 2dup [ value>> ] bi@ = >>selected? relayout-1 drop ;
219 :: <radio-controls> ( parent model assoc quot: ( value model label -- gadget ) -- parent )
220 assoc model [ parent swap quot call add-gadget ] assoc-each ; inline
224 : <radio-button> ( value model label -- gadget )
225 <radio-knob> label-on-right <radio-control> ;
227 : <radio-buttons> ( model assoc -- gadget )
229 [ <radio-button> ] <radio-controls>
232 : command-button-quot ( target command -- quot )
233 '[ _ _ invoke-command ] ;
235 : gesture>tooltip ( gesture -- str/f )
236 dup [ gesture>string "Shortcut: " prepend ] when ;
238 : <command-button> ( target gesture command -- button )
239 swapd [ command-name swap ] keep command-button-quot
240 '[ drop @ ] <border-button> swap gesture>tooltip >>tooltip ;
242 : <toolbar> ( target -- toolbar )
247 [ [ "toolbar" ] dip class command-map commands>> ]
248 [ '[ [ _ ] 2dip <command-button> add-gadget ] ]
251 : add-toolbar ( track -- track )
252 dup <toolbar> { 3 3 } <border> align-left f track-add ;