source: trunk/gui/scripts/drawingcontrols.tcl @ 3508

Last change on this file since 3508 was 3330, checked in by gah, 12 years ago

merge (by hand) with Rappture1.2 branch
File size: 17.4 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2
3# ----------------------------------------------------------------------
4#  COMPONENT: drawingcontrols - Print X-Y plot.
5#
6# ======================================================================
7#  AUTHOR:  Michael McLennan, Purdue University
8#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
9#
10#  See the file "license.terms" for information on usage and
11#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12# ======================================================================
13package require Itk
14package require BLT
15
16#option add *DrawingControls.width 3i widgetDefault
17#option add *DrawingControls.height 3i widgetDefault
18#option add *DrawingControls*Font "Arial 9" widgetDefault
19option add *DrawingControls.padding 4 widgetDefault
20option add *DrawingControls.labelFont \
21    -*-helvetica-medium-r-normal-*-12-* widgetDefault
22
23
24itcl::class Rappture::DrawingControls {
25    inherit itk::Widget
26
27    constructor {args} {}
28    destructor {}
29
30    itk_option define -padding padding Padding 0
31
32    public variable deactivatecommand ""
33
34    public method add { path }
35    public method delete { {name "all"} }
36
37    private method ControlChanged { name }
38    private method ControlValue {path {units ""}}
39    private method Rebuild {}
40    private method FormatLabel {str}
41    private method Monitor {name state}
42    private variable _dispatcher ""
43    private variable _controls ""
44    private variable _name2info
45    private variable _counter 0
46    private variable _owner ""
47    private variable _frame ""
48    private variable _closeOnChange 0
49}
50
51# ----------------------------------------------------------------------
52# CONSTRUCTOR
53# ----------------------------------------------------------------------
54itcl::body Rappture::DrawingControls::constructor { owner args } {
55    Rappture::dispatcher _dispatcher
56    $_dispatcher register !layout
57    $_dispatcher dispatch $this !layout "[itcl::code $this Rebuild]; list"
58   
59    set _owner $owner
60    set _frame $itk_interior.frame
61    frame $_frame
62    itk_component add cancel {
63        button $itk_interior.cancel -text "cancel" -command $deactivatecommand
64    }
65    itk_component add save {
66        button $itk_interior.save -text "save"  -command $deactivatecommand
67    }
68    #
69    # Put this frame in whenever the control frame is empty.
70    # It forces the size to contract back now when controls are deleted.
71    #
72    frame $_frame.empty -width 1 -height 1
73    blt::table $itk_interior \
74        0,0 $_frame -fill both -cspan 2
75
76    eval itk_initialize $args
77}
78
79# ----------------------------------------------------------------------
80# DESTRUCTOR
81# ----------------------------------------------------------------------
82itcl::body Rappture::DrawingControls::destructor {} {
83    array unset _name2info
84}
85
86itcl::body Rappture::DrawingControls::delete { {cname "all"} } {
87    set controls $cname
88    if { $cname == "all" } {
89        set controls $_controls
90    }
91    foreach name $controls {
92        set w $_frame.v$name
93        destroy $w
94        if { [info exists _name2info($name-label)] } {
95            destroy $_frame.l$name
96        }
97        set i [lsearch $_controls $name]
98        set _controls [lreplace $_controls $i $i]
99        array unset _name2info $name-*
100    }
101}
102
103itcl::body Rappture::DrawingControls::add { path } {
104    set pos [llength $_controls]
105    incr _counter
106    set name "control$_counter"
107    set path [$_owner xml element -as path $path]
108
109    set _name2info($name-path) $path
110    set _name2info($name-label) ""
111    set _name2info($name-type) ""
112    set w $_frame.v$name
113    set _name2info($name-value) $w
114    set _name2info($name-enable) "yes"
115    set _name2info($name-disablestyle) "greyout"
116
117    set type [$_owner xml element -as type $path]
118    set _name2info($name-type) $type
119    switch -- $type {
120        choice {
121            Rappture::ChoiceEntry $w $_owner $path
122            bind $w <<Value>> [itcl::code $this ControlChanged $name]
123        }
124        filechoice {
125            Rappture::FileChoiceEntry $w $_owner $path
126            bind $w <<Value>> [itcl::code $this ControlChanged $name]
127        }
128        filelist {
129            Rappture::FileListEntry $w $_owner $path
130            bind $w <<Value>> [itcl::code $this ControlChanged $name]
131        }
132        group {
133            Rappture::GroupEntry $w $_owner $path
134        }
135        loader {
136            Rappture::Loader $w $_owner $path -tool [$_owner tool]
137            bind $w <<Value>> [itcl::code $this ControlChanged $name]
138        }
139        number {
140            Rappture::NumberEntry $w $_owner $path
141            bind $w <<Value>> [itcl::code $this ControlChanged $name]
142        }
143        integer {
144            Rappture::IntegerEntry $w $_owner $path
145            bind $w <<Value>> [itcl::code $this ControlChanged $name]
146        }
147        boolean {
148            Rappture::BooleanEntry $w $_owner $path
149            bind $w <<Value>> [itcl::code $this ControlChanged $name]
150        }
151        string {
152            Rappture::TextEntry $w $_owner $path
153            bind $w <<Value>> [itcl::code $this ControlChanged $name]
154        }
155        image {
156            Rappture::ImageEntry $w $_owner $path
157        }
158        separator {
159            # no widget to create
160            set _name2info($name-value) "--"
161        }
162        note {
163            Rappture::Note $w $_owner $path
164        }
165        periodicelement {
166            Rappture::PeriodicElementEntry $w $_owner $path
167            bind $w <<Value>> [itcl::code $this _controlChanged $name]
168        }
169        default {
170            error "don't know how to add control type \"$type\""
171        }
172    }
173    #
174    # If this element has an <enable> expression, then register its
175    # controlling widget here. 
176    #
177    set notify [string trim [$_owner xml get $path.about.notify]]
178
179    set disablestyle [string trim [$_owner xml get $path.about.disablestyle]]
180    if { $disablestyle != "" } {
181        set _name2info($name-disablestyle) $disablestyle
182    }
183
184    if 0 {
185    #
186    # If this element has an <enable> expression, then register
187    # its controlling widget here.
188    #
189    set enable [string trim [$_owner xml get $path.about.enable]]
190    if {"" == $enable} {
191        set enable yes
192    }
193    if {![string is boolean $enable]} {
194        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/]+)?}
195        set rest $enable
196        set enable ""
197        set deps ""
198        while {1} {
199            if {[regexp -indices $re $rest match]} {
200                foreach {s0 s1} $match break
201
202                if {[string index $rest [expr {$s0-1}]] == "\""
203                      && [string index $rest [expr {$s1+1}]] == "\""} {
204                    # string in ""'s? then leave it alone
205                    append enable [string range $rest 0 $s1]
206                    set rest [string range $rest [expr {$s1+1}] end]
207                } else {
208                    #
209                    # This is a symbol which should be substituted
210                    # it can be either:
211                    #   input.foo.bar
212                    #   input.foo.bar:units
213                    #
214                    set cpath [string range $rest $s0 $s1]
215                    set parts [split $cpath :]
216                    set ccpath [lindex $parts 0]
217                    set units [lindex $parts 1]
218
219                    # make sure we have the standard path notation
220                    set stdpath [$_owner regularize $ccpath]
221                    if {"" == $stdpath} {
222                        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."
223                        set stdpath $ccpath
224                    }
225                    # substitute [_controlValue ...] call in place of path
226                    append enable [string range $rest 0 [expr {$s0-1}]]
227                    append enable [format {[ControlValue %s %s]} $stdpath $units]
228                    lappend deps $stdpath
229                    set rest [string range $rest [expr {$s1+1}] end]
230                }
231            } else {
232                append enable $rest
233                break
234            }
235        }
236        foreach cpath $deps {
237            $_owner dependenciesfor $cpath $path
238        }
239    }
240    }
241    set _name2info($name-enable) yes
242
243    #set wid [$_owner widgetfor $path]
244
245    if {[lsearch {control group separator note} $type] < 0} {
246        # make a label for this control
247        set label [$w label]
248        if {"" != $label} {
249            set _name2info($name-label) $_frame.l$name
250            set font [option get $itk_component(hull) labelFont Font]
251            label $_name2info($name-label) -text [FormatLabel $label] \
252                -font $font
253        }
254
255        # register the tooltip for this control
256        set tip [$w tooltip]
257        if {"" != $tip} {
258            Rappture::Tooltip::for $w $tip
259
260            # add the tooltip to the label too, if there is one
261            if {$_name2info($name-label) != ""} {
262                Rappture::Tooltip::for $_name2info($name-label) $tip
263            }
264        }
265    }
266
267    # insert the new control onto the known list
268    set _controls [linsert $_controls $pos $name]
269    Monitor $name on
270
271    # now that we have a new control, we should fix the layout
272    $_dispatcher event -idle !layout
273    ControlChanged $name
274    return $name
275}
276
277# ----------------------------------------------------------------------
278# USAGE: ControlChanged <name>
279#
280# Invoked automatically whenever the value for a control changes.
281# Sends a notification along to the tool controlling this panel.
282# ----------------------------------------------------------------------
283itcl::body Rappture::DrawingControls::ControlChanged {name} {
284    set wv $_name2info($name-value)
285    set value [$wv value]
286    set path $_name2info($name-path)
287    set wid [$_owner widgetfor $path]
288    # Push the new value into the shadow widget.
289    $wid value $value
290    # Overwrite the default value
291    $_owner xml put $path.default $value
292    set path $_name2info($name-path)
293    # Let the owner know that this control changed.
294    if {"" != $_owner} {
295        $_owner changed $path
296    }
297    if { [winfo class $wid] == "TextEntry" } {
298        return
299    }
300    eval $deactivatecommand
301}
302
303# ----------------------------------------------------------------------
304# USAGE: Rebuild
305#
306# Used internally to fix the layout of controls whenever controls
307# are added or deleted, or when the control arrangement changes.
308# There are a lot of heuristics here trying to achieve a "good"
309# arrangement of controls.
310# ----------------------------------------------------------------------
311itcl::body Rappture::DrawingControls::Rebuild {} {
312    #
313    # Clear any existing layout
314    #
315    foreach name $_controls {
316        foreach elem {label value} {
317            set w $_name2info($name-$elem)
318            if {$w != "" && [winfo exists $w]} {
319                grid forget $w
320            }
321        }
322    }
323    grid forget $_frame.empty
324
325    #
326    # Decide which widgets should be shown and which should be hidden.
327    #
328    set hidden ""
329    set showing ""
330    foreach name $_controls {
331        set show 1
332        set cond $_name2info($name-enable)
333        if {[string is boolean $cond] && !$cond} {
334            # hard-coded "off" -- ignore completely
335        } elseif {[catch {expr $cond} show] == 0} {
336            set type $_name2info($name-type)
337            set disablestyle $_name2info($name-disablestyle)
338            set lwidget $_name2info($name-label)
339            set vwidget $_name2info($name-value)
340            if {[lsearch -exact {group image structure} $type] >= 0 ||
341                $disablestyle == "hide" } {
342                if {$show ne "" && $show} {
343                    lappend showing $name
344                } else {
345                    lappend hidden $name
346                }
347            } else {
348                # show other objects, but enable/disable them
349                lappend showing $name
350                if {$show ne "" && $show} {
351                    if {[winfo exists $vwidget]} {
352                        $vwidget configure -state normal
353                    }
354                    if {[winfo exists $lwidget]} {
355                        $lwidget configure -foreground \
356                            [lindex [$lwidget configure -foreground] 3]
357                    }
358                } else {
359                    if {[winfo exists $vwidget]} {
360                        $vwidget configure -state disabled
361                    }
362                    if {[winfo exists $lwidget]} {
363                        $lwidget configure -foreground gray
364                    }
365                }
366            }
367        } else {
368            bgerror "Error in <enable> expression for \"$_name2info($name-path)\":\n  $show"
369        }
370    }
371
372    # store the showing tabs in the object so it can be used in _changeTabs
373    set _showing $showing
374
375    #
376    # SCHEME: hlabels
377    # simple "Label: Value" layout
378    #
379    #pack forget $_tabs
380    grid propagate $_frame on
381    grid columnconfigure $_frame 0 -weight 0
382    grid rowconfigure $_frame 0 -weight 0
383   
384    set expand 0  ;# most controls float to top
385    set row 0
386    foreach name $showing {
387        set wl $_name2info($name-label)
388        if {$wl != "" && [winfo exists $wl]} {
389            grid $wl -row $row -column 0 -sticky e
390        }
391       
392        set wv $_name2info($name-value)
393        if {$wv != "" && [winfo exists $wv]} {
394            if {$wl != ""} {
395                grid $wv -row $row -column 1 -sticky ew
396            } else {
397                grid $wv -row $row -column 0 -columnspan 2 -sticky ew
398            }
399           
400            grid rowconfigure $_frame $row -weight 0
401           
402            switch -- [winfo class $wv] {
403                TextEntry {
404                    if {[regexp {[0-9]+x[0-9]+} [$wv size]]} {
405                        grid $wl -sticky n -pady 4
406                        grid $wv -sticky nsew
407                        grid rowconfigure $_frame $row -weight 1
408                        grid columnconfigure $_frame 1 -weight 1
409                        set expand 1
410                    }
411                }
412                GroupEntry {
413                    $wv configure -heading yes
414                   
415                    #
416                    # Scan through all children in this group
417                    # and see if any demand more space.  If the
418                    # group contains a structure or a note, then
419                    # make sure that the group itself is set to
420                    # expand/fill.
421                    #
422                    set queue [winfo children $wv]
423                    set expandgroup 0
424                    while {[llength $queue] > 0} {
425                        set w [lindex $queue 0]
426                        set queue [lrange $queue 1 end]
427                        set c [winfo class $w]
428                        if {[lsearch {DeviceEditor Note} $c] >= 0} {
429                            set expandgroup 1
430                            break
431                        }
432                        eval lappend queue [winfo children $w]
433                    }
434                    if {$expandgroup} {
435                        set expand 1
436                        grid $wv -sticky nsew
437                        grid rowconfigure $_frame $row -weight 1
438                    }
439                }
440                Note {
441                    grid $wv -sticky nsew
442                    grid rowconfigure $_frame $row -weight 1
443                    set expand 1
444                }
445            }
446            grid columnconfigure $_frame 1 -weight 1
447        } elseif {$wv == "--"} {
448            grid rowconfigure $_frame $row -minsize 10
449        }
450       
451        incr row
452        grid rowconfigure $_frame $row -minsize $itk_option(-padding)
453        incr row
454    }
455    grid $_frame.empty -row $row
456   
457    #
458    # If there are any hidden items, then make the bottom of
459    # this form fill up any extra space, so the form floats
460    # to the top.  Otherwise, it will jitter around as the
461    # hidden items come and go.
462    #
463    if {[llength $hidden] > 0 && !$expand} {
464        grid rowconfigure $_frame 99 -weight 1
465    } else {
466        grid rowconfigure $_frame 99 -weight 0
467    }
468    set _closeOnChange 0
469    set slaves [grid slaves $_frame]
470    if { [llength $slaves] == 1 } {
471        set slave [lindex $slaves 0]
472        set _closeOnChange 1
473    }
474}
475
476# ----------------------------------------------------------------------
477# USAGE: ControlValue <path> ?<units>?
478#
479# Used internally to get the value of a control with the specified
480# <path>.  Returns the current value for the control.
481# ----------------------------------------------------------------------
482itcl::body Rappture::DrawingControls::ControlValue {path {units ""}} {
483    if {"" != $_owner} {
484        set val [$_owner valuefor $path]
485        if {"" != $units} {
486            set val [Rappture::Units::convert $val -to $units -units off]
487        }
488        return $val
489    }
490    return ""
491}
492
493# ----------------------------------------------------------------------
494# USAGE: FormatLabel <string>
495#
496# Used internally to format a label <string>.  Trims any excess
497# white space and adds a ":" to the end.  That way, all labels
498# have a uniform look.
499# ----------------------------------------------------------------------
500itcl::body Rappture::DrawingControls::FormatLabel {str} {
501    set str [string trim $str]
502    if {"" != $str && [string index $str end] != ":"} {
503        append str ":"
504    }
505    return $str
506}
507
508# ----------------------------------------------------------------------
509# USAGE: Monitor <name> <state>
510#
511# Used internally to add/remove bindings that cause the widget
512# associated with <name> to notify this controls widget of size
513# changes.  Whenever there is a size change, this controls widget
514# should fix its layout.
515# ----------------------------------------------------------------------
516itcl::body Rappture::DrawingControls::Monitor {name state} {
517    set tag "Controls-$this"
518    set wv $_name2info($name-value)
519    if {$wv == "--" || [catch {bindtags $wv} btags]} {
520        return
521    }
522    set i [lsearch $btags $tag]
523
524    if {$state} {
525        if {$i < 0} {
526            bindtags $wv [linsert $btags 0 $tag]
527        }
528    } else {
529        if {$i >= 0} {
530            bindtags $wv [lreplace $btags $i $i]
531        }
532    }
533}
534
535# ----------------------------------------------------------------------
536# OPTION: -padding
537# ----------------------------------------------------------------------
538itcl::configbody Rappture::DrawingControls::padding {
539    $_dispatcher event -idle !layout
540}
541
Note: See TracBrowser for help on using the repository browser.