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

Last change on this file since 2159 was 2159, checked in by mmc, 13 years ago

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