1 | # ------------------------------------------------------------------------------ |
---|
2 | # spinbox.tcl |
---|
3 | # This file is part of Unifix BWidget Toolkit |
---|
4 | # ------------------------------------------------------------------------------ |
---|
5 | # Index of commands: |
---|
6 | # - SpinBox::create |
---|
7 | # - SpinBox::configure |
---|
8 | # - SpinBox::cget |
---|
9 | # - SpinBox::setvalue |
---|
10 | # - SpinBox::_destroy |
---|
11 | # - SpinBox::_modify_value |
---|
12 | # - SpinBox::_test_options |
---|
13 | # ------------------------------------------------------------------------------ |
---|
14 | |
---|
15 | namespace eval SpinBox { |
---|
16 | ArrowButton::use |
---|
17 | Entry::use |
---|
18 | LabelFrame::use |
---|
19 | |
---|
20 | Widget::bwinclude SpinBox LabelFrame .labf \ |
---|
21 | rename {-text -label} \ |
---|
22 | prefix {label -justify -width -anchor -height -font} \ |
---|
23 | remove {-focus} \ |
---|
24 | initialize {-relief sunken -borderwidth 2} |
---|
25 | |
---|
26 | Widget::bwinclude SpinBox Entry .e \ |
---|
27 | remove {-relief -bd -borderwidth -fg -bg} \ |
---|
28 | rename {-foreground -entryfg -background -entrybg} |
---|
29 | |
---|
30 | Widget::declare SpinBox { |
---|
31 | {-range String "" 0} |
---|
32 | {-values String "" 0} |
---|
33 | {-modifycmd String "" 0} |
---|
34 | {-repeatdelay Int 400 0 {=0}} |
---|
35 | {-repeatinterval Int 100 0 {=0}} |
---|
36 | } |
---|
37 | |
---|
38 | Widget::addmap SpinBox "" :cmd {-background {}} |
---|
39 | Widget::addmap SpinBox ArrowButton .arrup { |
---|
40 | -foreground {} -background {} -disabledforeground {} -state {} |
---|
41 | -repeatdelay {} -repeatinterval {} |
---|
42 | } |
---|
43 | Widget::addmap SpinBox ArrowButton .arrdn { |
---|
44 | -foreground {} -background {} -disabledforeground {} -state {} |
---|
45 | -repeatdelay {} -repeatinterval {} |
---|
46 | } |
---|
47 | |
---|
48 | Widget::syncoptions SpinBox Entry .e {-text {}} |
---|
49 | Widget::syncoptions SpinBox LabelFrame .labf {-label -text -underline {}} |
---|
50 | |
---|
51 | ::bind BwSpinBox <FocusIn> {focus %W.labf} |
---|
52 | ::bind BwSpinBox <Destroy> {SpinBox::_destroy %W} |
---|
53 | |
---|
54 | proc ::SpinBox { path args } { return [eval SpinBox::create $path $args] } |
---|
55 | proc use {} {} |
---|
56 | |
---|
57 | variable _widget |
---|
58 | } |
---|
59 | |
---|
60 | |
---|
61 | # ------------------------------------------------------------------------------ |
---|
62 | # Command SpinBox::create |
---|
63 | # ------------------------------------------------------------------------------ |
---|
64 | proc SpinBox::create { path args } { |
---|
65 | variable _widget |
---|
66 | |
---|
67 | Widget::init SpinBox $path $args |
---|
68 | |
---|
69 | _test_options $path |
---|
70 | eval frame $path [Widget::subcget $path :cmd] \ |
---|
71 | -highlightthickness 0 -bd 0 -relief flat -takefocus 0 |
---|
72 | set labf [eval LabelFrame::create $path.labf [Widget::subcget $path .labf] \ |
---|
73 | -borderwidth 2 -relief sunken -focus $path.e] |
---|
74 | set entry [eval Entry::create $path.e [Widget::subcget $path .e] \ |
---|
75 | -relief flat -borderwidth 0] |
---|
76 | |
---|
77 | bindtags $path [list $path BwSpinBox [winfo toplevel $path] all] |
---|
78 | |
---|
79 | set farr [frame $path.farr -relief flat -bd 0 -highlightthickness 0] |
---|
80 | set height [expr {[winfo reqheight $path.e]/2-2}] |
---|
81 | set width 11 |
---|
82 | set arrup [eval ArrowButton::create $path.arrup -dir top \ |
---|
83 | [Widget::subcget $path .arrup] \ |
---|
84 | -highlightthickness 0 -borderwidth 1 -takefocus 0 \ |
---|
85 | -type button \ |
---|
86 | -width $width -height $height \ |
---|
87 | -armcommand [list "SpinBox::_modify_value $path next arm"] \ |
---|
88 | -disarmcommand [list "SpinBox::_modify_value $path next disarm"]] |
---|
89 | set arrdn [eval ArrowButton::create $path.arrdn -dir bottom \ |
---|
90 | [Widget::subcget $path .arrdn] \ |
---|
91 | -highlightthickness 0 -borderwidth 1 -takefocus 0 \ |
---|
92 | -type button \ |
---|
93 | -width $width -height $height \ |
---|
94 | -armcommand [list "SpinBox::_modify_value $path previous arm"] \ |
---|
95 | -disarmcommand [list "SpinBox::_modify_value $path previous disarm"]] |
---|
96 | set frame [LabelFrame::getframe $path.labf] |
---|
97 | |
---|
98 | # --- update -value --- |
---|
99 | if { [set val [Entry::cget $path.e -text]] != "" } { |
---|
100 | set _widget($path,curval) $val |
---|
101 | } else { |
---|
102 | if { [set var [Widget::getoption $path -textvariable]] != "" } { |
---|
103 | GlobalVar::setvar $var $_widget($path,curval) |
---|
104 | } else { |
---|
105 | Entry::configure $path.e -text $_widget($path,curval) |
---|
106 | } |
---|
107 | } |
---|
108 | Widget::setoption $path -text $_widget($path,curval) |
---|
109 | |
---|
110 | grid $arrup -in $farr -column 0 -row 0 -sticky nsew |
---|
111 | grid $arrdn -in $farr -column 0 -row 2 -sticky nsew |
---|
112 | grid rowconfigure $farr 0 -weight 1 |
---|
113 | grid rowconfigure $farr 2 -weight 1 |
---|
114 | |
---|
115 | pack $farr -in $frame -side right -fill y |
---|
116 | pack $entry -in $frame -side left -fill both -expand yes |
---|
117 | pack $labf -fill both -expand yes |
---|
118 | |
---|
119 | ::bind $entry <Key-Up> "SpinBox::_modify_value $path next activate" |
---|
120 | ::bind $entry <Key-Down> "SpinBox::_modify_value $path previous activate" |
---|
121 | ::bind $entry <Key-Prior> "SpinBox::_modify_value $path last activate" |
---|
122 | ::bind $entry <Key-Next> "SpinBox::_modify_value $path first activate" |
---|
123 | |
---|
124 | ::bind $farr <Configure> {grid rowconfigure %W 1 -minsize [expr {%h%%2}]} |
---|
125 | |
---|
126 | rename $path ::$path:cmd |
---|
127 | proc ::$path { cmd args } "return \[eval SpinBox::\$cmd $path \$args\]" |
---|
128 | |
---|
129 | return $path |
---|
130 | } |
---|
131 | |
---|
132 | |
---|
133 | # ------------------------------------------------------------------------------ |
---|
134 | # Command SpinBox::configure |
---|
135 | # ------------------------------------------------------------------------------ |
---|
136 | proc SpinBox::configure { path args } { |
---|
137 | set res [Widget::configure $path $args] |
---|
138 | if { [Widget::hasChanged $path -values val] || |
---|
139 | [Widget::hasChanged $path -range val] } { |
---|
140 | _test_options $path |
---|
141 | } |
---|
142 | return $res |
---|
143 | } |
---|
144 | |
---|
145 | |
---|
146 | # ------------------------------------------------------------------------------ |
---|
147 | # Command SpinBox::cget |
---|
148 | # ------------------------------------------------------------------------------ |
---|
149 | proc SpinBox::cget { path option } { |
---|
150 | return [Widget::cget $path $option] |
---|
151 | } |
---|
152 | |
---|
153 | |
---|
154 | # ------------------------------------------------------------------------------ |
---|
155 | # Command SpinBox::setvalue |
---|
156 | # ------------------------------------------------------------------------------ |
---|
157 | proc SpinBox::setvalue { path index } { |
---|
158 | variable _widget |
---|
159 | |
---|
160 | set values [Widget::getoption $path -values] |
---|
161 | set value [Entry::cget $path.e -text] |
---|
162 | |
---|
163 | if { [llength $values] } { |
---|
164 | # --- -values SpinBox --- |
---|
165 | switch -- $index { |
---|
166 | next { |
---|
167 | if { [set idx [lsearch $values $value]] != -1 } { |
---|
168 | incr idx |
---|
169 | } elseif { [set idx [lsearch $values "$value*"]] == -1 } { |
---|
170 | set idx [lsearch $values $_widget($path,curval)] |
---|
171 | } |
---|
172 | } |
---|
173 | previous { |
---|
174 | if { [set idx [lsearch $values $value]] != -1 } { |
---|
175 | incr idx -1 |
---|
176 | } elseif { [set idx [lsearch $values "$value*"]] == -1 } { |
---|
177 | set idx [lsearch $values $_widget($path,curval)] |
---|
178 | } |
---|
179 | } |
---|
180 | first { |
---|
181 | set idx 0 |
---|
182 | } |
---|
183 | last { |
---|
184 | set idx [expr {[llength $values]-1}] |
---|
185 | } |
---|
186 | default { |
---|
187 | if { [string index $index 0] == "@" } { |
---|
188 | set idx [string range $index 1 end] |
---|
189 | if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } { |
---|
190 | return -code error "bad index \"$index\"" |
---|
191 | } |
---|
192 | } else { |
---|
193 | return -code error "bad index \"$index\"" |
---|
194 | } |
---|
195 | } |
---|
196 | } |
---|
197 | if { $idx >= 0 && $idx < [llength $values] } { |
---|
198 | set newval [lindex $values $idx] |
---|
199 | } else { |
---|
200 | return 0 |
---|
201 | } |
---|
202 | } else { |
---|
203 | # --- -range SpinBox --- |
---|
204 | set range [Widget::getoption $path -range] |
---|
205 | set vmin [lindex $range 0] |
---|
206 | set vmax [lindex $range 1] |
---|
207 | set incr [lindex $range 2] |
---|
208 | switch -- $index { |
---|
209 | next { |
---|
210 | if { [catch {expr {double($value-$vmin)/$incr}} idx] } { |
---|
211 | set newval $_widget($path,curval) |
---|
212 | } else { |
---|
213 | set newval [expr {$vmin+(round($idx)+1)*$incr}] |
---|
214 | if { $newval < $vmin } { |
---|
215 | set newval $vmin |
---|
216 | } elseif { $newval > $vmax } { |
---|
217 | set newval $vmax |
---|
218 | } |
---|
219 | } |
---|
220 | } |
---|
221 | previous { |
---|
222 | if { [catch {expr {double($value-$vmin)/$incr}} idx] } { |
---|
223 | set newval $_widget($path,curval) |
---|
224 | } else { |
---|
225 | set newval [expr {$vmin+(round($idx)-1)*$incr}] |
---|
226 | if { $newval < $vmin } { |
---|
227 | set newval $vmin |
---|
228 | } elseif { $newval > $vmax } { |
---|
229 | set newval $vmax |
---|
230 | } |
---|
231 | } |
---|
232 | } |
---|
233 | first { |
---|
234 | set newval $vmin |
---|
235 | } |
---|
236 | last { |
---|
237 | set newval $vmax |
---|
238 | } |
---|
239 | default { |
---|
240 | if { [string index $index 0] == "@" } { |
---|
241 | set idx [string range $index 1 end] |
---|
242 | if { [catch {string compare [expr {int($idx)}] $idx} res] || $res != 0 } { |
---|
243 | return -code error "bad index \"$index\"" |
---|
244 | } |
---|
245 | set newval [expr {$vmin+int($idx)*$incr}] |
---|
246 | if { $newval < $vmin || $newval > $vmax } { |
---|
247 | return 0 |
---|
248 | } |
---|
249 | } else { |
---|
250 | return -code error "bad index \"$index\"" |
---|
251 | } |
---|
252 | } |
---|
253 | } |
---|
254 | } |
---|
255 | set _widget($path,curval) $newval |
---|
256 | Widget::setoption $path -text $newval |
---|
257 | if { [set varname [Entry::cget $path.e -textvariable]] != "" } { |
---|
258 | GlobalVar::setvar $varname $newval |
---|
259 | } else { |
---|
260 | Entry::configure $path.e -text $newval |
---|
261 | } |
---|
262 | return 1 |
---|
263 | } |
---|
264 | |
---|
265 | |
---|
266 | # ------------------------------------------------------------------------------ |
---|
267 | # Command SpinBox::getvalue |
---|
268 | # ------------------------------------------------------------------------------ |
---|
269 | proc SpinBox::getvalue { path } { |
---|
270 | variable _widget |
---|
271 | |
---|
272 | set values [Widget::getoption $path -values] |
---|
273 | set value [Entry::cget $path.e -text] |
---|
274 | |
---|
275 | if { [llength $values] } { |
---|
276 | # --- -values SpinBox --- |
---|
277 | return [lsearch $values $value] |
---|
278 | } else { |
---|
279 | set range [Widget::getoption $path -range] |
---|
280 | set vmin [lindex $range 0] |
---|
281 | set vmax [lindex $range 1] |
---|
282 | set incr [lindex $range 2] |
---|
283 | if { ![catch {expr {double($value-$vmin)/$incr}} idx] && |
---|
284 | $idx == int($idx) } { |
---|
285 | return [expr {int($idx)}] |
---|
286 | } |
---|
287 | return -1 |
---|
288 | } |
---|
289 | } |
---|
290 | |
---|
291 | |
---|
292 | # ------------------------------------------------------------------------------ |
---|
293 | # Command SpinBox::bind |
---|
294 | # ------------------------------------------------------------------------------ |
---|
295 | proc SpinBox::bind { path args } { |
---|
296 | return [eval ::bind $path.e $args] |
---|
297 | } |
---|
298 | |
---|
299 | |
---|
300 | # ------------------------------------------------------------------------------ |
---|
301 | # Command SpinBox::_destroy |
---|
302 | # ------------------------------------------------------------------------------ |
---|
303 | proc SpinBox::_destroy { path } { |
---|
304 | variable _widget |
---|
305 | |
---|
306 | unset _widget($path,curval) |
---|
307 | Widget::destroy $path |
---|
308 | rename $path {} |
---|
309 | } |
---|
310 | |
---|
311 | |
---|
312 | # ------------------------------------------------------------------------------ |
---|
313 | # Command SpinBox::_modify_value |
---|
314 | # ------------------------------------------------------------------------------ |
---|
315 | proc SpinBox::_modify_value { path direction reason } { |
---|
316 | if { $reason == "arm" || $reason == "activate" } { |
---|
317 | SpinBox::setvalue $path $direction |
---|
318 | } |
---|
319 | if { ($reason == "disarm" || $reason == "activate") && |
---|
320 | [set cmd [Widget::getoption $path -modifycmd]] != "" } { |
---|
321 | uplevel \#0 $cmd |
---|
322 | } |
---|
323 | } |
---|
324 | |
---|
325 | |
---|
326 | # ------------------------------------------------------------------------------ |
---|
327 | # Command SpinBox::_test_options |
---|
328 | # ------------------------------------------------------------------------------ |
---|
329 | proc SpinBox::_test_options { path } { |
---|
330 | variable _widget |
---|
331 | |
---|
332 | set values [Widget::getoption $path -values] |
---|
333 | if { [llength $values] } { |
---|
334 | set _widget($path,curval) [lindex $values 0] |
---|
335 | } else { |
---|
336 | set range [Widget::getoption $path -range] |
---|
337 | set vmin [lindex $range 0] |
---|
338 | set vmax [lindex $range 1] |
---|
339 | set incr [lindex $range 2] |
---|
340 | if { [catch {expr {int($vmin)}}] } { |
---|
341 | set vmin 0 |
---|
342 | } |
---|
343 | if { [catch {expr {$vmax<$vmin}} res] || $res } { |
---|
344 | set vmax $vmin |
---|
345 | } |
---|
346 | if { [catch {expr {$incr<0}} res] || $res } { |
---|
347 | set incr 1 |
---|
348 | } |
---|
349 | Widget::setoption $path -range [list $vmin $vmax $incr] |
---|
350 | set _widget($path,curval) $vmin |
---|
351 | } |
---|
352 | } |
---|
353 | |
---|