Context Navigation

controls.tcl @ 761

Last change on this file since 761 was 761, checked in by mmc, 17 years ago

Added a new <note> object which can be used to add annotations to
the input side. Each <note> has a <contents> area which contains
a url for a web site or a file. All file urls are treated as
relative to the "docs" directory where the tool.xml is located.

Fixed the output for <number>, <integer>, <boolean>, and <choice>
so that it shows multiple values when "All" is pressed, and it
highlights the current value. Also fixed the download option for
this widget so that it works properly.

Fixed the energy level viewer so that its download option works.

File size: 23.8 KB

Line
1	# ----------------------------------------------------------------------
2	# COMPONENT: controls - a container for various Rappture controls
3	#
4	# This widget is a smart frame acting as a container for controls.
5	# Controls are added to this panel, and the panel itself decides
6	# how to arrange them given available space.
7	# ======================================================================
8	# AUTHOR: Michael McLennan, Purdue University
9	# Copyright (c) 2004-2005 Purdue Research Foundation
10	#
11	# See the file "license.terms" for information on usage and
12	# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13	# ======================================================================
14	package require Itk
15	package require BLT
16
17	option add *Controls.padding 4 widgetDefault
18	option add *Controls.labelFont \
19	--helvetica-medium-r-normal--12-* widgetDefault
20
21	itcl::class Rappture::Controls {
22	inherit itk::Widget
23
24	itk_option define -padding padding Padding 0
25
26	constructor {owner args} { # defined below }
27	destructor { # defined below }
28
29	public method insert {pos path}
30	public method delete {first {last ""}}
31	public method index {name}
32	public method control {args}
33	public method refresh {}
34
35	protected method _layout {}
36	protected method _monitor {name state}
37	protected method _controlChanged {name}
38	protected method _controlValue {path {units ""}}
39	protected method _formatLabel {str}
40	protected method _changeTabs {}
41	protected method _resize {}
42
43	private variable _owner "" ;# controls belong to this owner
44	private variable _tabs "" ;# optional tabset for groups
45	private variable _frame "" ;# pack controls into this frame
46	private variable _counter 0 ;# counter for control names
47	private variable _dispatcher "" ;# dispatcher for !events
48	private variable _controls "" ;# list of known controls
49	private variable _name2info ;# maps control name => info
50	private variable _scheme "" ;# layout scheme (tabs/hlabels)
51	}
52
53	itk::usual Controls {
54	}
55
56	# ----------------------------------------------------------------------
57	# CONSTRUCTOR
58	# ----------------------------------------------------------------------
59	itcl::body Rappture::Controls::constructor {owner args} {
60	Rappture::dispatcher _dispatcher
61	$_dispatcher register !layout
62	$_dispatcher dispatch $this !layout "[itcl::code $this _layout]; list"
63	$_dispatcher register !resize
64	$_dispatcher dispatch $this !resize "[itcl::code $this _resize]; list"
65
66	set _owner $owner
67
68	Rappture::Scroller $itk_interior.sc -xscrollmode none -yscrollmode auto
69	pack $itk_interior.sc -expand yes -fill both
70	set f [$itk_interior.sc contents frame]
71
72	set _tabs [blt::tabset $f.tabs -borderwidth 0 -relief flat \
73	-side top -tearoff 0 -highlightthickness 0 \
74	-selectbackground $itk_option(-background) \
75	-selectcommand [itcl::code $this _changeTabs]]
76
77	set _frame [frame $f.inner]
78	pack $_frame -expand yes -fill both
79
80	#
81	# Put this frame in whenever the control frame is empty.
82	# It forces the size to contract back now when controls are deleted.
83	#
84	frame $_frame.empty -width 1 -height 1
85
86	#
87	# Set up a binding that all inserted widgets will use so that
88	# we can monitor their size changes.
89	#
90	bind Controls-$this <Configure> \
91	[list $_dispatcher event -idle !resize]
92
93	eval itk_initialize $args
94	}
95
96	# ----------------------------------------------------------------------
97	# DESTRUCTOR
98	# ----------------------------------------------------------------------
99	itcl::body Rappture::Controls::destructor {} {
100	delete 0 end
101	}
102
103	# ----------------------------------------------------------------------
104	# USAGE: insert <pos> <path>
105	#
106	# Clients use this to insert a control into this panel. The control
107	# is inserted into the list at position <pos>, which can be an integer
108	# starting from 0 or the keyword "end". Information about the control
109	# is taken from the specified <path>.
110	#
111	# Returns a name that can be used to identify the control in other
112	# methods.
113	# ----------------------------------------------------------------------
114	itcl::body Rappture::Controls::insert {pos path} {
115	if {"end" == $pos} {
116	set pos [llength $_controls]
117	} elseif {![string is integer $pos]} {
118	error "bad index \"$pos\": should be integer or \"end\""
119	}
120
121	incr _counter
122	set name "control$_counter"
123	set path [$_owner xml element -as path $path]
124
125	set _name2info($name-path) $path
126	set _name2info($name-label) ""
127	set _name2info($name-type) ""
128	set _name2info($name-value) [set w $_frame.v$name]
129	set _name2info($name-enable) "yes"
130
131	set type [$_owner xml element -as type $path]
132	set _name2info($name-type) $type
133	switch -- $type {
134	choice {
135	Rappture::ChoiceEntry $w $_owner $path
136	bind $w <<Value>> [itcl::code $this _controlChanged $name]
137	}
138	group {
139	Rappture::GroupEntry $w $_owner $path
140	}
141	loader {
142	Rappture::Loader $w $_owner $path -tool [$_owner tool]
143	bind $w <<Value>> [itcl::code $this _controlChanged $name]
144	}
145	number {
146	Rappture::NumberEntry $w $_owner $path
147	bind $w <<Value>> [itcl::code $this _controlChanged $name]
148	}
149	integer {
150	Rappture::IntegerEntry $w $_owner $path
151	bind $w <<Value>> [itcl::code $this _controlChanged $name]
152	}
153	boolean {
154	Rappture::BooleanEntry $w $_owner $path
155	bind $w <<Value>> [itcl::code $this _controlChanged $name]
156	}
157	string {
158	Rappture::TextEntry $w $_owner $path
159	bind $w <<Value>> [itcl::code $this _controlChanged $name]
160	}
161	image {
162	Rappture::ImageEntry $w $_owner $path
163	}
164	control {
165	set label [$_owner xml get $path.label]
166	if {"" == $label} { set label "Simulate" }
167	set service [$_owner xml get $path.service]
168	button $w -text $label -command [list $service run]
169	}
170	separator {
171	# no widget to create
172	set _name2info($name-value) "--"
173	}
174	note {
175	Rappture::Note $w $_owner $path
176	}
177	default {
178	error "don't know how to add control type \"$type\""
179	}
180	}
181
182	#
183	# If this element has an <enable> expression, then register
184	# its controlling widget here.
185	#
186	set enable [string trim [$_owner xml get $path.about.enable]]
187	if {"" == $enable} {
188	set enable yes
189	}
190	if {![string is boolean $enable]} {
191	set re {([a-zA-Z_]+[0-9]\|$[^\($]+\)\|[a-zA-Z_]+[0-9]$[^\($]+\))(\.([a-zA-Z_]+[0-9]\|$[^\($]+\)\|[a-zA-Z_]+[0-9]$[^\($]+\)))*(:[-a-zA-Z0-9/]+)?}
192	set rest $enable
193	set enable ""
194	set deps ""
195	while {1} {
196	if {[regexp -indices $re $rest match]} {
197	foreach {s0 s1} $match break
198
199	if {[string index $rest [expr {$s0-1}]] == "\""
200	&& [string index $rest [expr {$s1+1}]] == "\""} {
201	# string in ""'s? then leave it alone
202	append enable [string range $rest 0 $s1]
203	set rest [string range $rest [expr {$s1+1}] end]
204	} else {
205	#
206	# This is a symbol which should be substituted
207	# it can be either:
208	# input.foo.bar
209	# input.foo.bar:units
210	#
211	set cpath [string range $rest $s0 $s1]
212	set parts [split $cpath :]
213	set ccpath [lindex $parts 0]
214	set units [lindex $parts 1]
215
216	# make sure we have the standard path notation
217	set stdpath [$_owner regularize $ccpath]
218	if {"" == $stdpath} {
219	puts stderr "WARNING: don't recognize parameter $cpath in <enable> expression for $path. This may be buried in a structure that is not yet loaded."
220	set stdpath $ccpath
221	}
222	# substitute [_controlValue ...] call in place of path
223	append enable [string range $rest 0 [expr {$s0-1}]]
224	append enable [format {[_controlValue %s %s]} $stdpath $units]
225	lappend deps $stdpath
226	set rest [string range $rest [expr {$s1+1}] end]
227	}
228	} else {
229	append enable $rest
230	break
231	}
232	}
233
234	foreach cpath $deps {
235	$_owner dependenciesfor $cpath $path
236	}
237	}
238	set _name2info($name-enable) $enable
239
240	$_owner widgetfor $path $w
241
242	if {[lsearch {control group separator note} $type] < 0} {
243	# make a label for this control
244	set label [$w label]
245	if {"" != $label} {
246	set _name2info($name-label) $_frame.l$name
247	set font [option get $itk_component(hull) labelFont Font]
248	label $_name2info($name-label) -text [_formatLabel $label] \
249	-font $font
250	}
251
252	# register the tooltip for this control
253	set tip [$w tooltip]
254	if {"" != $tip} {
255	Rappture::Tooltip::for $w $tip
256
257	# add the tooltip to the label too, if there is one
258	if {$_name2info($name-label) != ""} {
259	Rappture::Tooltip::for $_name2info($name-label) $tip
260	}
261	}
262	}
263
264	# insert the new control onto the known list
265	set _controls [linsert $_controls $pos $name]
266	_monitor $name on
267
268	# now that we have a new control, we should fix the layout
269	$_dispatcher event -idle !layout
270	_controlChanged $name
271
272	return $name
273	}
274
275	# ----------------------------------------------------------------------
276	# USAGE: delete <first> ?<last>?
277	#
278	# Clients use this to delete one or more controls from this widget.
279	# The <first> and <last> represent the integer index of the desired
280	# control. You can use the "index" method to convert a control name to
281	# its integer index. If only <first> is specified, then that one
282	# control is deleted. If <last> is specified, then all controls in the
283	# range <first> to <last> are deleted.
284	# ----------------------------------------------------------------------
285	itcl::body Rappture::Controls::delete {first {last ""}} {
286	if {$last == ""} {
287	set last $first
288	}
289	if {![regexp {^[0-9]+\|end$} $first]} {
290	error "bad index \"$first\": should be integer or \"end\""
291	}
292	if {![regexp {^[0-9]+\|end$} $last]} {
293	error "bad index \"$last\": should be integer or \"end\""
294	}
295
296	foreach name [lrange $_controls $first $last] {
297	_monitor $name off
298
299	if {"" != $_name2info($name-label)} {
300	destroy $_name2info($name-label)
301	}
302	if {"" != $_name2info($name-value)} {
303	destroy $_name2info($name-value)
304	}
305	$_owner widgetfor $_name2info($name-path) ""
306
307	unset _name2info($name-path)
308	unset _name2info($name-label)
309	unset _name2info($name-type)
310	unset _name2info($name-value)
311	unset _name2info($name-enable)
312	}
313	set _controls [lreplace $_controls $first $last]
314
315	$_dispatcher event -idle !layout
316	}
317
318	# ----------------------------------------------------------------------
319	# USAGE: index <name>\|@n
320	#
321	# Clients use this to convert a control <name> into its corresponding
322	# integer index. Returns an error if the <name> is not recognized.
323	# ----------------------------------------------------------------------
324	itcl::body Rappture::Controls::index {name} {
325	set i [lsearch $_controls $name]
326	if {$i >= 0} {
327	return $i
328	}
329	if {[regexp {^@([0-9]+)$} $name match i]} {
330	return $i
331	}
332	if {$name == "end"} {
333	return [expr {[llength $_controls]-1}]
334	}
335	error "bad control name \"$name\": should be @int or one of [join [lsort $_controls] {, }]"
336	}
337
338	# ----------------------------------------------------------------------
339	# USAGE: control ?-label\|-value\|-path\|-enable? ?<name>\|@n?
340	#
341	# Clients use this to get information about controls. With no args, it
342	# returns a list of all control names. Otherwise, it returns the frame
343	# associated with a control name. The -label option requests the label
344	# widget instead of the value widget. The -path option requests the
345	# path within the XML that the control affects. The -enable option
346	# requests the enabling condition for this control.
347	# ----------------------------------------------------------------------
348	itcl::body Rappture::Controls::control {args} {
349	if {[llength $args] == 0} {
350	return $_controls
351	}
352	Rappture::getopts args params {
353	flag switch -value default
354	flag switch -label
355	flag switch -path
356	flag switch -enable
357	}
358	if {[llength $args] == 0} {
359	error "missing control name"
360	}
361	set i [index [lindex $args 0]]
362	set name [lindex $_controls $i]
363
364	set opt $params(switch)
365	return $_name2info($name$opt)
366	}
367
368	# ----------------------------------------------------------------------
369	# USAGE: refresh
370	#
371	# Clients use this to refresh the layout of the control panel
372	# whenever a widget within the panel changes visibility state.
373	# ----------------------------------------------------------------------
374	itcl::body Rappture::Controls::refresh {} {
375	$_dispatcher event -idle !layout
376	}
377
378	# ----------------------------------------------------------------------
379	# USAGE: _layout
380	#
381	# Used internally to fix the layout of controls whenever controls
382	# are added or deleted, or when the control arrangement changes.
383	# There are a lot of heuristics here trying to achieve a "good"
384	# arrangement of controls.
385	# ----------------------------------------------------------------------
386	itcl::body Rappture::Controls::_layout {} {
387	#
388	# Clear any existing layout
389	#
390	foreach name $_controls {
391	foreach elem {label value} {
392	set w $_name2info($name-$elem)
393	if {$w != "" && [winfo exists $w]} {
394	grid forget $w
395	}
396	}
397	}
398	if {[$_tabs size] > 0} {
399	$_tabs delete 0 end
400	}
401	grid forget $_frame.empty
402
403	#
404	# Decide which widgets should be shown and which should be hidden.
405	#
406	set hidden ""
407	set showing ""
408	foreach name $_controls {
409	set show 1
410	set cond $_name2info($name-enable)
411	if {[string is boolean $cond] && !$cond} {
412	# hard-coded "off" -- ignore completely
413	} elseif {[catch {expr $cond} show] == 0} {
414	set type $_name2info($name-type)
415	set lwidget $_name2info($name-label)
416	set vwidget $_name2info($name-value)
417	if {[lsearch -exact {group image structure} $type] >= 0} {
418	if {$show} {
419	lappend showing $name
420	} else {
421	lappend hidden $name
422	}
423	} else {
424	# show other objects, but enable/disable them
425	lappend showing $name
426	if {$show} {
427	if {[winfo exists $vwidget]} {
428	$vwidget configure -state normal
429	}
430	if {[winfo exists $lwidget]} {
431	$lwidget configure -foreground \
432	[lindex [$lwidget configure -foreground] 3]
433	}
434	} else {
435	if {[winfo exists $vwidget]} {
436	$vwidget configure -state disabled
437	}
438	if {[winfo exists $lwidget]} {
439	$lwidget configure -foreground gray
440	}
441	}
442	}
443	} else {
444	bgerror "Error in <enable> expression for \"$_name2info($name-path)\":\n $show"
445	}
446	}
447
448	#
449	# Decide on a layout scheme:
450	# tabs ...... best if all elements within are groups
451	# hlabels ... horizontal labels (label: value)
452	#
453	if {[llength $showing] >= 2} {
454	# assume tabs for multiple groups
455	set _scheme tabs
456	foreach name $showing {
457	set w $_name2info($name-value)
458
459	if {$w == "--" \|\| [winfo class $w] != "GroupEntry"} {
460	# something other than a group? then fall back on hlabels
461	set _scheme hlabels
462	break
463	}
464	}
465	} else {
466	set _scheme hlabels
467	}
468
469	switch -- $_scheme {
470	tabs {
471	#
472	# SCHEME: tabs
473	# put a series of groups into a tabbed notebook
474	#
475
476	# use inner frame within tabs to show current group
477	pack $_tabs -before $_frame -fill x
478
479	set gn 1
480	foreach name $showing {
481	set wv $_name2info($name-value)
482	$wv configure -heading no
483
484	set label [$wv component heading cget -text]
485	if {"" == $label} {
486	set label "Group #$gn"
487	}
488	set _name2info($name-label) $label
489
490	$_tabs insert end $label \
491	-activebackground $itk_option(-background)
492
493	incr gn
494	}
495
496	# compute the overall size
497	# BE CAREFUL: do this after setting "-heading no" above
498	$_dispatcher event -now !resize
499
500	grid propagate $_frame off
501	grid columnconfigure $_frame 0 -weight 1
502	grid rowconfigure $_frame 0 -weight 1
503
504	$_tabs select 0; _changeTabs
505	}
506
507	hlabels {
508	#
509	# SCHEME: hlabels
510	# simple "Label: Value" layout
511	#
512	pack forget $_tabs
513	grid propagate $_frame on
514	grid columnconfigure $_frame 0 -weight 0
515	grid rowconfigure $_frame 0 -weight 0
516
517	set row 0
518	foreach name $showing {
519	set wl $_name2info($name-label)
520	if {$wl != "" && [winfo exists $wl]} {
521	grid $wl -row $row -column 0 -sticky e
522	}
523
524	set wv $_name2info($name-value)
525	if {$wv != "" && [winfo exists $wv]} {
526	if {$wl != ""} {
527	grid $wv -row $row -column 1 -sticky ew
528	} else {
529	grid $wv -row $row -column 0 -columnspan 2 -sticky ew
530	}
531
532	grid rowconfigure $_frame $row -weight 0
533
534	switch -- [winfo class $wv] {
535	TextEntry {
536	if {[regexp {[0-9]+x[0-9]+} [$wv size]]} {
537	grid $wl -sticky n -pady 4
538	grid $wv -sticky nsew
539	grid rowconfigure $_frame $row -weight 1
540	grid columnconfigure $_frame 1 -weight 1
541	}
542	}
543	GroupEntry {
544	$wv configure -heading yes
545	}
546	Note {
547	grid $wv -sticky nsew
548	grid rowconfigure $_frame $row -weight 1
549	}
550	}
551	grid columnconfigure $_frame 1 -weight 1
552	} elseif {$wv == "--"} {
553	grid rowconfigure $_frame $row -minsize 10
554	}
555
556	incr row
557	grid rowconfigure $_frame $row -minsize $itk_option(-padding)
558	incr row
559	}
560	grid $_frame.empty -row $row
561
562	#
563	# If there are any hidden items, then make the bottom of
564	# this form fill up any extra space, so the form floats
565	# to the top. Otherwise, it will jitter around as the
566	# hidden items come and go.
567	#
568	if {[llength $hidden] > 0} {
569	grid rowconfigure $_frame 99 -weight 1
570	} else {
571	grid rowconfigure $_frame 99 -weight 0
572	}
573	}
574	}
575	}
576
577	# ----------------------------------------------------------------------
578	# USAGE: _monitor <name> <state>
579	#
580	# Used internally to add/remove bindings that cause the widget
581	# associated with <name> to notify this controls widget of size
582	# changes. Whenever there is a size change, this controls widget
583	# should fix its layout.
584	# ----------------------------------------------------------------------
585	itcl::body Rappture::Controls::_monitor {name state} {
586	set tag "Controls-$this"
587	set wv $_name2info($name-value)
588	if {$wv == "--" \|\| [catch {bindtags $wv} btags]} {
589	return
590	}
591	set i [lsearch $btags $tag]
592
593	if {$state} {
594	if {$i < 0} {
595	bindtags $wv [linsert $btags 0 $tag]
596	}
597	} else {
598	if {$i >= 0} {
599	bindtags $wv [lreplace $btags $i $i]
600	}
601	}
602	}
603
604	# ----------------------------------------------------------------------
605	# USAGE: _controlChanged <name>
606	#
607	# Invoked automatically whenever the value for a control changes.
608	# Sends a notification along to the tool controlling this panel.
609	# ----------------------------------------------------------------------
610	itcl::body Rappture::Controls::_controlChanged {name} {
611	set path $_name2info($name-path)
612
613	#
614	# Let the owner know that this control changed.
615	#
616	if {"" != $_owner} {
617	$_owner changed $path
618	}
619	}
620
621	# ----------------------------------------------------------------------
622	# USAGE: _controlValue <path> ?<units>?
623	#
624	# Used internally to get the value of a control with the specified
625	# <path>. Returns the current value for the control.
626	# ----------------------------------------------------------------------
627	itcl::body Rappture::Controls::_controlValue {path {units ""}} {
628	if {"" != $_owner} {
629	set val [$_owner valuefor $path]
630	if {"" != $units} {
631	set val [Rappture::Units::convert $val -to $units -units off]
632	}
633	return $val
634	}
635	return ""
636	}
637
638	# ----------------------------------------------------------------------
639	# USAGE: _formatLabel <string>
640	#
641	# Used internally to format a label <string>. Trims any excess
642	# white space and adds a ":" to the end. That way, all labels
643	# have a uniform look.
644	# ----------------------------------------------------------------------
645	itcl::body Rappture::Controls::_formatLabel {str} {
646	set str [string trim $str]
647	if {"" != $str && [string index $str end] != ":"} {
648	append str ":"
649	}
650	return $str
651	}
652
653	# ----------------------------------------------------------------------
654	# USAGE: _changeTabs
655	#
656	# Used internally to change tabs when the user clicks on a tab
657	# in the "tabs" layout mode. This mode is used when the widget
658	# contains nothing but groups, as a compact way of representing
659	# the groups.
660	# ----------------------------------------------------------------------
661	itcl::body Rappture::Controls::_changeTabs {} {
662	set i [$_tabs index select]
663	set name [lindex $_controls $i]
664	if {"" != $name} {
665	foreach w [grid slaves $_frame] {
666	grid forget $w
667	}
668
669	set wv $_name2info($name-value)
670	grid $wv -row 0 -column 0 -sticky new
671	}
672	}
673
674	# ----------------------------------------------------------------------
675	# USAGE: _resize
676	#
677	# Used internally to resize the widget when its contents change.
678	# ----------------------------------------------------------------------
679	itcl::body Rappture::Controls::_resize {} {
680	switch -- $_scheme {
681	tabs {
682	# compute the overall size
683	# BE CAREFUL: do this after setting "-heading no" above
684	set maxw 0
685	set maxh 0
686	update idletasks
687	foreach name $_controls {
688	set wv $_name2info($name-value)
689	set w [winfo reqwidth $wv]
690	if {$w > $maxw} { set maxw $w }
691	set h [winfo reqheight $wv]
692	if {$h > $maxh} { set maxh $h }
693	}
694	$_frame configure -width $maxw -height $maxh
695	}
696	hlabels {
697	# do nothing
698	}
699	}
700	}
701
702	# ----------------------------------------------------------------------
703	# OPTION: -padding
704	# ----------------------------------------------------------------------
705	itcl::configbody Rappture::Controls::padding {
706	$_dispatcher event -idle !layout
707	}

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

Context Navigation

source: trunk/gui/scripts/controls.tcl @ 761

Download in other formats: