source: trunk/gui/scripts/gauge.tcl @ 1313

Last change on this file since 1313 was 962, checked in by dkearney, 17 years ago

code cleanups.
adjusted gague.tcl to check the length of the string it receives for integers and reals.
modified c, matlab, and octave's lib function to handle empty string for creation of empty library.
modified matlab and octave's lib result function to handle status as a parameter.
fixed core library code to deal with incorrect order of translating xml entity references.

File size: 24.7 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: gauge - compact readout for real values
3#
4#  This widget is a readout for a real value.  It has a little glyph
5#  filled with color according to the value, followed by a numeric
6#  representation of the value itself.  The value can be edited, and
7#  a list of predefined values can be associated with a menu that
8#  drops down from the value.
9# ======================================================================
10#  AUTHOR:  Michael McLennan, Purdue University
11#  Copyright (c) 2004-2005  Purdue Research Foundation
12#
13#  See the file "license.terms" for information on usage and
14#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15# ======================================================================
16package require Itk
17package require BLT
18
19option add *Gauge.sampleWidth 30 widgetDefault
20option add *Gauge.sampleHeight 20 widgetDefault
21option add *Gauge.valuePosition "right" widgetDefault
22option add *Gauge.textBackground #cccccc widgetDefault
23option add *Gauge.editable yes widgetDefault
24
25itcl::class Rappture::Gauge {
26    inherit itk::Widget
27
28    itk_option define -editable editable Editable ""
29    itk_option define -state state State "normal"
30    itk_option define -spectrum spectrum Spectrum ""
31    itk_option define -type type Type "real"
32    itk_option define -units units Units ""
33    itk_option define -minvalue minValue MinValue ""
34    itk_option define -maxvalue maxValue MaxValue ""
35    itk_option define -presets presets Presets ""
36    itk_option define -valueposition valuePosition ValuePosition ""
37    itk_option define -image image Image ""
38    itk_option define -samplewidth sampleWidth SampleWidth 0
39    itk_option define -sampleheight sampleHeight SampleHeight 0
40
41    constructor {args} { # defined below }
42
43    public method value {args}
44    public method edit {option}
45    public method bump {delta}
46
47    protected method _redraw {}
48    protected method _resize {}
49    protected method _hilite {comp state}
50    protected method _editor {option args}
51    protected method _presets {option}
52    protected method _layout {}
53
54    private variable _value 0  ;# value for this widget
55
56    blt::bitmap define GaugeArrow-up {
57        #define up_width 8
58        #define up_height 4
59        static unsigned char up_bits[] = {
60           0x10, 0x38, 0x7c, 0xfe};
61    }
62    blt::bitmap define GaugeArrow-down {
63        #define arrow_width 8
64        #define arrow_height 4
65        static unsigned char arrow_bits[] = {
66           0xfe, 0x7c, 0x38, 0x10};
67    }
68
69    blt::bitmap define GaugeArrow {
70        #define arrow_width 9
71        #define arrow_height 4
72        static unsigned char arrow_bits[] = {
73           0x7f, 0x00, 0x3e, 0x00, 0x1c, 0x00, 0x08, 0x00};
74    }
75}
76                                                                               
77itk::usual Gauge {
78    keep -cursor -font -foreground -background
79    keep -selectbackground -selectforeground -selectborderwidth
80}
81
82# ----------------------------------------------------------------------
83# CONSTRUCTOR
84# ----------------------------------------------------------------------
85itcl::body Rappture::Gauge::constructor {args} {
86    itk_component add icon {
87        canvas $itk_interior.icon -width 1 -height 1 \
88            -borderwidth 0 -highlightthickness 0
89    } {
90        usual
91        ignore -highlightthickness -highlightbackground -highlightcolor
92    }
93    pack $itk_component(icon) -side left
94    bind $itk_component(icon) <Configure> [itcl::code $this _redraw]
95
96    itk_component add -protected vframe {
97        frame $itk_interior.vframe
98    }
99
100    itk_component add value {
101        label $itk_component(vframe).value -borderwidth 1 -width 7 \
102            -textvariable [itcl::scope _value]
103    } {
104        rename -background -textbackground textBackground Background
105    }
106    pack $itk_component(value) -side left -expand yes -fill both
107
108    bind $itk_component(value) <Enter> [itcl::code $this _hilite value on]
109    bind $itk_component(value) <Leave> [itcl::code $this _hilite value off]
110
111    bind $itk_component(value) <<Cut>> [itcl::code $this edit cut]
112    bind $itk_component(value) <<Copy>> [itcl::code $this edit copy]
113    bind $itk_component(value) <<Paste>> [itcl::code $this edit paste]
114
115    itk_component add emenu {
116        menu $itk_component(value).menu -tearoff 0
117    } {
118        usual
119        ignore -tearoff
120    }
121    $itk_component(emenu) add command -label "Cut" -accelerator "^X" \
122        -command [list event generate $itk_component(value) <<Cut>>]
123    $itk_component(emenu) add command -label "Copy" -accelerator "^C" \
124        -command [list event generate $itk_component(value) <<Copy>>]
125    $itk_component(emenu) add command -label "Paste" -accelerator "^V" \
126        -command [list event generate $itk_component(value) <<Paste>>]
127    bind $itk_component(value) <<PopupMenu>> \
128        [itcl::code $this _editor menu %X %Y]
129
130    itk_component add editor {
131        Rappture::Editor $itk_interior.editor \
132            -activatecommand [itcl::code $this _editor activate] \
133            -validatecommand [itcl::code $this _editor validate] \
134            -applycommand [itcl::code $this _editor apply]
135    }
136    bind $itk_component(value) <ButtonPress> \
137        [itcl::code $this _editor popup]
138
139
140    itk_component add spinner {
141        frame $itk_component(vframe).spinner
142    }
143
144    itk_component add spinup {
145        button $itk_component(spinner).up -bitmap GaugeArrow-up \
146            -borderwidth 1 -relief raised -highlightthickness 0 \
147            -command [itcl::code $this bump 1]
148    } {
149        usual
150        ignore -borderwidth -highlightthickness
151    }
152    pack $itk_component(spinup) -side top -expand yes -fill both
153
154    itk_component add spindn {
155        button $itk_component(spinner).down -bitmap GaugeArrow-down \
156            -borderwidth 1 -relief raised -highlightthickness 0 \
157            -command [itcl::code $this bump -1]
158    } {
159        usual
160        ignore -borderwidth -highlightthickness
161    }
162    pack $itk_component(spindn) -side bottom -expand yes -fill both
163
164
165    itk_component add presets {
166        button $itk_component(vframe).psbtn -bitmap GaugeArrow \
167            -borderwidth 1 -highlightthickness 0 -relief flat
168    } {
169        usual
170        ignore -borderwidth -relief -highlightthickness
171        rename -background -textbackground textBackground Background
172    }
173
174    bind $itk_component(presets) <Enter> [itcl::code $this _hilite presets on]
175    bind $itk_component(presets) <Leave> [itcl::code $this _hilite presets off]
176
177    itk_component add presetlist {
178        Rappture::Dropdownlist $itk_component(presets).plist \
179            -postcommand [itcl::code $this _presets post] \
180            -unpostcommand [itcl::code $this _presets unpost] \
181    }
182
183    bind $itk_component(presetlist) <<DropdownlistSelect>> \
184        [itcl::code $this _presets select]
185
186    $itk_component(presets) configure -command \
187        [list $itk_component(presetlist) post $itk_component(vframe) left]
188
189    eval itk_initialize $args
190}
191
192# ----------------------------------------------------------------------
193# USAGE: value ?-check? ?<newval>?
194#
195# Clients use this to query/set the value for this widget.  With
196# no args, it returns the current value for the widget.  If the
197# <newval> is specified, it sets the value of the widget and
198# sends a <<Value>> event.  If the -check flag is included, the
199# new value is not actually applied, but just checked for correctness.
200# ----------------------------------------------------------------------
201itcl::body Rappture::Gauge::value {args} {
202    set onlycheck 0
203    set i [lsearch -exact $args -check]
204    if {$i >= 0} {
205        set onlycheck 1
206        set args [lreplace $args $i $i]
207    }
208
209    if {[llength $args] == 1} {
210        #
211        # If this gauge has -units, try to convert the incoming
212        # value to that system of units.  Also, make sure that
213        # the value is bound by any min/max value constraints.
214        #
215        # Keep track of the inputted units so we can give a
216        # response about min and max values in familiar units.
217        #
218        set newval [set nv [lindex $args 0]]
219        set units $itk_option(-units)
220        if {"" != $units} {
221            set newval [Rappture::Units::convert $newval -context $units]
222            set nvUnits [Rappture::Units::Search::for $newval]
223            if { "" == $nvUnits} {
224                set msg [Rappture::Units::description $units]
225                error "Unrecognized units: $newval\nEnter value with units of $msg"
226            }
227            set nv [Rappture::Units::convert $nv \
228                -context $units -to $units -units off]
229
230            # Normalize the units name
231            set newval [Rappture::Units::convert $newval -units off]$nvUnits
232        }
233
234        switch -- $itk_option(-type) {
235            integer {
236                if {[string length $nv] <= 0
237                      || ![string is integer $nv] } {
238                    error "Should be an integer value"
239                }
240            }
241            real {
242                if {[string length $nv] <= 0
243                      || ![string is double $nv]
244                      || [regexp -nocase {^(inf|nan)$} $nv]} {
245                    error "Should be a real number"
246                }
247            }
248        }
249
250        if {"" != $itk_option(-minvalue)} {
251            set convMinVal [set minv $itk_option(-minvalue)]
252            if {"" != $units} {
253                set minv [Rappture::Units::convert $minv \
254                    -context $units -to $units -units off]
255                set convMinVal [Rappture::Units::convert \
256                    $itk_option(-minvalue) -context $units -to $nvUnits]
257            } else {
258                set newval [format "%g" $newval]
259            }
260
261            # fix for the case when the user tries to
262            # compare values like minv=-500 nv=-0600
263            set nv [format "%g" $nv]
264            set minv [format "%g" $minv]
265
266            if {$nv < $minv} {
267                error "minimum value allowed here is $convMinVal"
268            }
269        }
270
271        if {"" != $itk_option(-maxvalue)} {
272            set convMaxVal [set maxv $itk_option(-maxvalue)]
273            if {"" != $units} {
274                set maxv [Rappture::Units::convert $maxv \
275                    -context $units -to $units -units off]
276                set convMaxVal [Rappture::Units::convert \
277                    $itk_option(-maxvalue) -context $units -to $nvUnits]
278            } else {
279                set newval [format "%g" $newval]
280            }
281
282            # fix for the case when the user tries to
283            # compare values like maxv=500 nv=0600
284            set nv [format "%g" $nv]
285            set maxv [format "%g" $maxv]
286
287            if {$nv > $maxv} {
288                error "maximum value allowed here is $convMaxVal"
289            }
290        }
291
292        if {$onlycheck} {
293            return
294        }
295
296        set _value $newval
297
298        _redraw
299        event generate $itk_component(hull) <<Value>>
300
301    } elseif {[llength $args] != 0} {
302        error "wrong # args: should be \"value ?-check? ?newval?\""
303    }
304    return $_value
305}
306
307# ----------------------------------------------------------------------
308# USAGE: edit cut
309# USAGE: edit copy
310# USAGE: edit paste
311#
312# Used internally to handle cut/copy/paste operations for the current
313# value.  Usually invoked by <<Cut>>, <<Copy>>, <<Paste>> events, but
314# can also be called directly through this method.
315# ----------------------------------------------------------------------
316itcl::body Rappture::Gauge::edit {option} {
317    if {$itk_option(-state) == "disabled"} {
318        return  ;# disabled? then bail out here!
319    }
320    switch -- $option {
321        cut {
322            edit copy
323            _editor popup
324            $itk_component(editor) value ""
325            $itk_component(editor) deactivate
326        }
327        copy {
328            clipboard clear
329            clipboard append $_value
330        }
331        paste {
332            _editor popup
333            $itk_component(editor) value [clipboard get]
334            $itk_component(editor) deactivate
335        }
336        default {
337            error "bad option \"$option\": should be cut, copy, paste"
338        }
339    }
340}
341
342# ----------------------------------------------------------------------
343# USAGE: bump <delta>
344#
345# Changes the current value up/down by the <delta> value.  Used
346# internally by the up/down spinner buttons when the value is
347# -type integer.
348# ----------------------------------------------------------------------
349itcl::body Rappture::Gauge::bump {delta} {
350    set val $_value
351    if {$val == ""} {
352        set val 0
353    }
354    if {[catch {value [expr {$val+$delta}]} result]} {
355        if {[regexp {allowed here is (.+)} $result match newval]} {
356            set _value $newval
357            $itk_component(value) configure -text $newval
358        }
359        if {[regexp {^bad.*: +(.)(.+)} $result match first tail]
360              || [regexp {(.)(.+)} $result match first tail]} {
361            set result "[string toupper $first]$tail"
362        }
363        bell
364        Rappture::Tooltip::cue $itk_component(value) $result
365        return 0
366    }
367}
368
369# ----------------------------------------------------------------------
370# USAGE: _redraw
371#
372# Used internally to redraw the gauge on the internal canvas based
373# on the current value and the size of the widget.  In this simple
374# base class, the gauge is drawn as a colored block, with an optional
375# image in the middle of it.
376# ----------------------------------------------------------------------
377itcl::body Rappture::Gauge::_redraw {} {
378    set c $itk_component(icon)
379    set w [winfo width $c]
380    set h [winfo height $c]
381
382    if {"" == [$c find all]} {
383        # first time around, create the items
384        $c create rectangle 0 0 1 1 -outline black -tags block
385        $c create image 0 0 -anchor center -image "" -tags bimage
386        $c create rectangle 0 0 1 1 -outline "" -fill "" -stipple gray50 -tags screen
387    }
388
389    if {"" != $itk_option(-spectrum)} {
390        set color [$itk_option(-spectrum) get $_value]
391    } else {
392        set color ""
393    }
394
395    # update the items based on current values
396    $c coords block 0 0 [expr {$w-1}] [expr {$h-1}]
397    $c coords screen 0 0 $w $h
398    $c itemconfigure block -fill $color
399
400    $c coords bimage [expr {0.5*$w}] [expr {0.5*$h}]
401
402    if {$itk_option(-state) == "disabled"} {
403        $c itemconfigure screen -fill white
404    } else {
405        $c itemconfigure screen -fill ""
406    }
407}
408
409# ----------------------------------------------------------------------
410# USAGE: _resize
411#
412# Used internally to resize the internal canvas based on the -image
413# option or the size of the text.
414# ----------------------------------------------------------------------
415itcl::body Rappture::Gauge::_resize {} {
416    set w 0
417    set h 0
418
419    if {"" != $itk_option(-image) || "" != $itk_option(-spectrum)} {
420        if {$itk_option(-samplewidth) > 0} {
421            set w $itk_option(-samplewidth)
422        } else {
423            if {$itk_option(-image) != ""} {
424                set w [expr {[image width $itk_option(-image)]+4}]
425            } else {
426                set w [winfo reqheight $itk_component(value)]
427            }
428        }
429
430        if {$itk_option(-sampleheight) > 0} {
431            set h $itk_option(-sampleheight)
432        } else {
433            if {$itk_option(-image) != ""} {
434                set h [expr {[image height $itk_option(-image)]+4}]
435            } else {
436                set h [winfo reqheight $itk_component(value)]
437            }
438        }
439    }
440
441    if {$w > 0 && $h > 0} {
442        $itk_component(icon) configure -width $w -height $h
443    }
444}
445
446# ----------------------------------------------------------------------
447# USAGE: _hilite <component> <state>
448#
449# Used internally to resize the internal canvas based on the -image
450# option or the size of the text.
451# ----------------------------------------------------------------------
452itcl::body Rappture::Gauge::_hilite {comp state} {
453    if {$itk_option(-state) == "disabled"} {
454        set state 0  ;# disabled? then don't hilite
455    }
456    if {$comp == "value" && !$itk_option(-editable)} {
457        $itk_component(value) configure -relief flat
458        return
459    }
460
461    if {$state} {
462        $itk_component($comp) configure -relief solid
463    } else {
464        $itk_component($comp) configure -relief flat
465    }
466}
467
468# ----------------------------------------------------------------------
469# USAGE: _editor popup
470# USAGE: _editor activate
471# USAGE: _editor validate <value>
472# USAGE: _editor apply <value>
473# USAGE: _editor menu <rootx> <rooty>
474#
475# Used internally to handle the various functions of the pop-up
476# editor for the value of this gauge.
477# ----------------------------------------------------------------------
478itcl::body Rappture::Gauge::_editor {option args} {
479    if {$itk_option(-state) == "disabled"} {
480        return  ;# disabled? then bail out here!
481    }
482    switch -- $option {
483        popup {
484            if {$itk_option(-editable)} {
485                $itk_component(editor) activate
486            }
487        }
488        activate {
489            return [list text $_value \
490                x [winfo rootx $itk_component(value)] \
491                y [winfo rooty $itk_component(value)] \
492                w [winfo width $itk_component(value)] \
493                h [winfo height $itk_component(value)]]
494        }
495        validate {
496            if {[llength $args] != 1} {
497                error "wrong # args: should be \"_editor validate val\""
498            }
499            set val [lindex $args 0]
500
501            if {[catch {value -check $val} result]} {
502                if {[regexp {allowed here is (.+)} $result match newval]} {
503                    $itk_component(editor) value $newval
504                }
505                if {[regexp {^bad.*: +(.)(.+)} $result match first tail]
506                      || [regexp {(.)(.+)} $result match first tail]} {
507                    set result "[string toupper $first]$tail"
508                }
509                bell
510                Rappture::Tooltip::cue $itk_component(editor) $result
511                return 0
512            }
513        }
514        apply {
515            if {[llength $args] != 1} {
516                error "wrong # args: should be \"_editor apply val\""
517            }
518            value [lindex $args 0]
519        }
520        menu {
521            eval tk_popup $itk_component(emenu) $args
522        }
523        default {
524            error "bad option \"$option\": should be popup, activate, validate, apply, and menu"
525        }
526    }
527}
528
529# ----------------------------------------------------------------------
530# USAGE: _presets post
531# USAGE: _presets unpost
532# USAGE: _presets select
533#
534# Used internally to handle the list of presets for this gauge.  The
535# post/unpost options are invoked when the list is posted or unposted
536# to manage the relief of the controlling button.  The select option
537# is invoked whenever there is a selection from the list, to assign
538# the value back to the gauge.
539# ----------------------------------------------------------------------
540itcl::body Rappture::Gauge::_presets {option} {
541    switch -- $option {
542        post {
543            set i [$itk_component(presetlist) index $_value]
544            if {$i >= 0} {
545                $itk_component(presetlist) select clear 0 end
546                $itk_component(presetlist) select set $i
547            }
548            after 10 [list $itk_component(presets) configure -relief sunken]
549        }
550        unpost {
551            $itk_component(presets) configure -relief flat
552        }
553        select {
554            set val [$itk_component(presetlist) current]
555            if {"" != $val} {
556                value $val
557            }
558        }
559        default {
560            error "bad option \"$option\": should be post, unpost, select"
561        }
562    }
563}
564
565# ----------------------------------------------------------------------
566# USAGE: _layout
567#
568# Used internally to fix the layout of widgets whenever there is a
569# change in the options that affect layout.  Puts the value in the
570# proper position according to the -valueposition option.  Also,
571# adds or removes the icon if it needs to be shown.
572# ----------------------------------------------------------------------
573itcl::body Rappture::Gauge::_layout {} {
574    foreach w [pack slaves $itk_component(hull)] {
575        pack forget $w
576    }
577
578    array set side2anchor {
579        left   e
580        right  w
581        top    s
582        bottom n
583    }
584    set pos $itk_option(-valueposition)
585    pack $itk_component(vframe) -side $pos \
586        -expand yes -fill both -ipadx 2
587    $itk_component(value) configure -anchor $side2anchor($pos)
588
589    if {"" != $itk_option(-image) || "" != $itk_option(-spectrum)} {
590        pack $itk_component(icon) -side $pos
591    }
592}
593
594# ----------------------------------------------------------------------
595# CONFIGURATION OPTION: -editable
596# ----------------------------------------------------------------------
597itcl::configbody Rappture::Gauge::editable {
598    if {![string is boolean -strict $itk_option(-editable)]} {
599        error "bad value \"$itk_option(-editable)\": should be boolean"
600    }
601    if {!$itk_option(-editable) && [winfo ismapped $itk_component(editor)]} {
602        $itk_component(editor) deactivate -abort
603    }
604}
605
606# ----------------------------------------------------------------------
607# CONFIGURATION OPTION: -state
608# ----------------------------------------------------------------------
609itcl::configbody Rappture::Gauge::state {
610    set valid {normal disabled}
611    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
612        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
613    }
614    $itk_component(value) configure -state $itk_option(-state)
615    $itk_component(spinup) configure -state $itk_option(-state)
616    $itk_component(spindn) configure -state $itk_option(-state)
617    $itk_component(presets) configure -state $itk_option(-state)
618    _redraw  ;# fix gauge
619}
620
621# ----------------------------------------------------------------------
622# CONFIGURATION OPTION: -spectrum
623# ----------------------------------------------------------------------
624itcl::configbody Rappture::Gauge::spectrum {
625    if {$itk_option(-spectrum) != ""
626          && ([catch {$itk_option(-spectrum) isa ::Rappture::Spectrum} valid]
627               || !$valid)} {
628        error "bad option \"$itk_option(-spectrum)\": should be Rappture::Spectrum object"
629    }
630    _resize
631    _layout
632    _redraw
633}
634
635# ----------------------------------------------------------------------
636# CONFIGURATION OPTION: -image
637# ----------------------------------------------------------------------
638itcl::configbody Rappture::Gauge::image {
639    if {$itk_option(-image) != ""
640          && [catch {image width $itk_option(-image)}]} {
641        error "bad value \"$itk_option(-image)\": should be Tk image"
642    }
643    _resize
644    _layout
645    $itk_component(icon) itemconfigure bimage -image $itk_option(-image)
646}
647
648# ----------------------------------------------------------------------
649# CONFIGURATION OPTION: -units
650# ----------------------------------------------------------------------
651itcl::configbody Rappture::Gauge::units {
652    if {$itk_option(-units) != ""
653          && [::Rappture::Units::System::for $itk_option(-units)] == ""} {
654        error "unrecognized system of units \"$itk_option(-units)\""
655    }
656}
657
658# ----------------------------------------------------------------------
659# CONFIGURATION OPTION: -valueposition
660# ----------------------------------------------------------------------
661itcl::configbody Rappture::Gauge::valueposition {
662    set pos $itk_option(-valueposition)
663    set opts {left right top bottom}
664    if {[lsearch -exact $opts $pos] < 0} {
665        error "bad value \"$pos\": should be [join $opts {, }]"
666    }
667    _layout
668}
669
670# ----------------------------------------------------------------------
671# CONFIGURATION OPTION: -presets
672# ----------------------------------------------------------------------
673itcl::configbody Rappture::Gauge::presets {
674    if {"" == $itk_option(-presets)} {
675        pack forget $itk_component(presets)
676    } else {
677        if {$itk_option(-valueposition) == "left"} {
678            set s "left"
679        } else {
680            set s "right"
681        }
682        set first [lindex [pack slaves $itk_component(vframe)] 0]
683        pack $itk_component(presets) -before $first -side $s -fill y
684
685        $itk_component(presetlist) delete 0 end
686        $itk_component(presetlist) insert end $itk_option(-presets)
687    }
688}
689
690# ----------------------------------------------------------------------
691# CONFIGURATION OPTION: -type
692# ----------------------------------------------------------------------
693itcl::configbody Rappture::Gauge::type {
694    switch -- $itk_option(-type) {
695        integer {
696            set first [lindex [pack slaves $itk_component(vframe)] 0]
697            if {$first == $itk_component(presets)} {
698                pack $itk_component(spinner) -after $first -side left -fill y
699            } else {
700                pack $itk_component(spinner) -before $first -side right -fill y
701            }
702        }
703        real {
704            pack forget $itk_component(spinner)
705        }
706        default {
707            error "bad number type \"$itk_option(-type)\": should be integer or real"
708        }
709    }
710}
Note: See TracBrowser for help on using the repository browser.