Context Navigation

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

Last change on this file since 563 was 563, checked in by dkearney, 18 years ago
small adjustments to gauge.tcl to fix errors in number and units recognition. adjusted configure.in and makefiles to allow user to specify the architecture they would like to use for compiling matlab bindings. also adjusted the main makefile not to try to compile bindings for languages it cannot find on the system.
File size: 24.5 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]
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 \
222	-context $units]
223	set nvUnits [Rappture::Units::Search::for $newval]
224	if { "" == $nvUnits} {
225	set msg [Rappture::Units::description $units]
226	error "Unrecognized units: $newval\nEnter value with units $msg"
227	}
228	set nv [Rappture::Units::convert $nv \
229	-context $units -to $units -units off]
230	}
231
232	switch -- $itk_option(-type) {
233	integer {
234	if {![string is integer -strict $nv]} {
235	error "Should be an integer value"
236	}
237	}
238	real {
239	if {![string is double -strict $nv]} {
240	error "Should be a real number"
241	}
242	}
243	}
244
245	if {"" != $itk_option(-minvalue)} {
246	set convMinVal [set minv $itk_option(-minvalue)]
247	if {$units != ""} {
248	set minv [Rappture::Units::convert $minv \
249	-context $units -to $units -units off]
250	set convMinVal [Rappture::Units::convert \
251	$itk_option(-minvalue) -to $nvUnits]
252	} else {
253	set newval [format "%g" $newval]
254	}
255
256	# fix for the case when the user tries to
257	# compare values like minv=-500 nv=-0600
258	set nv [format "%g" $nv]
259	set minv [format "%g" $minv]
260
261	if {$nv < $minv} {
262	error "minimum value allowed here is $convMinVal"
263	}
264	}
265
266	if {"" != $itk_option(-maxvalue)} {
267	set convMaxVal [set maxv $itk_option(-maxvalue)]
268	if {$units != ""} {
269	set maxv [Rappture::Units::convert $maxv \
270	-context $units -to $units -units off]
271	set convMaxVal [Rappture::Units::convert \
272	$itk_option(-maxvalue) -to $nvUnits]
273	} else {
274	set newval [format "%g" $newval]
275	}
276
277	# fix for the case when the user tries to
278	# compare values like maxv=500 nv=0600
279	set nv [format "%g" $nv]
280	set maxv [format "%g" $maxv]
281
282	if {$nv > $maxv} {
283	error "maximum value allowed here is $convMaxVal"
284	}
285	}
286
287	if {$onlycheck} {
288	return
289	}
290	set _value $newval
291	_redraw
292	event generate $itk_component(hull) <<Value>>
293
294	} elseif {[llength $args] != 0} {
295	error "wrong # args: should be \"value ?-check? ?newval?\""
296	}
297	return $_value
298	}
299
300	# ----------------------------------------------------------------------
301	# USAGE: edit cut
302	# USAGE: edit copy
303	# USAGE: edit paste
304	#
305	# Used internally to handle cut/copy/paste operations for the current
306	# value. Usually invoked by <<Cut>>, <<Copy>>, <<Paste>> events, but
307	# can also be called directly through this method.
308	# ----------------------------------------------------------------------
309	itcl::body Rappture::Gauge::edit {option} {
310	if {$itk_option(-state) == "disabled"} {
311	return ;# disabled? then bail out here!
312	}
313	switch -- $option {
314	cut {
315	edit copy
316	_editor popup
317	$itk_component(editor) value ""
318	$itk_component(editor) deactivate
319	}
320	copy {
321	clipboard clear
322	clipboard append $_value
323	}
324	paste {
325	_editor popup
326	$itk_component(editor) value [clipboard get]
327	$itk_component(editor) deactivate
328	}
329	default {
330	error "bad option \"$option\": should be cut, copy, paste"
331	}
332	}
333	}
334
335	# ----------------------------------------------------------------------
336	# USAGE: bump <delta>
337	#
338	# Changes the current value up/down by the <delta> value. Used
339	# internally by the up/down spinner buttons when the value is
340	# -type integer.
341	# ----------------------------------------------------------------------
342	itcl::body Rappture::Gauge::bump {delta} {
343	set val $_value
344	if {$val == ""} {
345	set val 0
346	}
347	if {[catch {value [expr {$val+$delta}]} result]} {
348	if {[regexp {allowed here is (.+)} $result match newval]} {
349	set _value $newval
350	$itk_component(value) configure -text $newval
351	}
352	if {[regexp {^bad.*: +(.)(.+)} $result match first tail]
353	\|\| [regexp {(.)(.+)} $result match first tail]} {
354	set result "[string toupper $first]$tail"
355	}
356	bell
357	Rappture::Tooltip::cue $itk_component(value) $result
358	return 0
359	}
360	}
361
362	# ----------------------------------------------------------------------
363	# USAGE: _redraw
364	#
365	# Used internally to redraw the gauge on the internal canvas based
366	# on the current value and the size of the widget. In this simple
367	# base class, the gauge is drawn as a colored block, with an optional
368	# image in the middle of it.
369	# ----------------------------------------------------------------------
370	itcl::body Rappture::Gauge::_redraw {} {
371	set c $itk_component(icon)
372	set w [winfo width $c]
373	set h [winfo height $c]
374
375	if {"" == [$c find all]} {
376	# first time around, create the items
377	$c create rectangle 0 0 1 1 -outline black -tags block
378	$c create image 0 0 -anchor center -image "" -tags bimage
379	$c create rectangle 0 0 1 1 -outline "" -fill "" -stipple gray50 -tags screen
380	}
381
382	if {"" != $itk_option(-spectrum)} {
383	set color [$itk_option(-spectrum) get $_value]
384	} else {
385	set color ""
386	}
387
388	# update the items based on current values
389	$c coords block 0 0 [expr {$w-1}] [expr {$h-1}]
390	$c coords screen 0 0 $w $h
391	$c itemconfigure block -fill $color
392
393	$c coords bimage [expr {0.5$w}] [expr {0.5$h}]
394
395	if {$itk_option(-state) == "disabled"} {
396	$c itemconfigure screen -fill white
397	} else {
398	$c itemconfigure screen -fill ""
399	}
400	}
401
402	# ----------------------------------------------------------------------
403	# USAGE: _resize
404	#
405	# Used internally to resize the internal canvas based on the -image
406	# option or the size of the text.
407	# ----------------------------------------------------------------------
408	itcl::body Rappture::Gauge::_resize {} {
409	set w 0
410	set h 0
411
412	if {"" != $itk_option(-image) \|\| "" != $itk_option(-spectrum)} {
413	if {$itk_option(-samplewidth) > 0} {
414	set w $itk_option(-samplewidth)
415	} else {
416	if {$itk_option(-image) != ""} {
417	set w [expr {[image width $itk_option(-image)]+4}]
418	} else {
419	set w [winfo reqheight $itk_component(value)]
420	}
421	}
422
423	if {$itk_option(-sampleheight) > 0} {
424	set h $itk_option(-sampleheight)
425	} else {
426	if {$itk_option(-image) != ""} {
427	set h [expr {[image height $itk_option(-image)]+4}]
428	} else {
429	set h [winfo reqheight $itk_component(value)]
430	}
431	}
432	}
433
434	if {$w > 0 && $h > 0} {
435	$itk_component(icon) configure -width $w -height $h
436	}
437	}
438
439	# ----------------------------------------------------------------------
440	# USAGE: _hilite <component> <state>
441	#
442	# Used internally to resize the internal canvas based on the -image
443	# option or the size of the text.
444	# ----------------------------------------------------------------------
445	itcl::body Rappture::Gauge::_hilite {comp state} {
446	if {$itk_option(-state) == "disabled"} {
447	set state 0 ;# disabled? then don't hilite
448	}
449	if {$comp == "value" && !$itk_option(-editable)} {
450	$itk_component(value) configure -relief flat
451	return
452	}
453
454	if {$state} {
455	$itk_component($comp) configure -relief solid
456	} else {
457	$itk_component($comp) configure -relief flat
458	}
459	}
460
461	# ----------------------------------------------------------------------
462	# USAGE: _editor popup
463	# USAGE: _editor activate
464	# USAGE: _editor validate <value>
465	# USAGE: _editor apply <value>
466	# USAGE: _editor menu <rootx> <rooty>
467	#
468	# Used internally to handle the various functions of the pop-up
469	# editor for the value of this gauge.
470	# ----------------------------------------------------------------------
471	itcl::body Rappture::Gauge::_editor {option args} {
472	if {$itk_option(-state) == "disabled"} {
473	return ;# disabled? then bail out here!
474	}
475	switch -- $option {
476	popup {
477	if {$itk_option(-editable)} {
478	$itk_component(editor) activate
479	}
480	}
481	activate {
482	return [list text $_value \
483	x [winfo rootx $itk_component(value)] \
484	y [winfo rooty $itk_component(value)] \
485	w [winfo width $itk_component(value)] \
486	h [winfo height $itk_component(value)]]
487	}
488	validate {
489	if {[llength $args] != 1} {
490	error "wrong # args: should be \"_editor validate val\""
491	}
492	set val [lindex $args 0]
493
494	if {[catch {value -check $val} result]} {
495	if {[regexp {allowed here is (.+)} $result match newval]} {
496	$itk_component(editor) value $newval
497	}
498	if {[regexp {^bad.*: +(.)(.+)} $result match first tail]
499	\|\| [regexp {(.)(.+)} $result match first tail]} {
500	set result "[string toupper $first]$tail"
501	}
502	bell
503	Rappture::Tooltip::cue $itk_component(editor) $result
504	return 0
505	}
506	}
507	apply {
508	if {[llength $args] != 1} {
509	error "wrong # args: should be \"_editor apply val\""
510	}
511	value [lindex $args 0]
512	}
513	menu {
514	eval tk_popup $itk_component(emenu) $args
515	}
516	default {
517	error "bad option \"$option\": should be popup, activate, validate, apply, and menu"
518	}
519	}
520	}
521
522	# ----------------------------------------------------------------------
523	# USAGE: _presets post
524	# USAGE: _presets unpost
525	# USAGE: _presets select
526	#
527	# Used internally to handle the list of presets for this gauge. The
528	# post/unpost options are invoked when the list is posted or unposted
529	# to manage the relief of the controlling button. The select option
530	# is invoked whenever there is a selection from the list, to assign
531	# the value back to the gauge.
532	# ----------------------------------------------------------------------
533	itcl::body Rappture::Gauge::_presets {option} {
534	switch -- $option {
535	post {
536	set i [$itk_component(presetlist) index $_value]
537	if {$i >= 0} {
538	$itk_component(presetlist) select clear 0 end
539	$itk_component(presetlist) select set $i
540	}
541	after 10 [list $itk_component(presets) configure -relief sunken]
542	}
543	unpost {
544	$itk_component(presets) configure -relief flat
545	}
546	select {
547	set val [$itk_component(presetlist) current]
548	if {"" != $val} {
549	value $val
550	}
551	}
552	default {
553	error "bad option \"$option\": should be post, unpost, select"
554	}
555	}
556	}
557
558	# ----------------------------------------------------------------------
559	# USAGE: _layout
560	#
561	# Used internally to fix the layout of widgets whenever there is a
562	# change in the options that affect layout. Puts the value in the
563	# proper position according to the -valueposition option. Also,
564	# adds or removes the icon if it needs to be shown.
565	# ----------------------------------------------------------------------
566	itcl::body Rappture::Gauge::_layout {} {
567	foreach w [pack slaves $itk_component(hull)] {
568	pack forget $w
569	}
570
571	array set side2anchor {
572	left e
573	right w
574	top s
575	bottom n
576	}
577	set pos $itk_option(-valueposition)
578	pack $itk_component(vframe) -side $pos \
579	-expand yes -fill both -ipadx 2
580	$itk_component(value) configure -anchor $side2anchor($pos)
581
582	if {"" != $itk_option(-image) \|\| "" != $itk_option(-spectrum)} {
583	pack $itk_component(icon) -side $pos
584	}
585	}
586
587	# ----------------------------------------------------------------------
588	# CONFIGURATION OPTION: -editable
589	# ----------------------------------------------------------------------
590	itcl::configbody Rappture::Gauge::editable {
591	if {![string is boolean -strict $itk_option(-editable)]} {
592	error "bad value \"$itk_option(-editable)\": should be boolean"
593	}
594	if {!$itk_option(-editable) && [winfo ismapped $itk_component(editor)]} {
595	$itk_component(editor) deactivate -abort
596	}
597	}
598
599	# ----------------------------------------------------------------------
600	# CONFIGURATION OPTION: -state
601	# ----------------------------------------------------------------------
602	itcl::configbody Rappture::Gauge::state {
603	set valid {normal disabled}
604	if {[lsearch -exact $valid $itk_option(-state)] < 0} {
605	error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
606	}
607	$itk_component(value) configure -state $itk_option(-state)
608	$itk_component(spinup) configure -state $itk_option(-state)
609	$itk_component(spindn) configure -state $itk_option(-state)
610	$itk_component(presets) configure -state $itk_option(-state)
611	_redraw ;# fix gauge
612	}
613
614	# ----------------------------------------------------------------------
615	# CONFIGURATION OPTION: -spectrum
616	# ----------------------------------------------------------------------
617	itcl::configbody Rappture::Gauge::spectrum {
618	if {$itk_option(-spectrum) != ""
619	&& ([catch {$itk_option(-spectrum) isa ::Rappture::Spectrum} valid]
620	\|\| !$valid)} {
621	error "bad option \"$itk_option(-spectrum)\": should be Rappture::Spectrum object"
622	}
623	_resize
624	_layout
625	_redraw
626	}
627
628	# ----------------------------------------------------------------------
629	# CONFIGURATION OPTION: -image
630	# ----------------------------------------------------------------------
631	itcl::configbody Rappture::Gauge::image {
632	if {$itk_option(-image) != ""
633	&& [catch {image width $itk_option(-image)}]} {
634	error "bad value \"$itk_option(-image)\": should be Tk image"
635	}
636	_resize
637	_layout
638	$itk_component(icon) itemconfigure bimage -image $itk_option(-image)
639	}
640
641	# ----------------------------------------------------------------------
642	# CONFIGURATION OPTION: -units
643	# ----------------------------------------------------------------------
644	itcl::configbody Rappture::Gauge::units {
645	if {$itk_option(-units) != ""
646	&& [::Rappture::Units::System::for $itk_option(-units)] == ""} {
647	error "unrecognized system of units \"$itk_option(-units)\""
648	}
649	}
650
651	# ----------------------------------------------------------------------
652	# CONFIGURATION OPTION: -valueposition
653	# ----------------------------------------------------------------------
654	itcl::configbody Rappture::Gauge::valueposition {
655	set pos $itk_option(-valueposition)
656	set opts {left right top bottom}
657	if {[lsearch -exact $opts $pos] < 0} {
658	error "bad value \"$pos\": should be [join $opts {, }]"
659	}
660	_layout
661	}
662
663	# ----------------------------------------------------------------------
664	# CONFIGURATION OPTION: -presets
665	# ----------------------------------------------------------------------
666	itcl::configbody Rappture::Gauge::presets {
667	if {"" == $itk_option(-presets)} {
668	pack forget $itk_component(presets)
669	} else {
670	if {$itk_option(-valueposition) == "left"} {
671	set s "left"
672	} else {
673	set s "right"
674	}
675	set first [lindex [pack slaves $itk_component(vframe)] 0]
676	pack $itk_component(presets) -before $first -side $s -fill y
677
678	$itk_component(presetlist) delete 0 end
679	$itk_component(presetlist) insert end $itk_option(-presets)
680	}
681	}
682
683	# ----------------------------------------------------------------------
684	# CONFIGURATION OPTION: -type
685	# ----------------------------------------------------------------------
686	itcl::configbody Rappture::Gauge::type {
687	switch -- $itk_option(-type) {
688	integer {
689	set first [lindex [pack slaves $itk_component(vframe)] 0]
690	if {$first == $itk_component(presets)} {
691	pack $itk_component(spinner) -after $first -side left -fill y
692	} else {
693	pack $itk_component(spinner) -before $first -side right -fill y
694	}
695	}
696	real {
697	pack forget $itk_component(spinner)
698	}
699	default {
700	error "bad number type \"$itk_option(-type)\": should be integer or real"
701	}
702	}
703	}

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

Download in other formats: