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

Last change on this file since 2417 was 2175, checked in by gah, 13 years ago

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