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

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

Fixed the layout of groups/notes so that largest elements on the page
expand properly.

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