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

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

Fixed a bug in syncing values within device editors embedded within
control panels. The "Simulate" button wasn't highlighting properly
when a value was changed.

Fixed a problem with enable/disable and separator objects.
File size: 23.7 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                    if {[winfo exists $vwidget]} {
425                        $vwidget configure -state normal
426                    }
427                    if {[winfo exists $lwidget]} {
428                        $lwidget configure -foreground \
429                            [lindex [$lwidget configure -foreground] 3]
430                    }
431                } else {
432                    if {[winfo exists $vwidget]} {
433                        $vwidget configure -state disabled
434                    }
435                    if {[winfo exists $lwidget]} {
436                        $lwidget configure -foreground gray
437                    }
438                }
439            }
440        } else {
441            bgerror "Error in <enable> expression for \"$_name2info($name-path)\":\n  $show"
442        }
443    }
444
445    #
446    # Decide on a layout scheme:
447    #   tabs ...... best if all elements within are groups
448    #   hlabels ... horizontal labels (label: value)
449    #
450    if {[llength $showing] >= 2} {
451        # assume tabs for multiple groups
452        set _scheme tabs
453        foreach name $showing {
454            set w $_name2info($name-value)
455
456            if {$w == "--" || [winfo class $w] != "GroupEntry"} {
457                # something other than a group? then fall back on hlabels
458                set _scheme hlabels
459                break
460            }
461        }
462    } else {
463        set _scheme hlabels
464    }
465
466    switch -- $_scheme {
467      tabs {
468        #
469        # SCHEME: tabs
470        # put a series of groups into a tabbed notebook
471        #
472
473        # use inner frame within tabs to show current group
474        pack $_tabs -before $_frame -fill x
475
476        set gn 1
477        foreach name $showing {
478            set wv $_name2info($name-value)
479            $wv configure -heading no
480
481            set label [$wv component heading cget -text]
482            if {"" == $label} {
483                set label "Group #$gn"
484            }
485            set _name2info($name-label) $label
486
487            $_tabs insert end $label \
488                -activebackground $itk_option(-background)
489
490            incr gn
491        }
492
493        # compute the overall size
494        # BE CAREFUL: do this after setting "-heading no" above
495        $_dispatcher event -now !resize
496
497        grid propagate $_frame off
498        grid columnconfigure $_frame 0 -weight 1
499        grid rowconfigure $_frame 0 -weight 1
500
501        $_tabs select 0; _changeTabs
502      }
503
504      hlabels {
505        #
506        # SCHEME: hlabels
507        # simple "Label: Value" layout
508        #
509        pack forget $_tabs
510        grid propagate $_frame on
511        grid columnconfigure $_frame 0 -weight 0
512        grid rowconfigure $_frame 0 -weight 0
513
514        set row 0
515        foreach name $showing {
516            set wl $_name2info($name-label)
517            if {$wl != "" && [winfo exists $wl]} {
518                grid $wl -row $row -column 0 -sticky e
519            }
520
521            set wv $_name2info($name-value)
522            if {$wv != "" && [winfo exists $wv]} {
523                if {$wl != ""} {
524                    grid $wv -row $row -column 1 -sticky ew
525                } else {
526                    grid $wv -row $row -column 0 -columnspan 2 -sticky ew
527                }
528
529                grid rowconfigure $_frame $row -weight 0
530                grid rowconfigure $_frame $row -weight 0
531
532                switch -- [winfo class $wv] {
533                    TextEntry {
534                        if {[regexp {[0-9]+x[0-9]+} [$wv size]]} {
535                            grid $wl -sticky n -pady 4
536                            grid $wv -sticky nsew
537                            grid rowconfigure $_frame $row -weight 1
538                            grid columnconfigure $_frame 1 -weight 1
539                        }
540                    }
541                    GroupEntry {
542                        $wv configure -heading yes
543                    }
544                }
545                grid columnconfigure $_frame 1 -weight 1
546            } elseif {$wv == "--"} {
547                grid rowconfigure $_frame $row -minsize 10
548            }
549
550            incr row
551            grid rowconfigure $_frame $row -minsize $itk_option(-padding)
552            incr row
553        }
554        grid $_frame.empty -row $row
555
556        #
557        # If there are any hidden items, then make the bottom of
558        # this form fill up any extra space, so the form floats
559        # to the top.  Otherwise, it will jitter around as the
560        # hidden items come and go.
561        #
562        if {[llength $hidden] > 0} {
563            grid rowconfigure $_frame 99 -weight 1
564        } else {
565            grid rowconfigure $_frame 99 -weight 0
566        }
567      }
568    }
569}
570
571# ----------------------------------------------------------------------
572# USAGE: _monitor <name> <state>
573#
574# Used internally to add/remove bindings that cause the widget
575# associated with <name> to notify this controls widget of size
576# changes.  Whenever there is a size change, this controls widget
577# should fix its layout.
578# ----------------------------------------------------------------------
579itcl::body Rappture::Controls::_monitor {name state} {
580    set tag "Controls-$this"
581    set wv $_name2info($name-value)
582    if {$wv == "--" || [catch {bindtags $wv} btags]} {
583        return
584    }
585    set i [lsearch $btags $tag]
586
587    if {$state} {
588        if {$i < 0} {
589            bindtags $wv [linsert $btags 0 $tag]
590        }
591    } else {
592        if {$i >= 0} {
593            bindtags $wv [lreplace $btags $i $i]
594        }
595    }
596}
597
598# ----------------------------------------------------------------------
599# USAGE: _controlChanged <name>
600#
601# Invoked automatically whenever the value for a control changes.
602# Sends a notification along to the tool controlling this panel.
603# ----------------------------------------------------------------------
604itcl::body Rappture::Controls::_controlChanged {name} {
605    set path $_name2info($name-path)
606
607    #
608    # Let the owner know that this control changed.
609    #
610    if {"" != $_owner} {
611        $_owner changed $path
612    }
613}
614
615# ----------------------------------------------------------------------
616# USAGE: _controlValue <path> ?<units>?
617#
618# Used internally to get the value of a control with the specified
619# <path>.  Returns the current value for the control.
620# ----------------------------------------------------------------------
621itcl::body Rappture::Controls::_controlValue {path {units ""}} {
622    if {"" != $_owner} {
623        set val [$_owner valuefor $path]
624        if {"" != $units} {
625            set val [Rappture::Units::convert $val -to $units -units off]
626        }
627        return $val
628    }
629    return ""
630}
631
632# ----------------------------------------------------------------------
633# USAGE: _formatLabel <string>
634#
635# Used internally to format a label <string>.  Trims any excess
636# white space and adds a ":" to the end.  That way, all labels
637# have a uniform look.
638# ----------------------------------------------------------------------
639itcl::body Rappture::Controls::_formatLabel {str} {
640    set str [string trim $str]
641    if {"" != $str && [string index $str end] != ":"} {
642        append str ":"
643    }
644    return $str
645}
646
647# ----------------------------------------------------------------------
648# USAGE: _changeTabs
649#
650# Used internally to change tabs when the user clicks on a tab
651# in the "tabs" layout mode.  This mode is used when the widget
652# contains nothing but groups, as a compact way of representing
653# the groups.
654# ----------------------------------------------------------------------
655itcl::body Rappture::Controls::_changeTabs {} {
656    set i [$_tabs index select]
657    set name [lindex $_controls $i]
658    if {"" != $name} {
659        foreach w [grid slaves $_frame] {
660            grid forget $w
661        }
662
663        set wv $_name2info($name-value)
664        grid $wv -row 0 -column 0 -sticky new
665    }
666}
667
668# ----------------------------------------------------------------------
669# USAGE: _resize
670#
671# Used internally to resize the widget when its contents change.
672# ----------------------------------------------------------------------
673itcl::body Rappture::Controls::_resize {} {
674    switch -- $_scheme {
675        tabs {
676            # compute the overall size
677            # BE CAREFUL: do this after setting "-heading no" above
678            set maxw 0
679            set maxh 0
680            update idletasks
681            foreach name $_controls {
682                set wv $_name2info($name-value)
683                set w [winfo reqwidth $wv]
684                if {$w > $maxw} { set maxw $w }
685                set h [winfo reqheight $wv]
686                if {$h > $maxh} { set maxh $h }
687            }
688            $_frame configure -width $maxw -height $maxh
689        }
690        hlabels {
691            # do nothing
692        }
693    }
694}
695
696# ----------------------------------------------------------------------
697# OPTION: -padding
698# ----------------------------------------------------------------------
699itcl::configbody Rappture::Controls::padding {
700    $_dispatcher event -idle !layout
701}
Note: See TracBrowser for help on using the repository browser.