Context Navigation

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

Last change on this file since 786 was 786, checked in by mmc, 17 years ago
Fixed the layout of groups/notes so that largest elements on the page expand properly.
File size: 25.1 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 expand 0 ;# most controls float to top
518	set row 0
519	foreach name $showing {
520	set wl $_name2info($name-label)
521	if {$wl != "" && [winfo exists $wl]} {
522	grid $wl -row $row -column 0 -sticky e
523	}
524
525	set wv $_name2info($name-value)
526	if {$wv != "" && [winfo exists $wv]} {
527	if {$wl != ""} {
528	grid $wv -row $row -column 1 -sticky ew
529	} else {
530	grid $wv -row $row -column 0 -columnspan 2 -sticky ew
531	}
532
533	grid rowconfigure $_frame $row -weight 0
534
535	switch -- [winfo class $wv] {
536	TextEntry {
537	if {[regexp {[0-9]+x[0-9]+} [$wv size]]} {
538	grid $wl -sticky n -pady 4
539	grid $wv -sticky nsew
540	grid rowconfigure $_frame $row -weight 1
541	grid columnconfigure $_frame 1 -weight 1
542	set expand 1
543	}
544	}
545	GroupEntry {
546	$wv configure -heading yes
547
548	#
549	# Scan through all children in this group
550	# and see if any demand more space. If the
551	# group contains a structure or a note, then
552	# make sure that the group itself is set to
553	# expand/fill.
554	#
555	set queue [winfo children $wv]
556	set expandgroup 0
557	while {[llength $queue] > 0} {
558	set w [lindex $queue 0]
559	set queue [lrange $queue 1 end]
560	set c [winfo class $w]
561	if {[lsearch {DeviceEditor Note} $c] >= 0} {
562	set expandgroup 1
563	break
564	}
565	eval lappend queue [winfo children $w]
566	}
567	if {$expandgroup} {
568	set expand 1
569	grid $wv -sticky nsew
570	grid rowconfigure $_frame $row -weight 1
571	}
572	}
573	Note {
574	grid $wv -sticky nsew
575	grid rowconfigure $_frame $row -weight 1
576	set expand 1
577	}
578	}
579	grid columnconfigure $_frame 1 -weight 1
580	} elseif {$wv == "--"} {
581	grid rowconfigure $_frame $row -minsize 10
582	}
583
584	incr row
585	grid rowconfigure $_frame $row -minsize $itk_option(-padding)
586	incr row
587	}
588	grid $_frame.empty -row $row
589
590	#
591	# If there are any hidden items, then make the bottom of
592	# this form fill up any extra space, so the form floats
593	# to the top. Otherwise, it will jitter around as the
594	# hidden items come and go.
595	#
596	if {[llength $hidden] > 0 && !$expand} {
597	grid rowconfigure $_frame 99 -weight 1
598	} else {
599	grid rowconfigure $_frame 99 -weight 0
600	}
601	}
602	}
603	}
604
605	# ----------------------------------------------------------------------
606	# USAGE: _monitor <name> <state>
607	#
608	# Used internally to add/remove bindings that cause the widget
609	# associated with <name> to notify this controls widget of size
610	# changes. Whenever there is a size change, this controls widget
611	# should fix its layout.
612	# ----------------------------------------------------------------------
613	itcl::body Rappture::Controls::_monitor {name state} {
614	set tag "Controls-$this"
615	set wv $_name2info($name-value)
616	if {$wv == "--" \|\| [catch {bindtags $wv} btags]} {
617	return
618	}
619	set i [lsearch $btags $tag]
620
621	if {$state} {
622	if {$i < 0} {
623	bindtags $wv [linsert $btags 0 $tag]
624	}
625	} else {
626	if {$i >= 0} {
627	bindtags $wv [lreplace $btags $i $i]
628	}
629	}
630	}
631
632	# ----------------------------------------------------------------------
633	# USAGE: _controlChanged <name>
634	#
635	# Invoked automatically whenever the value for a control changes.
636	# Sends a notification along to the tool controlling this panel.
637	# ----------------------------------------------------------------------
638	itcl::body Rappture::Controls::_controlChanged {name} {
639	set path $_name2info($name-path)
640
641	#
642	# Let the owner know that this control changed.
643	#
644	if {"" != $_owner} {
645	$_owner changed $path
646	}
647	}
648
649	# ----------------------------------------------------------------------
650	# USAGE: _controlValue <path> ?<units>?
651	#
652	# Used internally to get the value of a control with the specified
653	# <path>. Returns the current value for the control.
654	# ----------------------------------------------------------------------
655	itcl::body Rappture::Controls::_controlValue {path {units ""}} {
656	if {"" != $_owner} {
657	set val [$_owner valuefor $path]
658	if {"" != $units} {
659	set val [Rappture::Units::convert $val -to $units -units off]
660	}
661	return $val
662	}
663	return ""
664	}
665
666	# ----------------------------------------------------------------------
667	# USAGE: _formatLabel <string>
668	#
669	# Used internally to format a label <string>. Trims any excess
670	# white space and adds a ":" to the end. That way, all labels
671	# have a uniform look.
672	# ----------------------------------------------------------------------
673	itcl::body Rappture::Controls::_formatLabel {str} {
674	set str [string trim $str]
675	if {"" != $str && [string index $str end] != ":"} {
676	append str ":"
677	}
678	return $str
679	}
680
681	# ----------------------------------------------------------------------
682	# USAGE: _changeTabs
683	#
684	# Used internally to change tabs when the user clicks on a tab
685	# in the "tabs" layout mode. This mode is used when the widget
686	# contains nothing but groups, as a compact way of representing
687	# the groups.
688	# ----------------------------------------------------------------------
689	itcl::body Rappture::Controls::_changeTabs {} {
690	set i [$_tabs index select]
691	set name [lindex $_controls $i]
692	if {"" != $name} {
693	foreach w [grid slaves $_frame] {
694	grid forget $w
695	}
696
697	set wv $_name2info($name-value)
698	grid $wv -row 0 -column 0 -sticky new
699	}
700	}
701
702	# ----------------------------------------------------------------------
703	# USAGE: _resize
704	#
705	# Used internally to resize the widget when its contents change.
706	# ----------------------------------------------------------------------
707	itcl::body Rappture::Controls::_resize {} {
708	switch -- $_scheme {
709	tabs {
710	# compute the overall size
711	# BE CAREFUL: do this after setting "-heading no" above
712	set maxw 0
713	set maxh 0
714	update idletasks
715	foreach name $_controls {
716	set wv $_name2info($name-value)
717	set w [winfo reqwidth $wv]
718	if {$w > $maxw} { set maxw $w }
719	set h [winfo reqheight $wv]
720	if {$h > $maxh} { set maxh $h }
721	}
722	$_frame configure -width $maxw -height $maxh
723	}
724	hlabels {
725	# do nothing
726	}
727	}
728	}
729
730	# ----------------------------------------------------------------------
731	# OPTION: -padding
732	# ----------------------------------------------------------------------
733	itcl::configbody Rappture::Controls::padding {
734	$_dispatcher event -idle !layout
735	}

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

Download in other formats: