Context Navigation

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

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

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

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

Download in other formats: