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

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

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