Context Navigation

controls.tcl @ 3642

Last change on this file since 3642 was 3642, checked in by mmc, 11 years ago

Fixes for nanoHUB ticket #258058 and #258045 -- note within a group tab
doesn't fill out the area properly. Should work better now. Also fixed
tabs to contain the window, instead of floating above the cotents as they
have for a long time.

Fixed boolean controls to have a more obvious on/off switch instead of a
checkbox. Fixed integers and spinners to use larger +/- buttons that are
easier to press on an iPad. Fixed numbers and other gauges to have the
same relief style as entries and other widgets.

Added new layout styles to groups: horizontal, vertical, tabs, and sentence.
You can now explicitly make a layout vertical instead of tabs by setting
the layout to "vertical" instead of throwing in a separator. Updated the
zoo/groups example to show off new horizontal and sentence types.

Fixed the "drawing" example in the zoo to gray out the trapezoid top when
it is disabled.

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

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

Context Navigation

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

Download in other formats: