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

Last change on this file since 552 was 552, checked in by dkearney, 18 years ago

adjusted the formatting to use %g which chops off random zeros at the end of values so integers still look like integers and floats can live happily in "less than 6 digit percision"-land. also added in code to format newval which is the real value being stored in the component. formatting of newval only happens if the newval does not have units attached to it. this fix introduces a place of confusion where the user enters "." into an integer input, the error message states the user needs to enter a floating point number. then the user enters a floating point number and the error message states the user needs to enter an integer. might consider moving the integer check up, in front of the min/max value check
File size: 24.3 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]
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 nvUnits [Rappture::Units::Search::for $nv]
222            set newval [Rappture::Units::convert $newval \
223                -context $units]
224            set nv [Rappture::Units::convert $nv \
225                -context $units -to $units -units off]
226        }
227
228        if {"" != $itk_option(-minvalue)} {
229            set convMinVal [set minv $itk_option(-minvalue)]
230            if {$units != ""} {
231                set minv [Rappture::Units::convert $minv \
232                    -context $units -to $units -units off]
233                set convMinVal [Rappture::Units::convert \
234                    $itk_option(-minvalue) -to $nvUnits]
235            } else {
236                set newval [format "%g" $newval]
237            }
238           
239            # fix for the case when the user tries to
240            # compare values like minv=-500 nv=-0600
241            set nv [format "%g" $nv]
242            set minv [format "%g" $minv]
243
244            if {$nv < $minv} {
245                error "minimum value allowed here is $convMinVal"
246            }
247        }
248
249        if {"" != $itk_option(-maxvalue)} {
250            set convMaxVal [set maxv $itk_option(-maxvalue)]
251            if {$units != ""} {
252                set maxv [Rappture::Units::convert $maxv \
253                    -context $units -to $units -units off]
254                set convMaxVal [Rappture::Units::convert \
255                    $itk_option(-maxvalue) -to $nvUnits]
256            } else {
257                set newval [format "%g" $newval]
258            }
259
260            # fix for the case when the user tries to
261            # compare values like maxv=500 nv=0600
262            set nv [format "%g" $nv]
263            set maxv [format "%g" $maxv]
264
265            if {$nv > $maxv} {
266                error "maximum value allowed here is $convMaxVal"
267            }
268        }
269
270        switch -- $itk_option(-type) {
271            integer {
272                if {![string is integer -strict $nv]} {
273                    error "Should be an integer value"
274                }
275            }
276            real {
277                if {![string is double -strict $nv]} {
278                    error "Should be a real number"
279                }
280            }
281        }
282
283        if {$onlycheck} {
284            return
285        }
286        set _value $newval
287        _redraw
288        event generate $itk_component(hull) <<Value>>
289
290    } elseif {[llength $args] != 0} {
291        error "wrong # args: should be \"value ?-check? ?newval?\""
292    }
293    return $_value
294}
295
296# ----------------------------------------------------------------------
297# USAGE: edit cut
298# USAGE: edit copy
299# USAGE: edit paste
300#
301# Used internally to handle cut/copy/paste operations for the current
302# value.  Usually invoked by <<Cut>>, <<Copy>>, <<Paste>> events, but
303# can also be called directly through this method.
304# ----------------------------------------------------------------------
305itcl::body Rappture::Gauge::edit {option} {
306    if {$itk_option(-state) == "disabled"} {
307        return  ;# disabled? then bail out here!
308    }
309    switch -- $option {
310        cut {
311            edit copy
312            _editor popup
313            $itk_component(editor) value ""
314            $itk_component(editor) deactivate
315        }
316        copy {
317            clipboard clear
318            clipboard append $_value
319        }
320        paste {
321            _editor popup
322            $itk_component(editor) value [clipboard get]
323            $itk_component(editor) deactivate
324        }
325        default {
326            error "bad option \"$option\": should be cut, copy, paste"
327        }
328    }
329}
330
331# ----------------------------------------------------------------------
332# USAGE: bump <delta>
333#
334# Changes the current value up/down by the <delta> value.  Used
335# internally by the up/down spinner buttons when the value is
336# -type integer.
337# ----------------------------------------------------------------------
338itcl::body Rappture::Gauge::bump {delta} {
339    set val $_value
340    if {$val == ""} {
341        set val 0
342    }
343    if {[catch {value [expr {$val+$delta}]} result]} {
344        if {[regexp {allowed here is (.+)} $result match newval]} {
345            set _value $newval
346            $itk_component(value) configure -text $newval
347        }
348        if {[regexp {^bad.*: +(.)(.+)} $result match first tail]
349              || [regexp {(.)(.+)} $result match first tail]} {
350            set result "[string toupper $first]$tail"
351        }
352        bell
353        Rappture::Tooltip::cue $itk_component(value) $result
354        return 0
355    }
356}
357
358# ----------------------------------------------------------------------
359# USAGE: _redraw
360#
361# Used internally to redraw the gauge on the internal canvas based
362# on the current value and the size of the widget.  In this simple
363# base class, the gauge is drawn as a colored block, with an optional
364# image in the middle of it.
365# ----------------------------------------------------------------------
366itcl::body Rappture::Gauge::_redraw {} {
367    set c $itk_component(icon)
368    set w [winfo width $c]
369    set h [winfo height $c]
370
371    if {"" == [$c find all]} {
372        # first time around, create the items
373        $c create rectangle 0 0 1 1 -outline black -tags block
374        $c create image 0 0 -anchor center -image "" -tags bimage
375        $c create rectangle 0 0 1 1 -outline "" -fill "" -stipple gray50 -tags screen
376    }
377
378    if {"" != $itk_option(-spectrum)} {
379        set color [$itk_option(-spectrum) get $_value]
380    } else {
381        set color ""
382    }
383
384    # update the items based on current values
385    $c coords block 0 0 [expr {$w-1}] [expr {$h-1}]
386    $c coords screen 0 0 $w $h
387    $c itemconfigure block -fill $color
388
389    $c coords bimage [expr {0.5*$w}] [expr {0.5*$h}]
390
391    if {$itk_option(-state) == "disabled"} {
392        $c itemconfigure screen -fill white
393    } else {
394        $c itemconfigure screen -fill ""
395    }
396}
397
398# ----------------------------------------------------------------------
399# USAGE: _resize
400#
401# Used internally to resize the internal canvas based on the -image
402# option or the size of the text.
403# ----------------------------------------------------------------------
404itcl::body Rappture::Gauge::_resize {} {
405    set w 0
406    set h 0
407
408    if {"" != $itk_option(-image) || "" != $itk_option(-spectrum)} {
409        if {$itk_option(-samplewidth) > 0} {
410            set w $itk_option(-samplewidth)
411        } else {
412            if {$itk_option(-image) != ""} {
413                set w [expr {[image width $itk_option(-image)]+4}]
414            } else {
415                set w [winfo reqheight $itk_component(value)]
416            }
417        }
418
419        if {$itk_option(-sampleheight) > 0} {
420            set h $itk_option(-sampleheight)
421        } else {
422            if {$itk_option(-image) != ""} {
423                set h [expr {[image height $itk_option(-image)]+4}]
424            } else {
425                set h [winfo reqheight $itk_component(value)]
426            }
427        }
428    }
429
430    if {$w > 0 && $h > 0} {
431        $itk_component(icon) configure -width $w -height $h
432    }
433}
434
435# ----------------------------------------------------------------------
436# USAGE: _hilite <component> <state>
437#
438# Used internally to resize the internal canvas based on the -image
439# option or the size of the text.
440# ----------------------------------------------------------------------
441itcl::body Rappture::Gauge::_hilite {comp state} {
442    if {$itk_option(-state) == "disabled"} {
443        set state 0  ;# disabled? then don't hilite
444    }
445    if {$comp == "value" && !$itk_option(-editable)} {
446        $itk_component(value) configure -relief flat
447        return
448    }
449
450    if {$state} {
451        $itk_component($comp) configure -relief solid
452    } else {
453        $itk_component($comp) configure -relief flat
454    }
455}
456
457# ----------------------------------------------------------------------
458# USAGE: _editor popup
459# USAGE: _editor activate
460# USAGE: _editor validate <value>
461# USAGE: _editor apply <value>
462# USAGE: _editor menu <rootx> <rooty>
463#
464# Used internally to handle the various functions of the pop-up
465# editor for the value of this gauge.
466# ----------------------------------------------------------------------
467itcl::body Rappture::Gauge::_editor {option args} {
468    if {$itk_option(-state) == "disabled"} {
469        return  ;# disabled? then bail out here!
470    }
471    switch -- $option {
472        popup {
473            if {$itk_option(-editable)} {
474                $itk_component(editor) activate
475            }
476        }
477        activate {
478            return [list text $_value \
479                x [winfo rootx $itk_component(value)] \
480                y [winfo rooty $itk_component(value)] \
481                w [winfo width $itk_component(value)] \
482                h [winfo height $itk_component(value)]]
483        }
484        validate {
485            if {[llength $args] != 1} {
486                error "wrong # args: should be \"_editor validate val\""
487            }
488            set val [lindex $args 0]
489
490            if {[catch {value -check $val} result]} {
491                if {[regexp {allowed here is (.+)} $result match newval]} {
492                    $itk_component(editor) value $newval
493                }
494                if {[regexp {^bad.*: +(.)(.+)} $result match first tail]
495                      || [regexp {(.)(.+)} $result match first tail]} {
496                    set result "[string toupper $first]$tail"
497                }
498                bell
499                Rappture::Tooltip::cue $itk_component(editor) $result
500                return 0
501            }
502        }
503        apply {
504            if {[llength $args] != 1} {
505                error "wrong # args: should be \"_editor apply val\""
506            }
507            value [lindex $args 0]
508        }
509        menu {
510            eval tk_popup $itk_component(emenu) $args
511        }
512        default {
513            error "bad option \"$option\": should be popup, activate, validate, apply, and menu"
514        }
515    }
516}
517
518# ----------------------------------------------------------------------
519# USAGE: _presets post
520# USAGE: _presets unpost
521# USAGE: _presets select
522#
523# Used internally to handle the list of presets for this gauge.  The
524# post/unpost options are invoked when the list is posted or unposted
525# to manage the relief of the controlling button.  The select option
526# is invoked whenever there is a selection from the list, to assign
527# the value back to the gauge.
528# ----------------------------------------------------------------------
529itcl::body Rappture::Gauge::_presets {option} {
530    switch -- $option {
531        post {
532            set i [$itk_component(presetlist) index $_value]
533            if {$i >= 0} {
534                $itk_component(presetlist) select clear 0 end
535                $itk_component(presetlist) select set $i
536            }
537            after 10 [list $itk_component(presets) configure -relief sunken]
538        }
539        unpost {
540            $itk_component(presets) configure -relief flat
541        }
542        select {
543            set val [$itk_component(presetlist) current]
544            if {"" != $val} {
545                value $val
546            }
547        }
548        default {
549            error "bad option \"$option\": should be post, unpost, select"
550        }
551    }
552}
553
554# ----------------------------------------------------------------------
555# USAGE: _layout
556#
557# Used internally to fix the layout of widgets whenever there is a
558# change in the options that affect layout.  Puts the value in the
559# proper position according to the -valueposition option.  Also,
560# adds or removes the icon if it needs to be shown.
561# ----------------------------------------------------------------------
562itcl::body Rappture::Gauge::_layout {} {
563    foreach w [pack slaves $itk_component(hull)] {
564        pack forget $w
565    }
566
567    array set side2anchor {
568        left   e
569        right  w
570        top    s
571        bottom n
572    }
573    set pos $itk_option(-valueposition)
574    pack $itk_component(vframe) -side $pos \
575        -expand yes -fill both -ipadx 2
576    $itk_component(value) configure -anchor $side2anchor($pos)
577
578    if {"" != $itk_option(-image) || "" != $itk_option(-spectrum)} {
579        pack $itk_component(icon) -side $pos
580    }
581}
582
583# ----------------------------------------------------------------------
584# CONFIGURATION OPTION: -editable
585# ----------------------------------------------------------------------
586itcl::configbody Rappture::Gauge::editable {
587    if {![string is boolean -strict $itk_option(-editable)]} {
588        error "bad value \"$itk_option(-editable)\": should be boolean"
589    }
590    if {!$itk_option(-editable) && [winfo ismapped $itk_component(editor)]} {
591        $itk_component(editor) deactivate -abort
592    }
593}
594
595# ----------------------------------------------------------------------
596# CONFIGURATION OPTION: -state
597# ----------------------------------------------------------------------
598itcl::configbody Rappture::Gauge::state {
599    set valid {normal disabled}
600    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
601        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
602    }
603    $itk_component(value) configure -state $itk_option(-state)
604    $itk_component(spinup) configure -state $itk_option(-state)
605    $itk_component(spindn) configure -state $itk_option(-state)
606    $itk_component(presets) configure -state $itk_option(-state)
607    _redraw  ;# fix gauge
608}
609
610# ----------------------------------------------------------------------
611# CONFIGURATION OPTION: -spectrum
612# ----------------------------------------------------------------------
613itcl::configbody Rappture::Gauge::spectrum {
614    if {$itk_option(-spectrum) != ""
615          && ([catch {$itk_option(-spectrum) isa ::Rappture::Spectrum} valid]
616               || !$valid)} {
617        error "bad option \"$itk_option(-spectrum)\": should be Rappture::Spectrum object"
618    }
619    _resize
620    _layout
621    _redraw
622}
623
624# ----------------------------------------------------------------------
625# CONFIGURATION OPTION: -image
626# ----------------------------------------------------------------------
627itcl::configbody Rappture::Gauge::image {
628    if {$itk_option(-image) != ""
629          && [catch {image width $itk_option(-image)}]} {
630        error "bad value \"$itk_option(-image)\": should be Tk image"
631    }
632    _resize
633    _layout
634    $itk_component(icon) itemconfigure bimage -image $itk_option(-image)
635}
636
637# ----------------------------------------------------------------------
638# CONFIGURATION OPTION: -units
639# ----------------------------------------------------------------------
640itcl::configbody Rappture::Gauge::units {
641    if {$itk_option(-units) != ""
642          && [::Rappture::Units::System::for $itk_option(-units)] == ""} {
643        error "unrecognized system of units \"$itk_option(-units)\""
644    }
645}
646
647# ----------------------------------------------------------------------
648# CONFIGURATION OPTION: -valueposition
649# ----------------------------------------------------------------------
650itcl::configbody Rappture::Gauge::valueposition {
651    set pos $itk_option(-valueposition)
652    set opts {left right top bottom}
653    if {[lsearch -exact $opts $pos] < 0} {
654        error "bad value \"$pos\": should be [join $opts {, }]"
655    }
656    _layout
657}
658
659# ----------------------------------------------------------------------
660# CONFIGURATION OPTION: -presets
661# ----------------------------------------------------------------------
662itcl::configbody Rappture::Gauge::presets {
663    if {"" == $itk_option(-presets)} {
664        pack forget $itk_component(presets)
665    } else {
666        if {$itk_option(-valueposition) == "left"} {
667            set s "left"
668        } else {
669            set s "right"
670        }
671        set first [lindex [pack slaves $itk_component(vframe)] 0]
672        pack $itk_component(presets) -before $first -side $s -fill y
673
674        $itk_component(presetlist) delete 0 end
675        $itk_component(presetlist) insert end $itk_option(-presets)
676    }
677}
678
679# ----------------------------------------------------------------------
680# CONFIGURATION OPTION: -type
681# ----------------------------------------------------------------------
682itcl::configbody Rappture::Gauge::type {
683    switch -- $itk_option(-type) {
684        integer {
685            set first [lindex [pack slaves $itk_component(vframe)] 0]
686            if {$first == $itk_component(presets)} {
687                pack $itk_component(spinner) -after $first -side left -fill y
688            } else {
689                pack $itk_component(spinner) -before $first -side right -fill y
690            }
691        }
692        real {
693            pack forget $itk_component(spinner)
694        }
695        default {
696            error "bad number type \"$itk_option(-type)\": should be integer or real"
697        }
698    }
699}
Note: See TracBrowser for help on using the repository browser.