Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

controls.tcl

Last change on this file was 6372, checked in by dkearney, 8 years ago
adding multichoice widget from the multichoice branch
File size: 33.6 KB

Line
1	# -- mode: tcl; indent-tabs-mode: nil --
2	# ----------------------------------------------------------------------
3	# COMPONENT: controls - a container for various Rappture controls
4	#
5	# This widget is a smart frame acting as a container for controls.
6	# Controls are added to this panel, and the panel itself decides
7	# how to arrange them given available space.
8	# ======================================================================
9	# AUTHOR: Michael McLennan, Purdue University
10	# Copyright (c) 2004-2012 HUBzero Foundation, LLC
11	#
12	# See the file "license.terms" for information on usage and
13	# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14	# ======================================================================
15	package require Itk
16	package require BLT
17
18	option add *Controls.padding 4 widgetDefault
19	option add *Controls.labelFont \
20	--helvetica-medium-r-normal--12-* widgetDefault
21
22	itcl::class Rappture::Controls {
23	inherit itk::Widget
24
25	itk_option define -layout layout Layout ""
26	itk_option define -padding padding Padding 0
27
28	constructor {owner args} { # defined below }
29	destructor { # defined below }
30
31	public method insert {pos path}
32	public method delete {first {last ""}}
33	public method index {name}
34	public method control {args}
35	public method refresh {}
36
37	protected method _layout {}
38	protected method _monitor {name state}
39	protected method _controlChanged {name}
40	protected method _controlValue {path {units ""}}
41	protected method _formatLabel {str}
42	protected method _changeTabs {{why -program}}
43	protected method _resize {}
44
45	private variable _owner "" ;# controls belong to this owner
46	private variable _tabs "" ;# optional tabset for groups
47	private variable _frame "" ;# pack controls into this frame
48	private variable _counter 0 ;# counter for control names
49	private variable _dispatcher "" ;# dispatcher for !events
50	private variable _controls "" ;# list of known controls
51	private variable _showing "" ;# list of enabled (showing) controls
52	private variable _name2info ;# maps control name => info
53	private variable _scheme "" ;# layout scheme (tabs/vert/horz/sentence)
54	private variable _sentenceparts ;# info for layout scheme "sentence:"
55	}
56
57	itk::usual Controls {
58	}
59
60	# ----------------------------------------------------------------------
61	# CONSTRUCTOR
62	# ----------------------------------------------------------------------
63	itcl::body Rappture::Controls::constructor {owner args} {
64	Rappture::dispatcher _dispatcher
65	$_dispatcher register !layout
66	$_dispatcher dispatch $this !layout "[itcl::code $this _layout]; list"
67	$_dispatcher register !resize
68	$_dispatcher dispatch $this !resize "[itcl::code $this _resize]; list"
69
70	set _owner $owner
71
72	Rappture::Scroller $itk_interior.sc -xscrollmode none -yscrollmode auto
73	pack $itk_interior.sc -expand yes -fill both
74	set f [$itk_interior.sc contents frame]
75
76	set _tabs [blt::tabset $f.tabs -borderwidth 0 -relief flat \
77	-side top -tearoff 0 -samewidth 0 -highlightthickness 0 \
78	-selectbackground $itk_option(-background) \
79	-selectcommand [itcl::code $this _changeTabs -user]]
80	pack $_tabs -expand yes -fill both
81
82	set _frame [frame $_tabs.inner]
83	pack $_frame -expand yes -fill both
84
85	#
86	# Put this frame in whenever the control frame is empty.
87	# It forces the size to contract back now when controls are deleted.
88	#
89	frame $_frame.empty -width 1 -height 1
90
91	#
92	# Set up a binding that all inserted widgets will use so that
93	# we can monitor their size changes.
94	#
95	bind Controls-$this <Configure> \
96	[list $_dispatcher event -idle !resize]
97
98	eval itk_initialize $args
99	}
100
101	# ----------------------------------------------------------------------
102	# DESTRUCTOR
103	# ----------------------------------------------------------------------
104	itcl::body Rappture::Controls::destructor {} {
105	delete 0 end
106	}
107
108	# ----------------------------------------------------------------------
109	# USAGE: insert <pos> <path>
110	#
111	# Clients use this to insert a control into this panel. The control
112	# is inserted into the list at position <pos>, which can be an integer
113	# starting from 0 or the keyword "end". Information about the control
114	# is taken from the specified <path>.
115	#
116	# Returns a name that can be used to identify the control in other
117	# methods.
118	# ----------------------------------------------------------------------
119	itcl::body Rappture::Controls::insert {pos path} {
120	if {$pos ne "end" && ![string is integer $pos]} {
121	set pos [index $pos]
122	}
123
124	incr _counter
125	set name "control$_counter"
126	set path [$_owner xml element -as path $path]
127
128	set _name2info($name-path) $path
129	set _name2info($name-id) [$_owner xml element -as id $path]
130	set _name2info($name-label) ""
131	set _name2info($name-type) ""
132	set _name2info($name-value) [set w $_frame.v$name]
133	set _name2info($name-enable) "yes"
134	set _name2info($name-disablestyle) "greyout"
135
136	set type [$_owner xml element -as type $path]
137	set _name2info($name-type) $type
138	switch -- $type {
139	choice {
140	Rappture::ChoiceEntry $w $_owner $path
141	bind $w <<Value>> [itcl::code $this _controlChanged $name]
142	}
143	filechoice {
144	Rappture::FileChoiceEntry $w $_owner $path
145	bind $w <<Value>> [itcl::code $this _controlChanged $name]
146	}
147	filelist {
148	Rappture::FileListEntry $w $_owner $path
149	bind $w <<Value>> [itcl::code $this _controlChanged $name]
150	}
151	group {
152	Rappture::GroupEntry $w $_owner $path
153	}
154	loader {
155	Rappture::Loader $w $_owner $path -tool [$_owner tool]
156	bind $w <<Value>> [itcl::code $this _controlChanged $name]
157	}
158	multichoice {
159	Rappture::MultiChoiceEntry $w $_owner $path
160	bind $w <<Value>> [itcl::code $this _controlChanged $name]
161	}
162	number {
163	Rappture::NumberEntry $w $_owner $path
164	bind $w <<Value>> [itcl::code $this _controlChanged $name]
165	}
166	integer {
167	Rappture::IntegerEntry $w $_owner $path
168	bind $w <<Value>> [itcl::code $this _controlChanged $name]
169	}
170	boolean {
171	Rappture::BooleanEntry $w $_owner $path
172	bind $w <<Value>> [itcl::code $this _controlChanged $name]
173	}
174	string {
175	Rappture::TextEntry $w $_owner $path
176	bind $w <<Final>> [itcl::code $this _controlChanged $name]
177	}
178	drawing {
179	Rappture::DrawingEntry $w $_owner $path
180	}
181	map {
182	Rappture::MapEntry $w $_owner $path
183	}
184	image {
185	Rappture::ImageEntry $w $_owner $path
186	}
187	control {
188	set label [string trim [$_owner xml get $path.label]]
189	if {"" == $label} {
190	set label "Simulate"
191	}
192	set service [string trim [$_owner xml get $path.service]]
193	button $w -text $label -command [list $service run]
194	}
195	separator {
196	frame $w -class Separator -height 10
197	}
198	note {
199	Rappture::Note $w $_owner $path
200	}
201	periodicelement {
202	Rappture::PeriodicElementEntry $w $_owner $path
203	bind $w <<Value>> [itcl::code $this _controlChanged $name]
204	}
205	default {
206	error "don't know how to add control type \"$type\""
207	}
208	}
209
210	#
211	# If this element has an <enable> expression, then register
212	# its controlling widget here.
213	#
214	set disablestyle [string trim [$_owner xml get $path.about.disablestyle]]
215	if { $disablestyle != "" } {
216	set _name2info($name-disablestyle) $disablestyle
217	}
218	#
219	# If this element has an <enable> expression, then register
220	# its controlling widget here.
221	#
222	set enable [string trim [$_owner xml get $path.about.enable]]
223	if {"" == $enable} {
224	set enable yes
225	}
226	if {![string is boolean $enable]} {
227	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/]+)?}
228	set rest $enable
229	set enable ""
230	set deps ""
231	while {1} {
232	if {[regexp -indices $re $rest match]} {
233	foreach {s0 s1} $match break
234
235	if {[string index $rest [expr {$s0-1}]] == "\""} {
236	# string in ""'s? then leave it alone
237	append enable [string range $rest 0 [expr {$s0-1}]]
238	set rest [string range $rest $s0 end]
239	if {[regexp -indices {[^\"]+\"} $rest match]} {
240	foreach {s0 s1} $match break
241	append enable [string range $rest $s0 $s1]
242	set rest [string range $rest [expr {$s1+1}] end]
243	} else {
244	puts stderr "WARNING: mismatched quote in enable condition for $path"
245	puts stderr " expr: [string trim [$_owner xml get $path.about.enable]]"
246	set rest ""
247	}
248	} else {
249	#
250	# This is a symbol which should be substituted
251	# it can be either:
252	# input.foo.bar
253	# input.foo.bar:units
254	#
255	set cpath [string range $rest $s0 $s1]
256	set parts [split $cpath :]
257	set ccpath [lindex $parts 0]
258	set units [lindex $parts 1]
259
260	# make sure we have the standard path notation
261	set stdpath [$_owner regularize $ccpath]
262	if {"" == $stdpath} {
263	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."
264	set stdpath $ccpath
265	}
266	# substitute [_controlValue ...] call in place of path
267	append enable [string range $rest 0 [expr {$s0-1}]]
268	append enable [format {[_controlValue %s %s]} $stdpath $units]
269	lappend deps $stdpath
270	set rest [string range $rest [expr {$s1+1}] end]
271	}
272	} else {
273	append enable $rest
274	break
275	}
276	}
277
278	foreach cpath $deps {
279	$_owner dependenciesfor $cpath $path
280	}
281	}
282	set _name2info($name-enable) $enable
283	$_owner widgetfor $path $w
284
285	if {[lsearch {control group drawing map separator note} $type] < 0} {
286	# make a label for this control
287	set label [$w label]
288	if {$label ne ""} {
289	set _name2info($name-label) $_frame.l$name
290	set font [option get $itk_component(hull) labelFont Font]
291	label $_name2info($name-label) -text [_formatLabel $label] \
292	-font $font
293	}
294
295	# register the tooltip for this control
296	set tip [$w tooltip]
297	if {$tip ne ""} {
298	Rappture::Tooltip::for $w $tip -log $path
299
300	# add the tooltip to the label too, if there is one
301	if {$_name2info($name-label) ne ""} {
302	Rappture::Tooltip::for $_name2info($name-label) $tip -log $path
303	}
304	}
305	}
306
307	# insert the new control onto the known list
308	set _controls [linsert $_controls $pos $name]
309	_monitor $name on
310
311	# now that we have a new control, we should fix the layout
312	$_dispatcher event -idle !layout
313	_controlChanged $name
314
315	return $name
316	}
317
318	# ----------------------------------------------------------------------
319	# USAGE: delete <first> ?<last>?
320	#
321	# Clients use this to delete one or more controls from this widget.
322	# The <first> and <last> represent the integer index of the desired
323	# control. You can use the "index" method to convert a control name to
324	# its integer index. If only <first> is specified, then that one
325	# control is deleted. If <last> is specified, then all controls in the
326	# range <first> to <last> are deleted.
327	# ----------------------------------------------------------------------
328	itcl::body Rappture::Controls::delete {first {last ""}} {
329	if {$last == ""} {
330	set last $first
331	}
332	if {![string is integer $first]} {
333	set first [index $first]
334	}
335	if {![string is integer $last]} {
336	set last [index $last]
337	}
338
339	foreach name [lrange $_controls $first $last] {
340	_monitor $name off
341
342	if {"" != $_name2info($name-label)} {
343	destroy $_name2info($name-label)
344	}
345	if {"" != $_name2info($name-value)} {
346	destroy $_name2info($name-value)
347	}
348	$_owner widgetfor $_name2info($name-path) ""
349	array unset _name2info $name-*
350	}
351	set _controls [lreplace $_controls $first $last]
352
353	$_dispatcher event -idle !layout
354	}
355
356	# ----------------------------------------------------------------------
357	# USAGE: index <name>\|<path>\|@n\|end
358	#
359	# Clients use this to convert a control <name> into its corresponding
360	# integer index. Returns an error if the <name> is not recognized.
361	# ----------------------------------------------------------------------
362	itcl::body Rappture::Controls::index {val} {
363	set i [lsearch $_controls $val]
364	if {$i >= 0} {
365	return $i
366	}
367	if {[regexp {^@([0-9]+)$} $val match i]} {
368	return $i
369	}
370	if {$val eq "end"} {
371	return [expr {[llength $_controls]-1}]
372	}
373
374	# treat as a path name and search for this path
375	foreach name $_controls {
376	if {$_name2info($name-path) eq $val} {
377	set i [lsearch $_controls $name]
378	if {$i >= 0} {
379	return $i
380	}
381	}
382	}
383
384	error "bad control name \"$name\": should be @int or \"end\" or path name or one of [join [lsort $_controls] {, }]"
385	}
386
387	# ----------------------------------------------------------------------
388	# USAGE: control ?-label\|-value\|-path\|-enable? ?<name>\|@n?
389	#
390	# Clients use this to get information about controls. With no args, it
391	# returns a list of all control names. Otherwise, it returns the frame
392	# associated with a control name. The -label option requests the label
393	# widget instead of the value widget. The -path option requests the
394	# path within the XML that the control affects. The -enable option
395	# requests the enabling condition for this control.
396	# ----------------------------------------------------------------------
397	itcl::body Rappture::Controls::control {args} {
398	if {[llength $args] == 0} {
399	return $_controls
400	}
401	Rappture::getopts args params {
402	flag switch -value default
403	flag switch -label
404	flag switch -path
405	flag switch -enable
406	flag switch -disablestyle
407	}
408	if {[llength $args] == 0} {
409	error "missing control name"
410	}
411	set i [index [lindex $args 0]]
412	set name [lindex $_controls $i]
413
414	set opt $params(switch)
415	return $_name2info($name$opt)
416	}
417
418	# ----------------------------------------------------------------------
419	# USAGE: refresh
420	#
421	# Clients use this to refresh the layout of the control panel
422	# whenever a widget within the panel changes visibility state.
423	# ----------------------------------------------------------------------
424	itcl::body Rappture::Controls::refresh {} {
425	$_dispatcher event -idle !layout
426	}
427
428	# ----------------------------------------------------------------------
429	# USAGE: _layout
430	#
431	# Used internally to fix the layout of controls whenever controls
432	# are added or deleted, or when the control arrangement changes.
433	# There are a lot of heuristics here trying to achieve a "good"
434	# arrangement of controls.
435	# ----------------------------------------------------------------------
436	itcl::body Rappture::Controls::_layout {} {
437	#
438	# Clear any existing layout
439	#
440	foreach {rmax cmax} [grid size $_frame] break
441	for {set r 0} {$r < $rmax} {incr r} {
442	grid rowconfigure $_frame $r -weight 0 -minsize 0
443	}
444	grid rowconfigure $_frame 99 -weight 0
445
446	for {set c 0} {$c < $cmax} {incr c} {
447	grid columnconfigure $_frame $c -weight 0 -minsize 0
448	}
449
450	foreach name $_controls {
451	foreach elem {label value} {
452	set w $_name2info($name-$elem)
453	if {$w ne "" && [winfo exists $w]} {
454	grid forget $w
455	}
456	}
457	}
458	grid forget $_frame.empty
459
460	if {[$_tabs size] > 0} {
461	$_tabs delete 0 end
462	}
463
464	#
465	# Decide which widgets should be shown and which should be hidden.
466	#
467	set hidden ""
468	set showing ""
469	foreach name $_controls {
470	set show 1
471	set cond $_name2info($name-enable)
472	if {[string is boolean $cond] && !$cond} {
473	# hard-coded "off" -- ignore completely
474
475	# When the "enable" of a control is hardcoded "off", "0", etc., it
476	# means to hide the control. This is used by bandstrlab to add
477	# invisible parameters to a structure. The value of the parameter
478	# is used by other widgets with enable statements.
479
480	# The proper method for doing this is to add a
481	# <disablestyle>hide<disablestyle>
482	# tag to the about section of the control.
483
484	} elseif {[catch {expr $cond} show] == 0} {
485	set type $_name2info($name-type)
486	set disablestyle $_name2info($name-disablestyle)
487	set lwidget $_name2info($name-label)
488	set vwidget $_name2info($name-value)
489	if {[lsearch -exact {group image structure} $type] >= 0 \|\|
490	$disablestyle == "hide" } {
491	if {$show ne "" && $show} {
492	lappend showing $name
493	} else {
494	lappend hidden $name
495	}
496	} else {
497	# show other objects, but enable/disable them
498	lappend showing $name
499	if {$show ne "" && $show} {
500	catch {$vwidget configure -state normal}
501	if {[winfo exists $lwidget]} {
502	$lwidget configure -foreground \
503	[lindex [$lwidget configure -foreground] 3]
504	}
505	} else {
506	catch {$vwidget configure -state disabled}
507	if {[winfo exists $lwidget]} {
508	$lwidget configure -foreground gray
509	}
510	}
511	}
512	} else {
513	bgerror "Error in <enable> expression for \"$_name2info($name-path)\":\n $show"
514	}
515	}
516
517	# store the showing tabs in the object so it can be used in _changeTabs
518	set _showing $showing
519
520	#
521	# Decide on a layout scheme:
522	# default ...... tabs for groups of groups; vertical otherwise
523	# tabs ......... tabbed notebook
524	# vertical ..... "label: value" down in rows
525	# horizontal ... "label: value" across columns
526	# sentence ..... text with embedded widgets
527	#
528	set _scheme $itk_option(-layout)
529	if {$_scheme eq "" \|\| $_scheme eq "tabs"} {
530	if {[llength $showing] < 2} {
531	set _scheme "vertical"
532	} else {
533	set _scheme "tabs"
534	foreach name $showing {
535	set w $_name2info($name-value)
536	if {[winfo class $w] ne "GroupEntry"} {
537	# something other than a group? then fall back on vertical
538	set _scheme "vertical"
539	break
540	}
541	}
542	}
543	}
544
545	# if the layout is "sentence:..." then create new parts
546	if {[string match {sentence:*} $itk_option(-layout)]
547	&& [array size _sentenceparts] == 0} {
548	set n 0
549	set font [option get $itk_component(hull) labelFont Font]
550	set str [string range $itk_option(-layout) 9 end]
551	while {[regexp -indices {\$\{([a-zA-Z0-9_]+)\}} $str match name]} {
552	foreach {s0 s1} $name break
553	set name [string range $str $s0 $s1]
554
555	# create a label for the string before the substitution
556	foreach {s0 s1} $match break
557	set prefix [string trim [string range $str 0 [expr {$s0-1}]]]
558	if {$prefix ne ""} {
559	set lname $_frame.sentence[incr n]
560	label $lname -text $prefix -font $font
561	lappend _sentenceparts(all) $lname
562	lappend _sentenceparts(fragments) $lname
563	}
564
565	# add the widget for the substitution part
566	set found ""
567	foreach c $_controls {
568	if {$_name2info($c-id) eq $name} {
569	set found $c
570	break
571	}
572	}
573	if {$found ne ""} {
574	lappend _sentenceparts(all) $_name2info($found-value)
575	} else {
576	puts stderr "WARNING: name \"$name\" in sentence layout \"$itk_option(-layout)\" not recognized"
577	}
578
579	set str [string range $str [expr {$s1+1}] end]
580	}
581
582	# create a label for any trailing string
583	set str [string trim $str]
584	if {$str ne ""} {
585	set lname $_frame.sentence[incr n]
586	label $lname -text $str -font $font
587	lappend _sentenceparts(all) $lname
588	lappend _sentenceparts(fragments) $lname
589	}
590	}
591
592	switch -glob -- $_scheme {
593	tabs {
594	#
595	# SCHEME: tabs
596	# put a series of groups into a tabbed notebook
597	#
598
599	# stop covering up the tabset and put the _frame inside the tabs
600	pack forget $_frame
601	$_tabs configure -width 0 -height 0
602
603	set gn 1
604	foreach name $showing {
605	set wv $_name2info($name-value)
606	$wv configure -heading no
607	set label [$wv component heading cget -text]
608	if {"" == $label} {
609	set label "Group #$gn"
610	}
611	set _name2info($name-label) $label
612	$_tabs insert end $name -text $label \
613	-activebackground $itk_option(-background) \
614	-window $_frame -fill both
615	incr gn
616	}
617
618	# compute the overall size
619	# BE CAREFUL: do this after setting "-heading no" above
620	$_dispatcher event -now !resize
621
622	grid columnconfigure $_frame 0 -weight 1
623	grid rowconfigure $_frame 0 -weight 1
624
625	$_tabs select 0; _changeTabs
626	}
627
628	vertical {
629	#
630	# SCHEME: vertical
631	# simple "Label: Value" layout
632	#
633	if {[$_tabs size] > 0} {
634	$_tabs delete 0 end
635	}
636	pack $_frame -expand yes -fill both
637	$_tabs configure -width [winfo reqwidth $_frame] \
638	-height [winfo reqheight $_frame]
639
640	set expand 0 ;# most controls float to top
641	set row 0
642	foreach name $showing {
643	set wl $_name2info($name-label)
644	if {$wl != "" && [winfo exists $wl]} {
645	grid $wl -row $row -column 0 -sticky e
646	}
647
648	set wv $_name2info($name-value)
649	if {$wv ne "" && [winfo exists $wv]} {
650	if {$wl != ""} {
651	grid $wv -row $row -column 1 -sticky ew
652	} else {
653	grid $wv -row $row -column 0 -columnspan 2 -sticky ew
654	}
655
656	grid rowconfigure $_frame $row -weight 0
657
658	switch -- [winfo class $wv] {
659	TextEntry {
660	if {[regexp {[0-9]+x[0-9]+} [$wv size]]} {
661	grid $wl -sticky ne -pady 4
662	grid $wv -sticky nsew
663	grid rowconfigure $_frame $row -weight 1
664	grid columnconfigure $_frame 1 -weight 1
665	set expand 1
666	}
667	}
668	GroupEntry {
669	$wv configure -heading yes
670
671	#
672	# Scan through all children in this group
673	# and see if any demand more space. If the
674	# group contains a structure or a note, then
675	# make sure that the group itself is set to
676	# expand/fill.
677	#
678	set queue [winfo children $wv]
679	set expandgroup 0
680	while {[llength $queue] > 0} {
681	set w [lindex $queue 0]
682	set queue [lrange $queue 1 end]
683	set c [winfo class $w]
684	if {[lsearch {DeviceEditor Note} $c] >= 0} {
685	set expandgroup 1
686	break
687	}
688	eval lappend queue [winfo children $w]
689	}
690	if {$expandgroup} {
691	set expand 1
692	grid $wv -sticky nsew
693	grid rowconfigure $_frame $row -weight 1
694	}
695	}
696	Note {
697	grid $wv -sticky nsew
698	grid rowconfigure $_frame $row -weight 1
699	set expand 1
700	}
701	}
702	grid columnconfigure $_frame 1 -weight 1
703	}
704
705	incr row
706	grid rowconfigure $_frame $row -minsize $itk_option(-padding)
707	incr row
708	}
709	grid $_frame.empty -row $row
710
711	#
712	# If there are any hidden items, then make the bottom of
713	# this form fill up any extra space, so the form floats
714	# to the top. Otherwise, it will jitter around as the
715	# hidden items come and go.
716	#
717	if {[llength $hidden] > 0 && !$expand} {
718	grid rowconfigure $_frame 99 -weight 1
719	} else {
720	grid rowconfigure $_frame 99 -weight 0
721	}
722	}
723
724	horizontal {
725	#
726	# SCHEME: horizontal
727	# lay out left to right
728	#
729	if {[$_tabs size] > 0} {
730	$_tabs delete 0 end
731	}
732	pack $_frame -expand yes -fill both
733	$_tabs configure -width [winfo reqwidth $_frame] \
734	-height [winfo reqheight $_frame]
735
736	set col 0
737	set pad [expr {$itk_option(-padding)/2}]
738	foreach name $showing {
739	set wl $_name2info($name-label)
740	if {$wl != "" && [winfo exists $wl]} {
741	grid $wl -row 0 -column $col -sticky e -padx $pad
742	incr col
743	}
744
745	set wv $_name2info($name-value)
746	if {$wv != "" && [winfo exists $wv]} {
747	grid $wv -row 0 -column $col -sticky ew -padx $pad
748	grid columnconfigure $_frame $col -weight 0
749	incr col
750	}
751	}
752	}
753
754	sentence:* {
755	#
756	# SCHEME: sentence
757	# lay out left to right with sentence parts: "( [x] , [y] )"
758	#
759	if {[$_tabs size] > 0} {
760	$_tabs delete 0 end
761	}
762	pack $_frame -expand yes -fill both
763	$_tabs configure -width [winfo reqwidth $_frame] \
764	-height [winfo reqheight $_frame]
765
766	set col 0
767	set pad [expr {$itk_option(-padding)/2}]
768	foreach widget $_sentenceparts(all) {
769	grid $widget -row 0 -column $col -padx $pad
770	incr col
771	}
772	}
773	}
774	}
775
776	# ----------------------------------------------------------------------
777	# USAGE: _monitor <name> <state>
778	#
779	# Used internally to add/remove bindings that cause the widget
780	# associated with <name> to notify this controls widget of size
781	# changes. Whenever there is a size change, this controls widget
782	# should fix its layout.
783	# ----------------------------------------------------------------------
784	itcl::body Rappture::Controls::_monitor {name state} {
785	set tag "Controls-$this"
786	set wv $_name2info($name-value)
787	if {[catch {bindtags $wv} btags]} {
788	return
789	}
790	set i [lsearch $btags $tag]
791
792	if {$state} {
793	if {$i < 0} {
794	bindtags $wv [linsert $btags 0 $tag]
795	}
796	} else {
797	if {$i >= 0} {
798	bindtags $wv [lreplace $btags $i $i]
799	}
800	}
801	}
802
803	# ----------------------------------------------------------------------
804	# USAGE: _controlChanged <name>
805	#
806	# Invoked automatically whenever the value for a control changes.
807	# Sends a notification along to the tool controlling this panel.
808	# ----------------------------------------------------------------------
809	itcl::body Rappture::Controls::_controlChanged {name} {
810	set path $_name2info($name-path)
811
812	#
813	# Let the owner know that this control changed.
814	#
815	if {"" != $_owner} {
816	$_owner changed $path
817	}
818	}
819
820	# ----------------------------------------------------------------------
821	# USAGE: _controlValue <path> ?<units>?
822	#
823	# Used internally to get the value of a control with the specified
824	# <path>. Returns the current value for the control.
825	# ----------------------------------------------------------------------
826	itcl::body Rappture::Controls::_controlValue {path {units ""}} {
827	if {"" != $_owner} {
828	set val [$_owner valuefor $path]
829	if {"" != $units} {
830	set val [Rappture::Units::convert $val -to $units -units off]
831	}
832	return $val
833	}
834	return ""
835	}
836
837	# ----------------------------------------------------------------------
838	# USAGE: _formatLabel <string>
839	#
840	# Used internally to format a label <string>. Trims any excess
841	# white space and adds a ":" to the end. That way, all labels
842	# have a uniform look.
843	# ----------------------------------------------------------------------
844	itcl::body Rappture::Controls::_formatLabel {str} {
845	set str [string trim $str]
846	if {"" != $str && [string index $str end] != ":"} {
847	append str ":"
848	}
849	return $str
850	}
851
852	# ----------------------------------------------------------------------
853	# USAGE: _changeTabs ?-user\|-program?
854	#
855	# Used internally to change tabs when the user clicks on a tab
856	# in the "tabs" layout mode. This mode is used when the widget
857	# contains nothing but groups, as a compact way of representing
858	# the groups.
859	# ----------------------------------------------------------------------
860	itcl::body Rappture::Controls::_changeTabs {{why -program}} {
861	set i [$_tabs index select]
862	# we use _showing here instead of _controls because sometimes tabs
863	# are disabled, and the index of the choosen tab always matches
864	# _showing, even if tabs are disabled.
865	set name [lindex $_showing $i]
866	if {$name ne ""} {
867	foreach w [grid slaves $_frame] {
868	grid forget $w
869	}
870
871	set wv $_name2info($name-value)
872	grid $wv -row 0 -column 0 -sticky nsew
873
874	$_tabs tab configure [$_tabs get $i] -window $_frame
875
876	if {$why eq "-user"} {
877	Rappture::Logger::log group $_name2info($name-path)
878	}
879	}
880	}
881
882	# ----------------------------------------------------------------------
883	# USAGE: _resize
884	#
885	# Used internally to resize the widget when its contents change.
886	# ----------------------------------------------------------------------
887	itcl::body Rappture::Controls::_resize {} {
888	switch -glob -- $_scheme {
889	tabs {
890	# in "tabs" mode, the overall size is the largest for all pages
891	set maxw 0
892	set maxh 0
893	update idletasks
894	foreach name $_controls {
895	set wv $_name2info($name-value)
896	set w [winfo reqwidth $wv]
897	if {$w > $maxw} { set maxw $w }
898	set h [winfo reqheight $wv]
899	if {$h > $maxh} { set maxh $h }
900	}
901
902	# Turn off propagation temporarily so that we don't keep
903	# recursing back into this routine when we change the frame's
904	# dimensions below.
905	grid propagate $_frame no
906
907	$_frame configure -width $maxw -height $maxh
908
909	# Turn progagation back on so that the parent widget recognizes
910	# when the widget changes size or is unpacked.
911	grid propagate $_frame yes
912	}
913	vertical - horizontal - sentence* {
914	# in other modes, just use normal size propagation
915	grid propagate $_frame yes
916	}
917	default {
918	error "bad layout scheme \"$_scheme\""
919	}
920	}
921	}
922
923	# ----------------------------------------------------------------------
924	# OPTION: -padding
925	# ----------------------------------------------------------------------
926	itcl::configbody Rappture::Controls::padding {
927	$_dispatcher event -idle !layout
928	}
929
930	# ----------------------------------------------------------------------
931	# OPTION: -layout
932	# ----------------------------------------------------------------------
933	itcl::configbody Rappture::Controls::layout {
934	# clear any existing sentence parts
935	if {[array size _sentenceparts] > 0} {
936	foreach part $_sentenceparts(fragments) {
937	destroy $part
938	}
939	catch {unset _sentenceparts}
940	}
941
942	if {![regexp {^(\|horizontal\|vertical\|tabs\|sentence:.+)$} $itk_option(-layout)]} {
943	puts "ERROR: bad layout option \"$itk_option(-layout)\" -- should be horizontal, vertical, tabs or sentence:..."
944	set itk_option(-layout) ""
945	}
946
947	# recompute the layout at some point
948	$_dispatcher event -idle !layout
949	}

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

Context Navigation

source: trunk/gui/scripts/controls.tcl

Download in other formats: