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

Last change on this file since 438 was 438, checked in by mmc, 18 years ago

Fixed the <enable> facility so that it will work correctly even
when an <enable> statement references an element that is loaded
dynamically into a <structure> parameters section. The element
is not found at first, so Rappture prints out a warning message
to stderr. But when the element is loaded later, the <enable>
condition works as expected.

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