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

Last change on this file since 1216 was 1216, checked in by dkearney, 11 years ago

adding fix to controls.tcl to properly display all enabled tabs when some of the available tabs are disabled. this fix helps allow photonicsdb to dynamically display inputs for layers of materials while keeping the first and last tabs always enabled.

also included is an example which displays the bad behavior in previous versions of rappture as part of the buggy_xml series.

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