Context Navigation

controls.tcl @ 1268

Last change on this file since 1268 was 1268, checked in by dkearney, 16 years ago

moving the update call from controls to driver because it was messing with the structure example in zoo. structure example's image and parameters options were failing. now the gui is updated after the page has been created and packed. i wanted to put the update just before the deiconify call at the end of driver, but it looks like if you dont call update after the input pages are created, the loader behavior persists. this may have something to do with the 50ms wait time before the loader's value command is called.

File size: 25.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 {}
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.

Context Navigation

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

Download in other formats: