1 ! Copyright (C) 2005, 2008 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
5 classes.tuple opengl math.vectors
6 ui.commands ui.gadgets ui.gadgets.borders
7 ui.gadgets.labels ui.gadgets.theme
8 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
9 ui.render math.geometry.rect ;
11 IN: ui.gadgets.buttons
13 TUPLE: button < border pressed? selected? quot ;
15 : buttons-down? ( -- ? )
16 hand-buttons get-global empty? not ;
18 : button-rollover? ( button -- ? )
19 hand-gadget get-global child? ;
21 : mouse-clicked? ( gadget -- ? )
22 hand-clicked get-global child? ;
24 : button-update ( button -- )
26 over button-rollover? and
31 : if-clicked ( button quot -- )
32 >r dup button-update dup button-rollover? r> [ drop ] if ;
34 : button-clicked ( button -- ) dup quot>> if-clicked ;
37 { T{ button-up } [ button-clicked ] }
38 { T{ button-down } [ button-update ] }
39 { T{ mouse-leave } [ button-update ] }
40 { T{ mouse-enter } [ button-update ] }
43 : new-button ( label quot class -- button )
44 [ swap >label ] dip new-border swap >>quot ; inline
46 : <button> ( label quot -- button )
49 TUPLE: button-paint plain rollover pressed selected ;
51 C: <button-paint> button-paint
53 : find-button ( gadget -- button )
54 [ button? ] find-parent ;
56 : button-paint ( button paint -- button paint )
58 { [ dup pressed?>> ] [ drop pressed>> ] }
59 { [ dup selected?>> ] [ drop selected>> ] }
60 { [ dup button-rollover? ] [ drop rollover>> ] }
64 M: button-paint draw-interior
65 button-paint draw-interior ;
67 M: button-paint draw-boundary
68 button-paint draw-boundary ;
70 : align-left ( button -- button )
71 { 0 1/2 } >>align ; inline
73 : roll-button-theme ( button -- button )
74 f black <solid> dup f <button-paint> >>boundary
77 : <roll-button> ( label quot -- button )
78 <button> roll-button-theme ;
80 : <bevel-button-paint> ( -- paint )
87 : bevel-button-theme ( gadget -- gadget )
88 <bevel-button-paint> >>interior
90 faint-boundary ; inline
92 : <bevel-button> ( label quot -- button )
93 <button> bevel-button-theme ;
95 TUPLE: repeat-button < button ;
98 { T{ drag } [ button-clicked ] }
101 : <repeat-button> ( label quot -- button )
102 #! Button that calls the quotation every 100ms as long as
103 #! the mouse is held down.
104 repeat-button new-button bevel-button-theme ;
106 TUPLE: checkmark-paint color ;
108 C: <checkmark-paint> checkmark-paint
110 M: checkmark-paint draw-interior
115 dup { 0 1 } v* swap { 1 0 } v* gl-line
118 : checkmark-theme ( gadget -- gadget )
122 black <checkmark-paint>
123 <button-paint> >>interior
124 black <solid> >>boundary ;
126 : <checkmark> ( -- gadget )
131 : toggle-model ( model -- )
132 [ not ] change-model ;
134 : checkbox-theme ( gadget -- gadget )
139 TUPLE: checkbox < button ;
141 : <checkbox> ( model label -- checkbox )
142 <checkmark> label-on-right checkbox-theme
143 [ model>> toggle-model ]
148 M: checkbox model-changed
149 swap value>> >>selected? relayout-1 ;
151 TUPLE: radio-paint color ;
153 C: <radio-paint> radio-paint
155 M: radio-paint draw-interior
157 origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
159 M: radio-paint draw-boundary
161 origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
163 : radio-knob-theme ( gadget -- gadget )
168 <button-paint> >>interior
169 black <radio-paint> >>boundary ;
171 : <radio-knob> ( -- gadget )
176 TUPLE: radio-control < button value ;
178 : <radio-control> ( value model label -- control )
179 [ [ value>> ] keep set-control-value ]
180 radio-control new-button
185 M: radio-control model-changed
187 over value>> = >>selected?
190 : <radio-controls> ( parent model assoc quot -- parent )
191 #! quot has stack effect ( value model label -- )
192 swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
194 : radio-button-theme ( gadget -- gadget )
198 : <radio-button> ( value model label -- gadget )
199 <radio-knob> label-on-right radio-button-theme <radio-control> ;
201 : <radio-buttons> ( model assoc -- gadget )
204 [ <radio-button> ] <radio-controls>
207 : <toggle-button> ( value model label -- gadget )
208 <radio-control> bevel-button-theme ;
210 : <toggle-buttons> ( model assoc -- gadget )
213 [ <toggle-button> ] <radio-controls> ;
215 : command-button-quot ( target command -- quot )
216 [ invoke-command drop ] 2curry ;
218 : <command-button> ( target gesture command -- button )
219 [ command-string ] keep
224 : <toolbar> ( target -- toolbar )
227 "toolbar" over class command-map commands>> swap
228 [ -rot <command-button> add-gadget ] curry assoc-each ;