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

Last change on this file since 742 was 676, checked in by mmc, 17 years ago

Fixed all fonts to set pixelsize instead of pointsize, so that fonts in
the latest X distribution look right.

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