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

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