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

Last change on this file since 120 was 120, checked in by mmc, 19 years ago
  • Fixed the Controls widget to resize itself properly the controls within it change size. This allows you to put a <structure> in a <group> and have it resize properly as new structures are loaded.
  • Fixed the loader to label unnamed files properly as "Example #1", "Example #2", etc.
File size: 17.4 KB
RevLine 
[11]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
[115]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.
[11]13# ======================================================================
14package require Itk
[26]15package require BLT
[11]16
17option add *Controls.padding 4 widgetDefault
18option add *Controls.labelFont \
19    -*-helvetica-medium-r-normal-*-*-120-* widgetDefault
20
21itcl::class Rappture::Controls {
22    inherit itk::Widget
23
24    itk_option define -padding padding Padding 0
25
[13]26    constructor {owner args} { # defined below }
[11]27
[22]28    public method insert {pos path}
[11]29    public method delete {first {last ""}}
30    public method index {name}
31    public method control {args}
32
33    protected method _layout {}
[120]34    protected method _monitor {name state}
[11]35    protected method _controlChanged {path}
36    protected method _formatLabel {str}
[26]37    protected method _changeTabs {}
[120]38    protected method _resize {}
[11]39
[13]40    private variable _owner ""       ;# controls belong to this owner
[26]41    private variable _tabs ""        ;# optional tabset for groups
42    private variable _frame ""       ;# pack controls into this frame
[11]43    private variable _counter 0      ;# counter for control names
44    private variable _dispatcher ""  ;# dispatcher for !events
45    private variable _controls ""    ;# list of known controls
46    private variable _name2info      ;# maps control name => info
[120]47    private variable _scheme ""      ;# layout scheme (tabs/hlabels)
[11]48}
49                                                                               
50itk::usual Controls {
51}
52
53# ----------------------------------------------------------------------
54# CONSTRUCTOR
55# ----------------------------------------------------------------------
[13]56itcl::body Rappture::Controls::constructor {owner args} {
[11]57    Rappture::dispatcher _dispatcher
58    $_dispatcher register !layout
59    $_dispatcher dispatch $this !layout "[itcl::code $this _layout]; list"
[120]60    $_dispatcher register !resize
61    $_dispatcher dispatch $this !resize "[itcl::code $this _resize]; list"
[11]62
[13]63    set _owner $owner
[11]64
[26]65    Rappture::Scroller $itk_interior.sc -xscrollmode none -yscrollmode auto
66    pack $itk_interior.sc -expand yes -fill both
67    set f [$itk_interior.sc contents frame]
68
69    set _tabs [blt::tabset $f.tabs -borderwidth 0 -relief flat \
70        -side top -tearoff 0 -highlightthickness 0 \
71        -selectbackground $itk_option(-background) \
72        -selectcommand [itcl::code $this _changeTabs]]
73
74    set _frame [frame $f.inner]
75    pack $_frame -expand yes -fill both
76
[74]77    #
78    # Put this frame in whenever the control frame is empty.
79    # It forces the size to contract back now when controls are deleted.
80    #
81    frame $_frame.empty -width 1 -height 1
82
[120]83    #
84    # Set up a binding that all inserted widgets will use so that
85    # we can monitor their size changes.
86    #
87    bind Controls-$this <Configure> \
88        [list $_dispatcher event -idle !resize]
89
[11]90    eval itk_initialize $args
91}
92
93# ----------------------------------------------------------------------
[22]94# USAGE: insert <pos> <path>
[11]95#
96# Clients use this to insert a control into this panel.  The control
97# is inserted into the list at position <pos>, which can be an integer
98# starting from 0 or the keyword "end".  Information about the control
[22]99# is taken from the specified <path>.
[11]100#
101# Returns a name that can be used to identify the control in other
102# methods.
103# ----------------------------------------------------------------------
[22]104itcl::body Rappture::Controls::insert {pos path} {
[11]105    if {"end" == $pos} {
106        set pos [llength $_controls]
107    } elseif {![string is integer $pos]} {
108        error "bad index \"$pos\": should be integer or \"end\""
109    }
110
111    incr _counter
112    set name "control$_counter"
113
114    set _name2info($name-path) $path
115    set _name2info($name-label) ""
[26]116    set _name2info($name-value) [set w $_frame.v$name]
[11]117
[22]118    set type [$_owner xml element -as type $path]
[11]119    switch -- $type {
120        choice {
[22]121            Rappture::ChoiceEntry $w $_owner $path
[11]122            bind $w <<Value>> [itcl::code $this _controlChanged $path]
123        }
124        group {
[22]125            Rappture::GroupEntry $w $_owner $path
[11]126        }
127        loader {
[22]128            Rappture::Loader $w $_owner $path -tool [$_owner tool]
[11]129            bind $w <<Value>> [itcl::code $this _controlChanged $path]
130        }
131        number {
[22]132            Rappture::NumberEntry $w $_owner $path
[11]133            bind $w <<Value>> [itcl::code $this _controlChanged $path]
134        }
[22]135        integer {
136            Rappture::IntegerEntry $w $_owner $path
137            bind $w <<Value>> [itcl::code $this _controlChanged $path]
138        }
[13]139        boolean {
[22]140            Rappture::BooleanEntry $w $_owner $path
[13]141            bind $w <<Value>> [itcl::code $this _controlChanged $path]
142        }
[11]143        string {
[22]144            Rappture::TextEntry $w $_owner $path
[11]145            bind $w <<Value>> [itcl::code $this _controlChanged $path]
146        }
[22]147        control {
148            set label [$_owner xml get $path.label]
149            if {"" == $label} { set label "Simulate" }
150            set service [$_owner xml get $path.service]
151            button $w -text $label -command [list $service run]
152        }
[69]153        separator {
154            # no widget to create
155            set _name2info($name-value) "--"
156        }
[11]157        default {
158            error "don't know how to add control type \"$type\""
159        }
160    }
161
[111]162    if {$type != "control" && $type != "group" && $type != "separator"} {
[22]163        $_owner widgetfor $path $w
[11]164
[22]165        # make a label for this control
166        set label [$w label]
167        if {"" != $label} {
[26]168            set _name2info($name-label) $_frame.l$name
[22]169            set font [option get $itk_component(hull) labelFont Font]
170            label $_name2info($name-label) -text [_formatLabel $label] \
171                -font $font
172        }
[11]173
[22]174        # register the tooltip for this control
175        set tip [$w tooltip]
176        if {"" != $tip} {
177            Rappture::Tooltip::for $w $tip
178
179            # add the tooltip to the label too, if there is one
180            if {$_name2info($name-label) != ""} {
181                Rappture::Tooltip::for $_name2info($name-label) $tip
182            }
[11]183        }
184    }
185
186    # insert the new control onto the known list
187    set _controls [linsert $_controls $pos $name]
[120]188    _monitor $name on
[11]189
190    # now that we have a new control, we should fix the layout
191    $_dispatcher event -idle !layout
192
193    return $name
194}
195
196# ----------------------------------------------------------------------
197# USAGE: delete <first> ?<last>?
198#
199# Clients use this to delete one or more controls from this widget.
200# The <first> and <last> represent the integer index of the desired
201# control.  You can use the "index" method to convert a control name to
202# its integer index.  If only <first> is specified, then that one
203# control is deleted.  If <last> is specified, then all controls in the
204# range <first> to <last> are deleted.
205# ----------------------------------------------------------------------
206itcl::body Rappture::Controls::delete {first {last ""}} {
207    if {$last == ""} {
208        set last $first
209    }
210    if {![regexp {^[0-9]+|end$} $first]} {
211        error "bad index \"$first\": should be integer or \"end\""
212    }
213    if {![regexp {^[0-9]+|end$} $last]} {
214        error "bad index \"$last\": should be integer or \"end\""
215    }
216
217    foreach name [lrange $_controls $first $last] {
[120]218        _monitor $name off
219
[11]220        if {"" != $_name2info($name-label)} {
221            destroy $_name2info($name-label)
222        }
223        if {"" != $_name2info($name-value)} {
224            destroy $_name2info($name-value)
225        }
[23]226        $_owner widgetfor $_name2info($name-path) ""
227
[11]228        unset _name2info($name-path)
229        unset _name2info($name-label)
230        unset _name2info($name-value)
231    }
232    set _controls [lreplace $_controls $first $last]
233
234    $_dispatcher event -idle !layout
235}
236
237# ----------------------------------------------------------------------
238# USAGE: index <name>|@n
239#
240# Clients use this to convert a control <name> into its corresponding
241# integer index.  Returns an error if the <name> is not recognized.
242# ----------------------------------------------------------------------
243itcl::body Rappture::Controls::index {name} {
244    set i [lsearch $_controls $name]
245    if {$i >= 0} {
246        return $i
247    }
248    if {[regexp {^@([0-9]+)$} $name match i]} {
249        return $i
250    }
251    error "bad control name \"$name\": should be @int or one of [join [lsort $_controls] {, }]"
252}
253
254# ----------------------------------------------------------------------
[22]255# USAGE: control ?-label|-value|-path? ?<name>|@n?
[11]256#
257# Clients use this to get information about controls.  With no args, it
258# returns a list of all control names.  Otherwise, it returns the frame
259# associated with a control name.  The -label option requests the label
[22]260# widget instead of the value widget.  The -path option requests the
261# path within the XML that the control affects.
[11]262# ----------------------------------------------------------------------
263itcl::body Rappture::Controls::control {args} {
264    if {[llength $args] == 0} {
265        return $_controls
266    }
267    Rappture::getopts args params {
268        flag switch -value default
269        flag switch -label
270        flag switch -path
271    }
272    if {[llength $args] == 0} {
273        error "missing control name"
274    }
275    set i [index [lindex $args 0]]
276    set name [lindex $_controls $i]
277
278    set opt $params(switch)
279    return $_name2info($name$opt)
280}
281
282# ----------------------------------------------------------------------
283# USAGE: _layout
284#
285# Used internally to fix the layout of controls whenever controls
286# are added or deleted, or when the control arrangement changes.
287# There are a lot of heuristics here trying to achieve a "good"
288# arrangement of controls.
289# ----------------------------------------------------------------------
290itcl::body Rappture::Controls::_layout {} {
291    #
292    # Clear any existing layout
293    #
294    foreach name $_controls {
295        foreach elem {label value} {
296            set w $_name2info($name-$elem)
297            if {$w != "" && [winfo exists $w]} {
298                grid forget $w
299            }
300        }
301    }
[26]302    if {[$_tabs size] > 0} {
303        $_tabs delete 0 end
304    }
[74]305    grid forget $_frame.empty
[11]306
307    #
[26]308    # Decide on a layout scheme:
309    #   tabs ...... best if all elements within are groups
310    #   hlabels ... horizontal labels (label: value)
[11]311    #
[26]312    if {[llength $_controls] >= 2} {
313        # assume tabs for multiple groups
[120]314        set _scheme tabs
[26]315        foreach name $_controls {
316            set w $_name2info($name-value)
317
[82]318            if {$w == "--" || [winfo class $w] != "GroupEntry"} {
[26]319                # something other than a group? then fall back on hlabels
[120]320                set _scheme hlabels
[26]321                break
322            }
[11]323        }
[26]324    } else {
[120]325        set _scheme hlabels
[26]326    }
[11]327
[120]328    switch -- $_scheme {
[26]329      tabs {
330        #
331        # SCHEME: tabs
332        # put a series of groups into a tabbed notebook
333        #
[11]334
[26]335        # use inner frame within tabs to show current group
336        pack $_tabs -before $_frame -fill x
[11]337
[26]338        set gn 1
339        foreach name $_controls {
340            set wv $_name2info($name-value)
341            $wv configure -heading no
342
343            set label [$wv component heading cget -text]
344            if {"" == $label} {
345                set label "Group #$gn"
346            }
347            set _name2info($name-label) $label
348
349            $_tabs insert end $label \
350                -activebackground $itk_option(-background)
351
352            incr gn
353        }
354
355        # compute the overall size
356        # BE CAREFUL: do this after setting "-heading no" above
[120]357        $_dispatcher event -now !resize
[26]358
359        grid propagate $_frame off
360        grid columnconfigure $_frame 0 -weight 1
361        grid rowconfigure $_frame 0 -weight 1
362
363        $_tabs select 0; _changeTabs
364      }
365
366      hlabels {
367        #
368        # SCHEME: hlabels
369        # simple "Label: Value" layout
370        #
371        pack forget $_tabs
372        grid propagate $_frame on
373        grid columnconfigure $_frame 0 -weight 0
374        grid rowconfigure $_frame 0 -weight 0
375
376        set row 0
377        foreach name $_controls {
378            set wl $_name2info($name-label)
379            if {$wl != "" && [winfo exists $wl]} {
380                grid $wl -row $row -column 0 -sticky e
381            }
382
383            set wv $_name2info($name-value)
384            if {$wv != "" && [winfo exists $wv]} {
385                if {$wl != ""} {
386                    grid $wv -row $row -column 1 -sticky ew
387                } else {
388                    grid $wv -row $row -column 0 -columnspan 2 -sticky ew
389                }
390
[82]391                grid rowconfigure $_frame $row -weight 0
392                grid rowconfigure $_frame $row -weight 0
[26]393
394                switch -- [winfo class $wv] {
395                    TextEntry {
396                        if {[regexp {[0-9]+x[0-9]+} [$wv size]]} {
397                            grid $wl -sticky n -pady 4
398                            grid $wv -sticky nsew
[82]399                            grid rowconfigure $_frame $row -weight 1
400                            grid columnconfigure $_frame 1 -weight 1
[26]401                        }
[11]402                    }
[26]403                    GroupEntry {
404                        $wv configure -heading yes
405                    }
[11]406                }
[82]407                grid columnconfigure $_frame 1 -weight 1
[69]408            } elseif {$wv == "--"} {
[82]409                grid rowconfigure $_frame $row -minsize 10
[11]410            }
411
[26]412            incr row
[82]413            grid rowconfigure $_frame $row -minsize $itk_option(-padding)
[26]414            incr row
415        }
[74]416        grid $_frame.empty -row $row
[26]417      }
[11]418    }
419}
420
421# ----------------------------------------------------------------------
[120]422# USAGE: _monitor <name> <state>
423#
424# Used internally to add/remove bindings that cause the widget
425# associated with <name> to notify this controls widget of size
426# changes.  Whenever there is a size change, this controls widget
427# should fix its layout.
428# ----------------------------------------------------------------------
429itcl::body Rappture::Controls::_monitor {name state} {
430    set tag "Controls-$this"
431    set wv $_name2info($name-value)
432    if {$wv == "--"} return
433    set btags [bindtags $wv]
434    set i [lsearch $btags $tag]
435
436    if {$state} {
437        if {$i < 0} {
438            bindtags $wv [linsert $btags 0 $tag]
439        }
440    } else {
441        if {$i >= 0} {
442            bindtags $wv [lreplace $btags $i $i]
443        }
444    }
445}
446
447# ----------------------------------------------------------------------
[11]448# USAGE: _controlChanged <path>
449#
450# Invoked automatically whenever the value for the control with the
451# XML <path> changes.  Sends a notification along to the tool
452# controlling this panel.
453# ----------------------------------------------------------------------
454itcl::body Rappture::Controls::_controlChanged {path} {
[13]455    if {"" != $_owner} {
456        $_owner changed $path
[11]457    }
458}
459
460# ----------------------------------------------------------------------
461# USAGE: _formatLabel <string>
462#
463# Used internally to format a label <string>.  Trims any excess
464# white space and adds a ":" to the end.  That way, all labels
465# have a uniform look.
466# ----------------------------------------------------------------------
467itcl::body Rappture::Controls::_formatLabel {str} {
468    set str [string trim $str]
469    if {"" != $str && [string index $str end] != ":"} {
470        append str ":"
471    }
472    return $str
473}
474
475# ----------------------------------------------------------------------
[26]476# USAGE: _changeTabs
477#
478# Used internally to change tabs when the user clicks on a tab
479# in the "tabs" layout mode.  This mode is used when the widget
480# contains nothing but groups, as a compact way of representing
481# the groups.
482# ----------------------------------------------------------------------
483itcl::body Rappture::Controls::_changeTabs {} {
484    set i [$_tabs index select]
485    set name [lindex $_controls $i]
486    if {"" != $name} {
487        foreach w [grid slaves $_frame] {
488            grid forget $w
489        }
490
491        set wv $_name2info($name-value)
492        grid $wv -row 0 -column 0 -sticky new
493    }
494}
495
496# ----------------------------------------------------------------------
[120]497# USAGE: _resize
498#
499# Used internally to resize the widget when its contents change.
500# ----------------------------------------------------------------------
501itcl::body Rappture::Controls::_resize {} {
502    switch -- $_scheme {
503        tabs {
504            # compute the overall size
505            # BE CAREFUL: do this after setting "-heading no" above
506            set maxw 0
507            set maxh 0
508            update idletasks
509            foreach name $_controls {
510                set wv $_name2info($name-value)
511                set w [winfo reqwidth $wv]
512                if {$w > $maxw} { set maxw $w }
513                set h [winfo reqheight $wv]
514                if {$h > $maxh} { set maxh $h }
515            }
516            $_frame configure -width $maxw -height $maxh
517        }
518        hlabels {
519            # do nothing
520        }
521    }
522}
523
524# ----------------------------------------------------------------------
[11]525# OPTION: -padding
526# ----------------------------------------------------------------------
527itcl::configbody Rappture::Controls::padding {
528    $_dispatcher event -idle !layout
529}
Note: See TracBrowser for help on using the repository browser.