Context Navigation

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

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

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

Download in other formats: