Context Navigation

source: trunk/gui/scripts/gauge.tcl @ 962

Last change on this file since 962 was 962, checked in by dkearney, 17 years ago
code cleanups. adjusted gague.tcl to check the length of the string it receives for integers and reals. modified c, matlab, and octave's lib function to handle empty string for creation of empty library. modified matlab and octave's lib result function to handle status as a parameter. fixed core library code to deal with incorrect order of translating xml entity references.
File size: 24.7 KB

Line
1	# ----------------------------------------------------------------------
2	# COMPONENT: gauge - compact readout for real values
3	#
4	# This widget is a readout for a real value. It has a little glyph
5	# filled with color according to the value, followed by a numeric
6	# representation of the value itself. The value can be edited, and
7	# a list of predefined values can be associated with a menu that
8	# drops down from the value.
9	# ======================================================================
10	# AUTHOR: Michael McLennan, Purdue University
11	# Copyright (c) 2004-2005 Purdue Research Foundation
12	#
13	# See the file "license.terms" for information on usage and
14	# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15	# ======================================================================
16	package require Itk
17	package require BLT
18
19	option add *Gauge.sampleWidth 30 widgetDefault
20	option add *Gauge.sampleHeight 20 widgetDefault
21	option add *Gauge.valuePosition "right" widgetDefault
22	option add *Gauge.textBackground #cccccc widgetDefault
23	option add *Gauge.editable yes widgetDefault
24
25	itcl::class Rappture::Gauge {
26	inherit itk::Widget
27
28	itk_option define -editable editable Editable ""
29	itk_option define -state state State "normal"
30	itk_option define -spectrum spectrum Spectrum ""
31	itk_option define -type type Type "real"
32	itk_option define -units units Units ""
33	itk_option define -minvalue minValue MinValue ""
34	itk_option define -maxvalue maxValue MaxValue ""
35	itk_option define -presets presets Presets ""
36	itk_option define -valueposition valuePosition ValuePosition ""
37	itk_option define -image image Image ""
38	itk_option define -samplewidth sampleWidth SampleWidth 0
39	itk_option define -sampleheight sampleHeight SampleHeight 0
40
41	constructor {args} { # defined below }
42
43	public method value {args}
44	public method edit {option}
45	public method bump {delta}
46
47	protected method _redraw {}
48	protected method _resize {}
49	protected method _hilite {comp state}
50	protected method _editor {option args}
51	protected method _presets {option}
52	protected method _layout {}
53
54	private variable _value 0 ;# value for this widget
55
56	blt::bitmap define GaugeArrow-up {
57	#define up_width 8
58	#define up_height 4
59	static unsigned char up_bits[] = {
60	0x10, 0x38, 0x7c, 0xfe};
61	}
62	blt::bitmap define GaugeArrow-down {
63	#define arrow_width 8
64	#define arrow_height 4
65	static unsigned char arrow_bits[] = {
66	0xfe, 0x7c, 0x38, 0x10};
67	}
68
69	blt::bitmap define GaugeArrow {
70	#define arrow_width 9
71	#define arrow_height 4
72	static unsigned char arrow_bits[] = {
73	0x7f, 0x00, 0x3e, 0x00, 0x1c, 0x00, 0x08, 0x00};
74	}
75	}
76
77	itk::usual Gauge {
78	keep -cursor -font -foreground -background
79	keep -selectbackground -selectforeground -selectborderwidth
80	}
81
82	# ----------------------------------------------------------------------
83	# CONSTRUCTOR
84	# ----------------------------------------------------------------------
85	itcl::body Rappture::Gauge::constructor {args} {
86	itk_component add icon {
87	canvas $itk_interior.icon -width 1 -height 1 \
88	-borderwidth 0 -highlightthickness 0
89	} {
90	usual
91	ignore -highlightthickness -highlightbackground -highlightcolor
92	}
93	pack $itk_component(icon) -side left
94	bind $itk_component(icon) <Configure> [itcl::code $this _redraw]
95
96	itk_component add -protected vframe {
97	frame $itk_interior.vframe
98	}
99
100	itk_component add value {
101	label $itk_component(vframe).value -borderwidth 1 -width 7 \
102	-textvariable [itcl::scope _value]
103	} {
104	rename -background -textbackground textBackground Background
105	}
106	pack $itk_component(value) -side left -expand yes -fill both
107
108	bind $itk_component(value) <Enter> [itcl::code $this _hilite value on]
109	bind $itk_component(value) <Leave> [itcl::code $this _hilite value off]
110
111	bind $itk_component(value) <<Cut>> [itcl::code $this edit cut]
112	bind $itk_component(value) <<Copy>> [itcl::code $this edit copy]
113	bind $itk_component(value) <<Paste>> [itcl::code $this edit paste]
114
115	itk_component add emenu {
116	menu $itk_component(value).menu -tearoff 0
117	} {
118	usual
119	ignore -tearoff
120	}
121	$itk_component(emenu) add command -label "Cut" -accelerator "^X" \
122	-command [list event generate $itk_component(value) <<Cut>>]
123	$itk_component(emenu) add command -label "Copy" -accelerator "^C" \
124	-command [list event generate $itk_component(value) <<Copy>>]
125	$itk_component(emenu) add command -label "Paste" -accelerator "^V" \
126	-command [list event generate $itk_component(value) <<Paste>>]
127	bind $itk_component(value) <<PopupMenu>> \
128	[itcl::code $this _editor menu %X %Y]
129
130	itk_component add editor {
131	Rappture::Editor $itk_interior.editor \
132	-activatecommand [itcl::code $this _editor activate] \
133	-validatecommand [itcl::code $this _editor validate] \
134	-applycommand [itcl::code $this _editor apply]
135	}
136	bind $itk_component(value) <ButtonPress> \
137	[itcl::code $this _editor popup]
138
139
140	itk_component add spinner {
141	frame $itk_component(vframe).spinner
142	}
143
144	itk_component add spinup {
145	button $itk_component(spinner).up -bitmap GaugeArrow-up \
146	-borderwidth 1 -relief raised -highlightthickness 0 \
147	-command [itcl::code $this bump 1]
148	} {
149	usual
150	ignore -borderwidth -highlightthickness
151	}
152	pack $itk_component(spinup) -side top -expand yes -fill both
153
154	itk_component add spindn {
155	button $itk_component(spinner).down -bitmap GaugeArrow-down \
156	-borderwidth 1 -relief raised -highlightthickness 0 \
157	-command [itcl::code $this bump -1]
158	} {
159	usual
160	ignore -borderwidth -highlightthickness
161	}
162	pack $itk_component(spindn) -side bottom -expand yes -fill both
163
164
165	itk_component add presets {
166	button $itk_component(vframe).psbtn -bitmap GaugeArrow \
167	-borderwidth 1 -highlightthickness 0 -relief flat
168	} {
169	usual
170	ignore -borderwidth -relief -highlightthickness
171	rename -background -textbackground textBackground Background
172	}
173
174	bind $itk_component(presets) <Enter> [itcl::code $this _hilite presets on]
175	bind $itk_component(presets) <Leave> [itcl::code $this _hilite presets off]
176
177	itk_component add presetlist {
178	Rappture::Dropdownlist $itk_component(presets).plist \
179	-postcommand [itcl::code $this _presets post] \
180	-unpostcommand [itcl::code $this _presets unpost] \
181	}
182
183	bind $itk_component(presetlist) <<DropdownlistSelect>> \
184	[itcl::code $this _presets select]
185
186	$itk_component(presets) configure -command \
187	[list $itk_component(presetlist) post $itk_component(vframe) left]
188
189	eval itk_initialize $args
190	}
191
192	# ----------------------------------------------------------------------
193	# USAGE: value ?-check? ?<newval>?
194	#
195	# Clients use this to query/set the value for this widget. With
196	# no args, it returns the current value for the widget. If the
197	# <newval> is specified, it sets the value of the widget and
198	# sends a <<Value>> event. If the -check flag is included, the
199	# new value is not actually applied, but just checked for correctness.
200	# ----------------------------------------------------------------------
201	itcl::body Rappture::Gauge::value {args} {
202	set onlycheck 0
203	set i [lsearch -exact $args -check]
204	if {$i >= 0} {
205	set onlycheck 1
206	set args [lreplace $args $i $i]
207	}
208
209	if {[llength $args] == 1} {
210	#
211	# If this gauge has -units, try to convert the incoming
212	# value to that system of units. Also, make sure that
213	# the value is bound by any min/max value constraints.
214	#
215	# Keep track of the inputted units so we can give a
216	# response about min and max values in familiar units.
217	#
218	set newval [set nv [lindex $args 0]]
219	set units $itk_option(-units)
220	if {"" != $units} {
221	set newval [Rappture::Units::convert $newval -context $units]
222	set nvUnits [Rappture::Units::Search::for $newval]
223	if { "" == $nvUnits} {
224	set msg [Rappture::Units::description $units]
225	error "Unrecognized units: $newval\nEnter value with units of $msg"
226	}
227	set nv [Rappture::Units::convert $nv \
228	-context $units -to $units -units off]
229
230	# Normalize the units name
231	set newval [Rappture::Units::convert $newval -units off]$nvUnits
232	}
233
234	switch -- $itk_option(-type) {
235	integer {
236	if {[string length $nv] <= 0
237	\|\| ![string is integer $nv] } {
238	error "Should be an integer value"
239	}
240	}
241	real {
242	if {[string length $nv] <= 0
243	\|\| ![string is double $nv]
244	\|\| [regexp -nocase {^(inf\|nan)$} $nv]} {
245	error "Should be a real number"
246	}
247	}
248	}
249
250	if {"" != $itk_option(-minvalue)} {
251	set convMinVal [set minv $itk_option(-minvalue)]
252	if {"" != $units} {
253	set minv [Rappture::Units::convert $minv \
254	-context $units -to $units -units off]
255	set convMinVal [Rappture::Units::convert \
256	$itk_option(-minvalue) -context $units -to $nvUnits]
257	} else {
258	set newval [format "%g" $newval]
259	}
260
261	# fix for the case when the user tries to
262	# compare values like minv=-500 nv=-0600
263	set nv [format "%g" $nv]
264	set minv [format "%g" $minv]
265
266	if {$nv < $minv} {
267	error "minimum value allowed here is $convMinVal"
268	}
269	}
270
271	if {"" != $itk_option(-maxvalue)} {
272	set convMaxVal [set maxv $itk_option(-maxvalue)]
273	if {"" != $units} {
274	set maxv [Rappture::Units::convert $maxv \
275	-context $units -to $units -units off]
276	set convMaxVal [Rappture::Units::convert \
277	$itk_option(-maxvalue) -context $units -to $nvUnits]
278	} else {
279	set newval [format "%g" $newval]
280	}
281
282	# fix for the case when the user tries to
283	# compare values like maxv=500 nv=0600
284	set nv [format "%g" $nv]
285	set maxv [format "%g" $maxv]
286
287	if {$nv > $maxv} {
288	error "maximum value allowed here is $convMaxVal"
289	}
290	}
291
292	if {$onlycheck} {
293	return
294	}
295
296	set _value $newval
297
298	_redraw
299	event generate $itk_component(hull) <<Value>>
300
301	} elseif {[llength $args] != 0} {
302	error "wrong # args: should be \"value ?-check? ?newval?\""
303	}
304	return $_value
305	}
306
307	# ----------------------------------------------------------------------
308	# USAGE: edit cut
309	# USAGE: edit copy
310	# USAGE: edit paste
311	#
312	# Used internally to handle cut/copy/paste operations for the current
313	# value. Usually invoked by <<Cut>>, <<Copy>>, <<Paste>> events, but
314	# can also be called directly through this method.
315	# ----------------------------------------------------------------------
316	itcl::body Rappture::Gauge::edit {option} {
317	if {$itk_option(-state) == "disabled"} {
318	return ;# disabled? then bail out here!
319	}
320	switch -- $option {
321	cut {
322	edit copy
323	_editor popup
324	$itk_component(editor) value ""
325	$itk_component(editor) deactivate
326	}
327	copy {
328	clipboard clear
329	clipboard append $_value
330	}
331	paste {
332	_editor popup
333	$itk_component(editor) value [clipboard get]
334	$itk_component(editor) deactivate
335	}
336	default {
337	error "bad option \"$option\": should be cut, copy, paste"
338	}
339	}
340	}
341
342	# ----------------------------------------------------------------------
343	# USAGE: bump <delta>
344	#
345	# Changes the current value up/down by the <delta> value. Used
346	# internally by the up/down spinner buttons when the value is
347	# -type integer.
348	# ----------------------------------------------------------------------
349	itcl::body Rappture::Gauge::bump {delta} {
350	set val $_value
351	if {$val == ""} {
352	set val 0
353	}
354	if {[catch {value [expr {$val+$delta}]} result]} {
355	if {[regexp {allowed here is (.+)} $result match newval]} {
356	set _value $newval
357	$itk_component(value) configure -text $newval
358	}
359	if {[regexp {^bad.*: +(.)(.+)} $result match first tail]
360	\|\| [regexp {(.)(.+)} $result match first tail]} {
361	set result "[string toupper $first]$tail"
362	}
363	bell
364	Rappture::Tooltip::cue $itk_component(value) $result
365	return 0
366	}
367	}
368
369	# ----------------------------------------------------------------------
370	# USAGE: _redraw
371	#
372	# Used internally to redraw the gauge on the internal canvas based
373	# on the current value and the size of the widget. In this simple
374	# base class, the gauge is drawn as a colored block, with an optional
375	# image in the middle of it.
376	# ----------------------------------------------------------------------
377	itcl::body Rappture::Gauge::_redraw {} {
378	set c $itk_component(icon)
379	set w [winfo width $c]
380	set h [winfo height $c]
381
382	if {"" == [$c find all]} {
383	# first time around, create the items
384	$c create rectangle 0 0 1 1 -outline black -tags block
385	$c create image 0 0 -anchor center -image "" -tags bimage
386	$c create rectangle 0 0 1 1 -outline "" -fill "" -stipple gray50 -tags screen
387	}
388
389	if {"" != $itk_option(-spectrum)} {
390	set color [$itk_option(-spectrum) get $_value]
391	} else {
392	set color ""
393	}
394
395	# update the items based on current values
396	$c coords block 0 0 [expr {$w-1}] [expr {$h-1}]
397	$c coords screen 0 0 $w $h
398	$c itemconfigure block -fill $color
399
400	$c coords bimage [expr {0.5$w}] [expr {0.5$h}]
401
402	if {$itk_option(-state) == "disabled"} {
403	$c itemconfigure screen -fill white
404	} else {
405	$c itemconfigure screen -fill ""
406	}
407	}
408
409	# ----------------------------------------------------------------------
410	# USAGE: _resize
411	#
412	# Used internally to resize the internal canvas based on the -image
413	# option or the size of the text.
414	# ----------------------------------------------------------------------
415	itcl::body Rappture::Gauge::_resize {} {
416	set w 0
417	set h 0
418
419	if {"" != $itk_option(-image) \|\| "" != $itk_option(-spectrum)} {
420	if {$itk_option(-samplewidth) > 0} {
421	set w $itk_option(-samplewidth)
422	} else {
423	if {$itk_option(-image) != ""} {
424	set w [expr {[image width $itk_option(-image)]+4}]
425	} else {
426	set w [winfo reqheight $itk_component(value)]
427	}
428	}
429
430	if {$itk_option(-sampleheight) > 0} {
431	set h $itk_option(-sampleheight)
432	} else {
433	if {$itk_option(-image) != ""} {
434	set h [expr {[image height $itk_option(-image)]+4}]
435	} else {
436	set h [winfo reqheight $itk_component(value)]
437	}
438	}
439	}
440
441	if {$w > 0 && $h > 0} {
442	$itk_component(icon) configure -width $w -height $h
443	}
444	}
445
446	# ----------------------------------------------------------------------
447	# USAGE: _hilite <component> <state>
448	#
449	# Used internally to resize the internal canvas based on the -image
450	# option or the size of the text.
451	# ----------------------------------------------------------------------
452	itcl::body Rappture::Gauge::_hilite {comp state} {
453	if {$itk_option(-state) == "disabled"} {
454	set state 0 ;# disabled? then don't hilite
455	}
456	if {$comp == "value" && !$itk_option(-editable)} {
457	$itk_component(value) configure -relief flat
458	return
459	}
460
461	if {$state} {
462	$itk_component($comp) configure -relief solid
463	} else {
464	$itk_component($comp) configure -relief flat
465	}
466	}
467
468	# ----------------------------------------------------------------------
469	# USAGE: _editor popup
470	# USAGE: _editor activate
471	# USAGE: _editor validate <value>
472	# USAGE: _editor apply <value>
473	# USAGE: _editor menu <rootx> <rooty>
474	#
475	# Used internally to handle the various functions of the pop-up
476	# editor for the value of this gauge.
477	# ----------------------------------------------------------------------
478	itcl::body Rappture::Gauge::_editor {option args} {
479	if {$itk_option(-state) == "disabled"} {
480	return ;# disabled? then bail out here!
481	}
482	switch -- $option {
483	popup {
484	if {$itk_option(-editable)} {
485	$itk_component(editor) activate
486	}
487	}
488	activate {
489	return [list text $_value \
490	x [winfo rootx $itk_component(value)] \
491	y [winfo rooty $itk_component(value)] \
492	w [winfo width $itk_component(value)] \
493	h [winfo height $itk_component(value)]]
494	}
495	validate {
496	if {[llength $args] != 1} {
497	error "wrong # args: should be \"_editor validate val\""
498	}
499	set val [lindex $args 0]
500
501	if {[catch {value -check $val} result]} {
502	if {[regexp {allowed here is (.+)} $result match newval]} {
503	$itk_component(editor) value $newval
504	}
505	if {[regexp {^bad.*: +(.)(.+)} $result match first tail]
506	\|\| [regexp {(.)(.+)} $result match first tail]} {
507	set result "[string toupper $first]$tail"
508	}
509	bell
510	Rappture::Tooltip::cue $itk_component(editor) $result
511	return 0
512	}
513	}
514	apply {
515	if {[llength $args] != 1} {
516	error "wrong # args: should be \"_editor apply val\""
517	}
518	value [lindex $args 0]
519	}
520	menu {
521	eval tk_popup $itk_component(emenu) $args
522	}
523	default {
524	error "bad option \"$option\": should be popup, activate, validate, apply, and menu"
525	}
526	}
527	}
528
529	# ----------------------------------------------------------------------
530	# USAGE: _presets post
531	# USAGE: _presets unpost
532	# USAGE: _presets select
533	#
534	# Used internally to handle the list of presets for this gauge. The
535	# post/unpost options are invoked when the list is posted or unposted
536	# to manage the relief of the controlling button. The select option
537	# is invoked whenever there is a selection from the list, to assign
538	# the value back to the gauge.
539	# ----------------------------------------------------------------------
540	itcl::body Rappture::Gauge::_presets {option} {
541	switch -- $option {
542	post {
543	set i [$itk_component(presetlist) index $_value]
544	if {$i >= 0} {
545	$itk_component(presetlist) select clear 0 end
546	$itk_component(presetlist) select set $i
547	}
548	after 10 [list $itk_component(presets) configure -relief sunken]
549	}
550	unpost {
551	$itk_component(presets) configure -relief flat
552	}
553	select {
554	set val [$itk_component(presetlist) current]
555	if {"" != $val} {
556	value $val
557	}
558	}
559	default {
560	error "bad option \"$option\": should be post, unpost, select"
561	}
562	}
563	}
564
565	# ----------------------------------------------------------------------
566	# USAGE: _layout
567	#
568	# Used internally to fix the layout of widgets whenever there is a
569	# change in the options that affect layout. Puts the value in the
570	# proper position according to the -valueposition option. Also,
571	# adds or removes the icon if it needs to be shown.
572	# ----------------------------------------------------------------------
573	itcl::body Rappture::Gauge::_layout {} {
574	foreach w [pack slaves $itk_component(hull)] {
575	pack forget $w
576	}
577
578	array set side2anchor {
579	left e
580	right w
581	top s
582	bottom n
583	}
584	set pos $itk_option(-valueposition)
585	pack $itk_component(vframe) -side $pos \
586	-expand yes -fill both -ipadx 2
587	$itk_component(value) configure -anchor $side2anchor($pos)
588
589	if {"" != $itk_option(-image) \|\| "" != $itk_option(-spectrum)} {
590	pack $itk_component(icon) -side $pos
591	}
592	}
593
594	# ----------------------------------------------------------------------
595	# CONFIGURATION OPTION: -editable
596	# ----------------------------------------------------------------------
597	itcl::configbody Rappture::Gauge::editable {
598	if {![string is boolean -strict $itk_option(-editable)]} {
599	error "bad value \"$itk_option(-editable)\": should be boolean"
600	}
601	if {!$itk_option(-editable) && [winfo ismapped $itk_component(editor)]} {
602	$itk_component(editor) deactivate -abort
603	}
604	}
605
606	# ----------------------------------------------------------------------
607	# CONFIGURATION OPTION: -state
608	# ----------------------------------------------------------------------
609	itcl::configbody Rappture::Gauge::state {
610	set valid {normal disabled}
611	if {[lsearch -exact $valid $itk_option(-state)] < 0} {
612	error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
613	}
614	$itk_component(value) configure -state $itk_option(-state)
615	$itk_component(spinup) configure -state $itk_option(-state)
616	$itk_component(spindn) configure -state $itk_option(-state)
617	$itk_component(presets) configure -state $itk_option(-state)
618	_redraw ;# fix gauge
619	}
620
621	# ----------------------------------------------------------------------
622	# CONFIGURATION OPTION: -spectrum
623	# ----------------------------------------------------------------------
624	itcl::configbody Rappture::Gauge::spectrum {
625	if {$itk_option(-spectrum) != ""
626	&& ([catch {$itk_option(-spectrum) isa ::Rappture::Spectrum} valid]
627	\|\| !$valid)} {
628	error "bad option \"$itk_option(-spectrum)\": should be Rappture::Spectrum object"
629	}
630	_resize
631	_layout
632	_redraw
633	}
634
635	# ----------------------------------------------------------------------
636	# CONFIGURATION OPTION: -image
637	# ----------------------------------------------------------------------
638	itcl::configbody Rappture::Gauge::image {
639	if {$itk_option(-image) != ""
640	&& [catch {image width $itk_option(-image)}]} {
641	error "bad value \"$itk_option(-image)\": should be Tk image"
642	}
643	_resize
644	_layout
645	$itk_component(icon) itemconfigure bimage -image $itk_option(-image)
646	}
647
648	# ----------------------------------------------------------------------
649	# CONFIGURATION OPTION: -units
650	# ----------------------------------------------------------------------
651	itcl::configbody Rappture::Gauge::units {
652	if {$itk_option(-units) != ""
653	&& [::Rappture::Units::System::for $itk_option(-units)] == ""} {
654	error "unrecognized system of units \"$itk_option(-units)\""
655	}
656	}
657
658	# ----------------------------------------------------------------------
659	# CONFIGURATION OPTION: -valueposition
660	# ----------------------------------------------------------------------
661	itcl::configbody Rappture::Gauge::valueposition {
662	set pos $itk_option(-valueposition)
663	set opts {left right top bottom}
664	if {[lsearch -exact $opts $pos] < 0} {
665	error "bad value \"$pos\": should be [join $opts {, }]"
666	}
667	_layout
668	}
669
670	# ----------------------------------------------------------------------
671	# CONFIGURATION OPTION: -presets
672	# ----------------------------------------------------------------------
673	itcl::configbody Rappture::Gauge::presets {
674	if {"" == $itk_option(-presets)} {
675	pack forget $itk_component(presets)
676	} else {
677	if {$itk_option(-valueposition) == "left"} {
678	set s "left"
679	} else {
680	set s "right"
681	}
682	set first [lindex [pack slaves $itk_component(vframe)] 0]
683	pack $itk_component(presets) -before $first -side $s -fill y
684
685	$itk_component(presetlist) delete 0 end
686	$itk_component(presetlist) insert end $itk_option(-presets)
687	}
688	}
689
690	# ----------------------------------------------------------------------
691	# CONFIGURATION OPTION: -type
692	# ----------------------------------------------------------------------
693	itcl::configbody Rappture::Gauge::type {
694	switch -- $itk_option(-type) {
695	integer {
696	set first [lindex [pack slaves $itk_component(vframe)] 0]
697	if {$first == $itk_component(presets)} {
698	pack $itk_component(spinner) -after $first -side left -fill y
699	} else {
700	pack $itk_component(spinner) -before $first -side right -fill y
701	}
702	}
703	real {
704	pack forget $itk_component(spinner)
705	}
706	default {
707	error "bad number type \"$itk_option(-type)\": should be integer or real"
708	}
709	}
710	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: