Context Navigation

source: branches/blt4/gui/scripts/controls.tcl @ 1675

Last change on this file since 1675 was 1675, checked in by gah, 14 years ago

File size: 22.5 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 { index }
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 _showing "" ;# list of enabled (showing) controls
50	private variable _name2info ;# maps control name => info
51	private variable _scheme "" ;# layout scheme (tabs/hlabels)
52	}
53
54	itk::usual Controls {
55	}
56
57	# ----------------------------------------------------------------------
58	# CONSTRUCTOR
59	# ----------------------------------------------------------------------
60	itcl::body Rappture::Controls::constructor {owner args} {
61	Rappture::dispatcher _dispatcher
62	$_dispatcher register !layout
63	$_dispatcher dispatch $this !layout "[itcl::code $this _layout]; list"
64	$_dispatcher register !resize
65	$_dispatcher dispatch $this !resize "[itcl::code $this _resize]; list"
66
67	set _owner $owner
68
69	blt::scrollset $itk_interior.sc -yscrollbar $itk_interior.sc.ys \
70	-window $itk_interior.sc.frame
71	blt::tk::scrollbar $itk_interior.sc.ys
72	pack $itk_interior.sc -expand yes -fill both
73	set f [frame $itk_interior.sc.frame]
74	set _tabs [blt::tabset $f.tabs -outerborderwidth 0 -outerrelief flat \
75	-side top -tearoff 0 -highlightthickness 0 \
76	-selectbackground $itk_option(-background) \
77	-selectcommand [itcl::code $this _changeTabs]]
78	set _frame [frame $f.inner]
79	pack $_frame -expand yes -fill both
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	filechoice {
139	Rappture::FileChoiceEntry $w $_owner $path
140	bind $w <<Value>> [itcl::code $this _controlChanged $name]
141	}
142	group {
143	Rappture::GroupEntry $w $_owner $path
144	}
145	loader {
146	Rappture::Loader $w $_owner $path -tool [$_owner tool]
147	bind $w <<Value>> [itcl::code $this _controlChanged $name]
148	}
149	number {
150	Rappture::NumberEntry $w $_owner $path
151	bind $w <<Value>> [itcl::code $this _controlChanged $name]
152	}
153	integer {
154	Rappture::IntegerEntry $w $_owner $path
155	bind $w <<Value>> [itcl::code $this _controlChanged $name]
156	}
157	boolean {
158	Rappture::BooleanEntry $w $_owner $path
159	bind $w <<Value>> [itcl::code $this _controlChanged $name]
160	}
161	string {
162	Rappture::TextEntry $w $_owner $path
163	bind $w <<Value>> [itcl::code $this _controlChanged $name]
164	}
165	image {
166	Rappture::ImageEntry $w $_owner $path
167	}
168	control {
169	set label [$_owner xml get $path.label]
170	if {"" == $label} { set label "Simulate" }
171	set service [$_owner xml get $path.service]
172	button $w -text $label -command [list $service run]
173	}
174	separator {
175	# no widget to create
176	set _name2info($name-value) "--"
177	}
178	note {
179	Rappture::Note $w $_owner $path
180	}
181	periodicelement {
182	Rappture::PeriodicElementEntry $w $_owner $path
183	bind $w <<Value>> [itcl::code $this _controlChanged $name]
184	}
185	default {
186	error "don't know how to add control type \"$type\""
187	}
188	}
189
190	#
191	# If this element has an <enable> expression, then register
192	# its controlling widget here.
193	#
194	set notify [string trim [$_owner xml get $path.about.notify]]
195
196	#
197	# If this element has an <enable> expression, then register
198	# its controlling widget here.
199	#
200	set enable [string trim [$_owner xml get $path.about.enable]]
201	if {"" == $enable} {
202	set enable yes
203	}
204	if {![string is boolean $enable]} {
205	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/]+)?}
206	set rest $enable
207	set enable ""
208	set deps ""
209	while {1} {
210	if {[regexp -indices $re $rest match]} {
211	foreach {s0 s1} $match break
212
213	if {[string index $rest [expr {$s0-1}]] == "\""
214	&& [string index $rest [expr {$s1+1}]] == "\""} {
215	# string in ""'s? then leave it alone
216	append enable [string range $rest 0 $s1]
217	set rest [string range $rest [expr {$s1+1}] end]
218	} else {
219	#
220	# This is a symbol which should be substituted
221	# it can be either:
222	# input.foo.bar
223	# input.foo.bar:units
224	#
225	set cpath [string range $rest $s0 $s1]
226	set parts [split $cpath :]
227	set ccpath [lindex $parts 0]
228	set units [lindex $parts 1]
229
230	# make sure we have the standard path notation
231	set stdpath [$_owner regularize $ccpath]
232	if {"" == $stdpath} {
233	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."
234	set stdpath $ccpath
235	}
236	# substitute [_controlValue ...] call in place of path
237	append enable [string range $rest 0 [expr {$s0-1}]]
238	append enable [format {[_controlValue %s %s]} $stdpath $units]
239	lappend deps $stdpath
240	set rest [string range $rest [expr {$s1+1}] end]
241	}
242	} else {
243	append enable $rest
244	break
245	}
246	}
247
248	foreach cpath $deps {
249	$_owner dependenciesfor $cpath $path
250	}
251	}
252	set _name2info($name-enable) $enable
253
254	$_owner widgetfor $path $w
255
256	if {[lsearch {control group separator note} $type] < 0} {
257	# make a label for this control
258	set label [$w label]
259	if {"" != $label} {
260	set _name2info($name-label) $_frame.l$name
261	set font [option get $itk_component(hull) labelFont Font]
262	label $_name2info($name-label) -text [_formatLabel $label] \
263	-font $font
264	}
265
266	# register the tooltip for this control
267	set tip [$w tooltip]
268	if {"" != $tip} {
269	Rappture::Tooltip::for $w $tip
270
271	# add the tooltip to the label too, if there is one
272	if {$_name2info($name-label) != ""} {
273	Rappture::Tooltip::for $_name2info($name-label) $tip
274	}
275	}
276	}
277
278	# insert the new control onto the known list
279	set _controls [linsert $_controls $pos $name]
280	_monitor $name on
281
282	# now that we have a new control, we should fix the layout
283	$_dispatcher event -idle !layout
284	_controlChanged $name
285
286	return $name
287	}
288
289	# ----------------------------------------------------------------------
290	# USAGE: delete <first> ?<last>?
291	#
292	# Clients use this to delete one or more controls from this widget.
293	# The <first> and <last> represent the integer index of the desired
294	# control. You can use the "index" method to convert a control name to
295	# its integer index. If only <first> is specified, then that one
296	# control is deleted. If <last> is specified, then all controls in the
297	# range <first> to <last> are deleted.
298	# ----------------------------------------------------------------------
299	itcl::body Rappture::Controls::delete {first {last ""}} {
300	if {$last == ""} {
301	set last $first
302	}
303	if {![regexp {^[0-9]+\|end$} $first]} {
304	error "bad index \"$first\": should be integer or \"end\""
305	}
306	if {![regexp {^[0-9]+\|end$} $last]} {
307	error "bad index \"$last\": should be integer or \"end\""
308	}
309
310	foreach name [lrange $_controls $first $last] {
311	_monitor $name off
312
313	if {"" != $_name2info($name-label)} {
314	destroy $_name2info($name-label)
315	}
316	if {"" != $_name2info($name-value)} {
317	destroy $_name2info($name-value)
318	}
319	$_owner widgetfor $_name2info($name-path) ""
320
321	unset _name2info($name-path)
322	unset _name2info($name-label)
323	unset _name2info($name-type)
324	unset _name2info($name-value)
325	unset _name2info($name-enable)
326	}
327	set _controls [lreplace $_controls $first $last]
328
329	$_dispatcher event -idle !layout
330	}
331
332	# ----------------------------------------------------------------------
333	# USAGE: index <name>\|@n
334	#
335	# Clients use this to convert a control <name> into its corresponding
336	# integer index. Returns an error if the <name> is not recognized.
337	# ----------------------------------------------------------------------
338	itcl::body Rappture::Controls::index {name} {
339	set i [lsearch $_controls $name]
340	if {$i >= 0} {
341	return $i
342	}
343	if {[regexp {^@([0-9]+)$} $name match i]} {
344	return $i
345	}
346	if {$name == "end"} {
347	return [expr {[llength $_controls]-1}]
348	}
349	error "bad control name \"$name\": should be @int or one of [join [lsort $_controls] {, }]"
350	}
351
352	# ----------------------------------------------------------------------
353	# USAGE: control ?-label\|-value\|-path\|-enable? ?<name>\|@n?
354	#
355	# Clients use this to get information about controls. With no args, it
356	# returns a list of all control names. Otherwise, it returns the frame
357	# associated with a control name. The -label option requests the label
358	# widget instead of the value widget. The -path option requests the
359	# path within the XML that the control affects. The -enable option
360	# requests the enabling condition for this control.
361	# ----------------------------------------------------------------------
362	itcl::body Rappture::Controls::control {args} {
363	if {[llength $args] == 0} {
364	return $_controls
365	}
366	Rappture::getopts args params {
367	flag switch -value default
368	flag switch -label
369	flag switch -path
370	flag switch -enable
371	}
372	if {[llength $args] == 0} {
373	error "missing control name"
374	}
375	set i [index [lindex $args 0]]
376	set name [lindex $_controls $i]
377
378	set opt $params(switch)
379	return $_name2info($name$opt)
380	}
381
382	# ----------------------------------------------------------------------
383	# USAGE: refresh
384	#
385	# Clients use this to refresh the layout of the control panel
386	# whenever a widget within the panel changes visibility state.
387	# ----------------------------------------------------------------------
388	itcl::body Rappture::Controls::refresh {} {
389	$_dispatcher event -idle !layout
390	}
391
392	# ----------------------------------------------------------------------
393	# USAGE: _layout
394	#
395	# Used internally to fix the layout of controls whenever controls
396	# are added or deleted, or when the control arrangement changes.
397	# There are a lot of heuristics here trying to achieve a "good"
398	# arrangement of controls.
399	# ----------------------------------------------------------------------
400	itcl::body Rappture::Controls::_layout {} {
401	#
402	# Clear any existing layout
403	#
404	foreach name $_controls {
405	foreach elem {label value} {
406	set w $_name2info($name-$elem)
407	if {$w != "" && [winfo exists $w]} {
408	grid forget $w
409	}
410	}
411	}
412	if {[$_tabs size] > 0} {
413	$_tabs delete 0 end
414	}
415	grid forget $_frame.empty
416
417	#
418	# Decide which widgets should be shown and which should be hidden.
419	#
420	set hidden ""
421	set showing ""
422	foreach name $_controls {
423	set show 1
424	set cond $_name2info($name-enable)
425	if {[string is boolean $cond] && !$cond} {
426	# hard-coded "off" -- ignore completely
427	} elseif {[catch {expr $cond} show] == 0} {
428	set type $_name2info($name-type)
429	set lwidget $_name2info($name-label)
430	set vwidget $_name2info($name-value)
431	if {[lsearch -exact {group image structure} $type] >= 0} {
432	if {$show} {
433	lappend showing $name
434	} else {
435	lappend hidden $name
436	}
437	} else {
438	# show other objects, but enable/disable them
439	lappend showing $name
440	if {$show} {
441	if {[winfo exists $vwidget]} {
442	$vwidget configure -state normal
443	}
444	if {[winfo exists $lwidget]} {
445	$lwidget configure -foreground \
446	[lindex [$lwidget configure -foreground] 3]
447	}
448	} else {
449	if {[winfo exists $vwidget]} {
450	$vwidget configure -state disabled
451	}
452	if {[winfo exists $lwidget]} {
453	$lwidget configure -foreground gray
454	}
455	}
456	}
457	} else {
458	bgerror "Error in <enable> expression for \"$_name2info($name-path)\":\n $show"
459	}
460	}
461
462	# store the showing tabs in the object so it can be used in _changeTabs
463	set _showing $showing
464
465	#
466	# Decide on a layout scheme:
467	# tabs ...... best if all elements within are groups
468	# hlabels ... horizontal labels (label: value)
469	#
470	if {[llength $showing] >= 2} {
471	# assume tabs for multiple groups
472	set _scheme tabs
473	foreach name $showing {
474	set w $_name2info($name-value)
475
476	if {$w == "--" \|\| [winfo class $w] != "GroupEntry"} {
477	# something other than a group? then fall back on hlabels
478	set _scheme hlabels
479	break
480	}
481	}
482	} else {
483	set _scheme hlabels
484	}
485
486	switch -- $_scheme {
487	tabs {
488	#
489	# SCHEME: tabs
490	# put a series of groups into a tabbed notebook
491	#
492
493	# use inner frame within tabs to show current group
494	pack $_tabs -before $_frame -fill x
495
496	set gn 1
497	foreach name $showing {
498	set wv $_name2info($name-value)
499	$wv configure -heading no
500
501	set label [$wv component heading cget -text]
502	if {"" == $label} {
503	set label "Group #$gn"
504	}
505	set _name2info($name-label) $label
506
507	$_tabs insert end $label
508	incr gn
509	}
510
511	# compute the overall size
512	# BE CAREFUL: do this after setting "-heading no" above
513	$_dispatcher event -now !resize
514
515	grid propagate $_frame off
516	grid columnconfigure $_frame 0 -weight 1
517	grid rowconfigure $_frame 0 -weight 1
518
519	_changeTabs 0
520	}
521
522	hlabels {
523	#
524	# SCHEME: hlabels
525	# simple "Label: Value" layout
526	#
527	pack forget $_tabs
528	grid propagate $_frame on
529	grid columnconfigure $_frame 0 -weight 0
530	grid rowconfigure $_frame 0 -weight 0
531
532	set expand 0 ;# most controls float to top
533	set row 0
534	foreach name $showing {
535	set wl $_name2info($name-label)
536	if {$wl != "" && [winfo exists $wl]} {
537	grid $wl -row $row -column 0 -sticky e
538	}
539
540	set wv $_name2info($name-value)
541	if {$wv != "" && [winfo exists $wv]} {
542	if {$wl != ""} {
543	grid $wv -row $row -column 1 -sticky ew
544	} else {
545	grid $wv -row $row -column 0 -columnspan 2 -sticky ew
546	}
547
548	grid rowconfigure $_frame $row -weight 0
549
550	switch -- [winfo class $wv] {
551	TextEntry {
552	if {[regexp {[0-9]+x[0-9]+} [$wv size]]} {
553	grid $wl -sticky n -pady 4
554	grid $wv -sticky nsew
555	grid rowconfigure $_frame $row -weight 1
556	grid columnconfigure $_frame 1 -weight 1
557	set expand 1
558	}
559	}
560	GroupEntry {
561	$wv configure -heading yes
562
563	#
564	# Scan through all children in this group
565	# and see if any demand more space. If the
566	# group contains a structure or a note, then
567	# make sure that the group itself is set to
568	# expand/fill.
569	#
570	set queue [winfo children $wv]
571	set expandgroup 0
572	while {[llength $queue] > 0} {
573	set w [lindex $queue 0]
574	set queue [lrange $queue 1 end]
575	set c [winfo class $w]
576	if {[lsearch {DeviceEditor Note} $c] >= 0} {
577	set expandgroup 1
578	break
579	}
580	eval lappend queue [winfo children $w]
581	}
582	if {$expandgroup} {
583	set expand 1
584	grid $wv -sticky nsew
585	grid rowconfigure $_frame $row -weight 1
586	}
587	}
588	Note {
589	grid $wv -sticky nsew
590	grid rowconfigure $_frame $row -weight 1
591	set expand 1
592	}
593	}
594	grid columnconfigure $_frame 1 -weight 1
595	} elseif {$wv == "--"} {
596	grid rowconfigure $_frame $row -minsize 10
597	}
598
599	incr row
600	grid rowconfigure $_frame $row -minsize $itk_option(-padding)
601	incr row
602	}
603	grid $_frame.empty -row $row
604
605	#
606	# If there are any hidden items, then make the bottom of
607	# this form fill up any extra space, so the form floats
608	# to the top. Otherwise, it will jitter around as the
609	# hidden items come and go.
610	#
611	if {[llength $hidden] > 0 && !$expand} {
612	grid rowconfigure $_frame 99 -weight 1
613	} else {
614	grid rowconfigure $_frame 99 -weight 0
615	}
616	}
617	}
618	}
619
620	# ----------------------------------------------------------------------
621	# USAGE: _monitor <name> <state>
622	#
623	# Used internally to add/remove bindings that cause the widget
624	# associated with <name> to notify this controls widget of size
625	# changes. Whenever there is a size change, this controls widget
626	# should fix its layout.
627	# ----------------------------------------------------------------------
628	itcl::body Rappture::Controls::_monitor {name state} {
629	set tag "Controls-$this"
630	set wv $_name2info($name-value)
631	if {$wv == "--" \|\| [catch {bindtags $wv} btags]} {
632	return
633	}
634	set i [lsearch $btags $tag]
635
636	if {$state} {
637	if {$i < 0} {
638	bindtags $wv [linsert $btags 0 $tag]
639	}
640	} else {
641	if {$i >= 0} {
642	bindtags $wv [lreplace $btags $i $i]
643	}
644	}
645	}
646
647	# ----------------------------------------------------------------------
648	# USAGE: _controlChanged <name>
649	#
650	# Invoked automatically whenever the value for a control changes.
651	# Sends a notification along to the tool controlling this panel.
652	# ----------------------------------------------------------------------
653	itcl::body Rappture::Controls::_controlChanged {name} {
654	set path $_name2info($name-path)
655
656	#
657	# Let the owner know that this control changed.
658	#
659	if {"" != $_owner} {
660	$_owner changed $path
661	}
662	}
663
664	# ----------------------------------------------------------------------
665	# USAGE: _controlValue <path> ?<units>?
666	#
667	# Used internally to get the value of a control with the specified
668	# <path>. Returns the current value for the control.
669	# ----------------------------------------------------------------------
670	itcl::body Rappture::Controls::_controlValue {path {units ""}} {
671	if {"" != $_owner} {
672	set val [$_owner valuefor $path]
673	if {"" != $units} {
674	set val [Rappture::Units::convert $val -to $units -units off]
675	}
676	return $val
677	}
678	return ""
679	}
680
681	# ----------------------------------------------------------------------
682	# USAGE: _formatLabel <string>
683	#
684	# Used internally to format a label <string>. Trims any excess
685	# white space and adds a ":" to the end. That way, all labels
686	# have a uniform look.
687	# ----------------------------------------------------------------------
688	itcl::body Rappture::Controls::_formatLabel {str} {
689	set str [string trim $str]
690	if {"" != $str && [string index $str end] != ":"} {
691	append str ":"
692	}
693	return $str
694	}
695
696	# ----------------------------------------------------------------------
697	# USAGE: _changeTabs
698	#
699	# Used internally to change tabs when the user clicks on a tab
700	# in the "tabs" layout mode. This mode is used when the widget
701	# contains nothing but groups, as a compact way of representing
702	# the groups.
703	# ----------------------------------------------------------------------
704	itcl::body Rappture::Controls::_changeTabs { index } {
705	if { $index == -1 } {
706	set index [$_tabs index select]
707	}
708	# we use _showing here instead of _controls because sometimes tabs
709	# are disabled, and the index of the choosen tab always matches
710	# _showing, even if tabs are disabled.
711	set name [lindex $_showing $index]
712	if {"" != $name} {
713	foreach w [grid slaves $_frame] {
714	grid forget $w
715	}
716
717	set wv $_name2info($name-value)
718	grid $wv -row 0 -column 0 -sticky new
719	}
720	}
721
722	# ----------------------------------------------------------------------
723	# USAGE: _resize
724	#
725	# Used internally to resize the widget when its contents change.
726	# ----------------------------------------------------------------------
727	itcl::body Rappture::Controls::_resize {} {
728	switch -- $_scheme {
729	tabs {
730	# compute the overall size
731	# BE CAREFUL: do this after setting "-heading no" above
732	set maxw 0
733	set maxh 0
734	update idletasks
735	foreach name $_controls {
736	set wv $_name2info($name-value)
737	set w [winfo reqwidth $wv]
738	if {$w > $maxw} { set maxw $w }
739	set h [winfo reqheight $wv]
740	if {$h > $maxh} { set maxh $h }
741	}
742	$_frame configure -width $maxw -height $maxh
743	}
744	hlabels {
745	# do nothing
746	}
747	}
748	}
749
750	# ----------------------------------------------------------------------
751	# OPTION: -padding
752	# ----------------------------------------------------------------------
753	itcl::configbody Rappture::Controls::padding {
754	$_dispatcher event -idle !layout
755	}

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

Download in other formats: