source: branches/blt4/gui/scripts/controls.tcl @ 1923

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