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

Last change on this file since 116 was 115, checked in by mmc, 19 years ago

Updated all copyright notices.
File size: 21.5 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 -spectrum spectrum Spectrum ""
30    itk_option define -type type Type "real"
31    itk_option define -units units Units ""
32    itk_option define -minvalue minValue MinValue ""
33    itk_option define -maxvalue maxValue MaxValue ""
34    itk_option define -presets presets Presets ""
35    itk_option define -valueposition valuePosition ValuePosition ""
36    itk_option define -image image Image ""
37    itk_option define -samplewidth sampleWidth SampleWidth 0
38    itk_option define -sampleheight sampleHeight SampleHeight 0
39
40    constructor {args} { # defined below }
41
42    public method value {args}
43    public method edit {option}
44    public method bump {delta}
45
46    protected method _redraw {}
47    protected method _resize {}
48    protected method _hilite {comp state}
49    protected method _editor {option args}
50    protected method _presets {option}
51    protected method _layout {}
52
53    private variable _value 0  ;# value for this widget
54
55    blt::bitmap define GaugeArrow-up {
56        #define up_width 8
57        #define up_height 4
58        static unsigned char up_bits[] = {
59           0x10, 0x38, 0x7c, 0xfe};
60    }
61    blt::bitmap define GaugeArrow-down {
62        #define arrow_width 8
63        #define arrow_height 4
64        static unsigned char arrow_bits[] = {
65           0xfe, 0x7c, 0x38, 0x10};
66    }
67
68    blt::bitmap define GaugeArrow {
69        #define arrow_width 9
70        #define arrow_height 4
71        static unsigned char arrow_bits[] = {
72           0x7f, 0x00, 0x3e, 0x00, 0x1c, 0x00, 0x08, 0x00};
73    }
74}
75                                                                               
76itk::usual Gauge {
77    keep -cursor -font -foreground -background
78    keep -selectbackground -selectforeground -selectborderwidth
79}
80
81# ----------------------------------------------------------------------
82# CONSTRUCTOR
83# ----------------------------------------------------------------------
84itcl::body Rappture::Gauge::constructor {args} {
85    itk_component add icon {
86        canvas $itk_interior.icon -width 1 -height 1 \
87            -borderwidth 0 -highlightthickness 0
88    } {
89        usual
90        ignore -highlightthickness -highlightbackground -highlightcolor
91    }
92    pack $itk_component(icon) -side left
93    bind $itk_component(icon) <Configure> [itcl::code $this _redraw]
94
95    itk_component add -protected vframe {
96        frame $itk_interior.vframe
97    }
98
99    itk_component add value {
100        label $itk_component(vframe).value -borderwidth 1 -width 7 \
101            -textvariable [itcl::scope _value]
102    } {
103        rename -background -textbackground textBackground Background
104    }
105    pack $itk_component(value) -side left -expand yes -fill both
106
107    bind $itk_component(value) <Enter> [itcl::code $this _hilite value on]
108    bind $itk_component(value) <Leave> [itcl::code $this _hilite value off]
109
110    bind $itk_component(value) <<Cut>> [itcl::code $this edit cut]
111    bind $itk_component(value) <<Copy>> [itcl::code $this edit copy]
112    bind $itk_component(value) <<Paste>> [itcl::code $this edit paste]
113
114    itk_component add emenu {
115        menu $itk_component(value).menu -tearoff 0
116    } {
117        usual
118        ignore -tearoff
119    }
120    $itk_component(emenu) add command -label "Cut" -accelerator "^X" \
121        -command [list event generate $itk_component(value) <<Cut>>]
122    $itk_component(emenu) add command -label "Copy" -accelerator "^C" \
123        -command [list event generate $itk_component(value) <<Copy>>]
124    $itk_component(emenu) add command -label "Paste" -accelerator "^V" \
125        -command [list event generate $itk_component(value) <<Paste>>]
126    bind $itk_component(value) <<PopupMenu>> {
127        tk_popup %W.menu %X %Y
128    }
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        set newval [set nv [lindex $args 0]]
216        set units $itk_option(-units)
217        if {$units != ""} {
218            set newval [Rappture::Units::convert $newval \
219                -context $units]
220            set nv [Rappture::Units::convert $nv \
221                -context $units -to $units -units off]
222        }
223
224        if {"" != $itk_option(-minvalue)} {
225            set minv $itk_option(-minvalue)
226            if {$units != ""} {
227                set minv [Rappture::Units::convert $minv \
228                    -context $units -to $units -units off]
229            }
230            if {$nv < $minv} {
231                error "minimum value allowed here is $itk_option(-minvalue)"
232            }
233        }
234
235        if {"" != $itk_option(-maxvalue)} {
236            set maxv $itk_option(-maxvalue)
237            if {$units != ""} {
238                set maxv [Rappture::Units::convert $maxv \
239                    -context $units -to $units -units off]
240            }
241            if {$nv > $maxv} {
242                error "maximum value allowed here is $itk_option(-maxvalue)"
243            }
244        }
245
246        switch -- $itk_option(-type) {
247            integer {
248                if {![string is integer -strict $nv]} {
249                    error "Should be an integer value"
250                }
251            }
252            real {
253                if {![string is double -strict $nv]} {
254                    error "Should be a real number"
255                }
256            }
257        }
258
259        if {$onlycheck} {
260            return
261        }
262        set _value $newval
263        _redraw
264        event generate $itk_component(hull) <<Value>>
265
266    } elseif {[llength $args] != 0} {
267        error "wrong # args: should be \"value ?-check? ?newval?\""
268    }
269    return $_value
270}
271
272# ----------------------------------------------------------------------
273# USAGE: edit cut
274# USAGE: edit copy
275# USAGE: edit paste
276#
277# Used internally to handle cut/copy/paste operations for the current
278# value.  Usually invoked by <<Cut>>, <<Copy>>, <<Paste>> events, but
279# can also be called directly through this method.
280# ----------------------------------------------------------------------
281itcl::body Rappture::Gauge::edit {option} {
282    switch -- $option {
283        cut {
284            edit copy
285            _editor popup
286            $itk_component(editor) value ""
287            $itk_component(editor) deactivate
288        }
289        copy {
290            clipboard clear
291            clipboard append $_value
292        }
293        paste {
294            _editor popup
295            $itk_component(editor) value [clipboard get]
296            $itk_component(editor) deactivate
297        }
298        default {
299            error "bad option \"$option\": should be cut, copy, paste"
300        }
301    }
302}
303
304# ----------------------------------------------------------------------
305# USAGE: bump <delta>
306#
307# Changes the current value up/down by the <delta> value.  Used
308# internally by the up/down spinner buttons when the value is
309# -type integer.
310# ----------------------------------------------------------------------
311itcl::body Rappture::Gauge::bump {delta} {
312    set val $_value
313    if {$val == ""} {
314        set val 0
315    }
316    value [expr {$val+$delta}]
317}
318
319# ----------------------------------------------------------------------
320# USAGE: _redraw
321#
322# Used internally to redraw the gauge on the internal canvas based
323# on the current value and the size of the widget.  In this simple
324# base class, the gauge is drawn as a colored block, with an optional
325# image in the middle of it.
326# ----------------------------------------------------------------------
327itcl::body Rappture::Gauge::_redraw {} {
328    set c $itk_component(icon)
329    set w [winfo width $c]
330    set h [winfo height $c]
331
332    if {"" == [$c find all]} {
333        # first time around, create the items
334        $c create rectangle 0 0 1 1 -outline black -tags block
335        $c create image 0 0 -anchor center -image "" -tags bimage
336    }
337
338    if {"" != $itk_option(-spectrum)} {
339        set color [$itk_option(-spectrum) get $_value]
340    } else {
341        set color ""
342    }
343
344    # update the items based on current values
345    $c coords block 0 0 [expr {$w-1}] [expr {$h-1}]
346    $c itemconfigure block -fill $color
347
348    $c coords bimage [expr {0.5*$w}] [expr {0.5*$h}]
349}
350
351# ----------------------------------------------------------------------
352# USAGE: _resize
353#
354# Used internally to resize the internal canvas based on the -image
355# option or the size of the text.
356# ----------------------------------------------------------------------
357itcl::body Rappture::Gauge::_resize {} {
358    set w 0
359    set h 0
360
361    if {"" != $itk_option(-image) || "" != $itk_option(-spectrum)} {
362        if {$itk_option(-samplewidth) > 0} {
363            set w $itk_option(-samplewidth)
364        } else {
365            if {$itk_option(-image) != ""} {
366                set w [expr {[image width $itk_option(-image)]+4}]
367            } else {
368                set w [winfo reqheight $itk_component(value)]
369            }
370        }
371
372        if {$itk_option(-sampleheight) > 0} {
373            set h $itk_option(-sampleheight)
374        } else {
375            if {$itk_option(-image) != ""} {
376                set h [expr {[image height $itk_option(-image)]+4}]
377            } else {
378                set h [winfo reqheight $itk_component(value)]
379            }
380        }
381    }
382
383    if {$w > 0 && $h > 0} {
384        $itk_component(icon) configure -width $w -height $h
385    }
386}
387
388# ----------------------------------------------------------------------
389# USAGE: _hilite <component> <state>
390#
391# Used internally to resize the internal canvas based on the -image
392# option or the size of the text.
393# ----------------------------------------------------------------------
394itcl::body Rappture::Gauge::_hilite {comp state} {
395    if {$comp == "value" && !$itk_option(-editable)} {
396        $itk_component(value) configure -relief flat
397        return
398    }
399
400    if {$state} {
401        $itk_component($comp) configure -relief solid
402    } else {
403        $itk_component($comp) configure -relief flat
404    }
405}
406
407# ----------------------------------------------------------------------
408# USAGE: _editor popup
409# USAGE: _editor activate
410# USAGE: _editor validate <value>
411# USAGE: _editor apply <value>
412#
413# Used internally to handle the various functions of the pop-up
414# editor for the value of this gauge.
415# ----------------------------------------------------------------------
416itcl::body Rappture::Gauge::_editor {option args} {
417    switch -- $option {
418        popup {
419            if {$itk_option(-editable)} {
420                $itk_component(editor) activate
421            }
422        }
423        activate {
424            return [list text $_value \
425                x [winfo rootx $itk_component(value)] \
426                y [winfo rooty $itk_component(value)] \
427                w [winfo width $itk_component(value)] \
428                h [winfo height $itk_component(value)]]
429        }
430        validate {
431            if {[llength $args] != 1} {
432                error "wrong # args: should be \"_editor validate val\""
433            }
434            set val [lindex $args 0]
435
436            if {[catch {value -check $val} result]} {
437                if {[regexp {allowed here is (.+)} $result match newval]} {
438                    $itk_component(editor) value $newval
439                }
440                if {[regexp {^bad.*: +(.)(.+)} $result match first tail]
441                      || [regexp {(.)(.+)} $result match first tail]} {
442                    set result "[string toupper $first]$tail"
443                }
444                bell
445                Rappture::Tooltip::cue $itk_component(editor) $result
446                return 0
447            }
448        }
449        apply {
450            if {[llength $args] != 1} {
451                error "wrong # args: should be \"_editor apply val\""
452            }
453            value [lindex $args 0]
454        }
455        default {
456            error "bad option \"$option\": should be popup, activate, validate, apply"
457        }
458    }
459}
460
461# ----------------------------------------------------------------------
462# USAGE: _presets post
463# USAGE: _presets unpost
464# USAGE: _presets select
465#
466# Used internally to handle the list of presets for this gauge.  The
467# post/unpost options are invoked when the list is posted or unposted
468# to manage the relief of the controlling button.  The select option
469# is invoked whenever there is a selection from the list, to assign
470# the value back to the gauge.
471# ----------------------------------------------------------------------
472itcl::body Rappture::Gauge::_presets {option} {
473    switch -- $option {
474        post {
475            set i [$itk_component(presetlist) index $_value]
476            if {$i >= 0} {
477                $itk_component(presetlist) select clear 0 end
478                $itk_component(presetlist) select set $i
479            }
480            after 10 [list $itk_component(presets) configure -relief sunken]
481        }
482        unpost {
483            $itk_component(presets) configure -relief flat
484        }
485        select {
486            set val [$itk_component(presetlist) current]
487            if {"" != $val} {
488                value $val
489            }
490        }
491        default {
492            error "bad option \"$option\": should be post, unpost, select"
493        }
494    }
495}
496
497# ----------------------------------------------------------------------
498# USAGE: _layout
499#
500# Used internally to fix the layout of widgets whenever there is a
501# change in the options that affect layout.  Puts the value in the
502# proper position according to the -valueposition option.  Also,
503# adds or removes the icon if it needs to be shown.
504# ----------------------------------------------------------------------
505itcl::body Rappture::Gauge::_layout {} {
506    foreach w [pack slaves $itk_component(hull)] {
507        pack forget $w
508    }
509
510    array set side2anchor {
511        left   e
512        right  w
513        top    s
514        bottom n
515    }
516    set pos $itk_option(-valueposition)
517    pack $itk_component(vframe) -side $pos \
518        -expand yes -fill both -ipadx 2
519    $itk_component(value) configure -anchor $side2anchor($pos)
520
521    if {"" != $itk_option(-image) || "" != $itk_option(-spectrum)} {
522        pack $itk_component(icon) -side $pos
523    }
524}
525
526# ----------------------------------------------------------------------
527# CONFIGURATION OPTION: -editable
528# ----------------------------------------------------------------------
529itcl::configbody Rappture::Gauge::editable {
530    if {![string is boolean -strict $itk_option(-editable)]} {
531        error "bad value \"$itk_option(-editable)\": should be boolean"
532    }
533    if {!$itk_option(-editable) && [winfo ismapped $itk_component(editor)]} {
534        $itk_component(editor) deactivate -abort
535    }
536}
537
538# ----------------------------------------------------------------------
539# CONFIGURATION OPTION: -spectrum
540# ----------------------------------------------------------------------
541itcl::configbody Rappture::Gauge::spectrum {
542    if {$itk_option(-spectrum) != ""
543          && ([catch {$itk_option(-spectrum) isa ::Rappture::Spectrum} valid]
544               || !$valid)} {
545        error "bad option \"$itk_option(-spectrum)\": should be Rappture::Spectrum object"
546    }
547    _resize
548    _layout
549    _redraw
550}
551
552# ----------------------------------------------------------------------
553# CONFIGURATION OPTION: -image
554# ----------------------------------------------------------------------
555itcl::configbody Rappture::Gauge::image {
556    if {$itk_option(-image) != ""
557          && [catch {image width $itk_option(-image)}]} {
558        error "bad value \"$itk_option(-image)\": should be Tk image"
559    }
560    _resize
561    _layout
562    $itk_component(icon) itemconfigure bimage -image $itk_option(-image)
563}
564
565# ----------------------------------------------------------------------
566# CONFIGURATION OPTION: -units
567# ----------------------------------------------------------------------
568itcl::configbody Rappture::Gauge::units {
569    if {$itk_option(-units) != ""
570          && [::Rappture::Units::System::for $itk_option(-units)] == ""} {
571        error "unrecognized system of units \"$itk_option(-units)\""
572    }
573}
574
575# ----------------------------------------------------------------------
576# CONFIGURATION OPTION: -valueposition
577# ----------------------------------------------------------------------
578itcl::configbody Rappture::Gauge::valueposition {
579    set pos $itk_option(-valueposition)
580    set opts {left right top bottom}
581    if {[lsearch -exact $opts $pos] < 0} {
582        error "bad value \"$pos\": should be [join $opts {, }]"
583    }
584    _layout
585}
586
587# ----------------------------------------------------------------------
588# CONFIGURATION OPTION: -presets
589# ----------------------------------------------------------------------
590itcl::configbody Rappture::Gauge::presets {
591    if {"" == $itk_option(-presets)} {
592        pack forget $itk_component(presets)
593    } else {
594        if {$itk_option(-valueposition) == "left"} {
595            set s "left"
596        } else {
597            set s "right"
598        }
599        set first [lindex [pack slaves $itk_component(vframe)] 0]
600        pack $itk_component(presets) -before $first -side $s -fill y
601
602        $itk_component(presetlist) delete 0 end
603        $itk_component(presetlist) insert end $itk_option(-presets)
604    }
605}
606
607# ----------------------------------------------------------------------
608# CONFIGURATION OPTION: -type
609# ----------------------------------------------------------------------
610itcl::configbody Rappture::Gauge::type {
611    switch -- $itk_option(-type) {
612        integer {
613            set first [lindex [pack slaves $itk_component(vframe)] 0]
614            if {$first == $itk_component(presets)} {
615                pack $itk_component(spinner) -after $first -side left -fill y
616            } else {
617                pack $itk_component(spinner) -before $first -side right -fill y
618            }
619        }
620        real {
621            pack forget $itk_component(spinner)
622        }
623        default {
624            error "bad number type \"$itk_option(-type)\": should be integer or real"
625        }
626    }
627}
Note: See TracBrowser for help on using the repository browser.