The code below is a further improvement from a meter that originally appeared on the french wiki [
1]. I modified it twice to suit my needs and ended up feeling that it would perhaps benefit to a larger audience if posted here. Check out the original page for some screen dumps. Apart from some bug fixing, I have added two features to the original code:
- The ability to automatically add labels showing the current value of the meter, together with its minimum and maximum possible value. This is in order to let the user understand the scale of the display.
- The ability to have active minimum and maximum needle that will record the minimum and maximum values since a given time. These values can be retrieved.
The honour is not mine, I am only an humble modifier.
EF
if {[info exists ::meter::version]} { return }
namespace eval ::meter {
# beginning of ::meter namespace definition
# ####################################
#
# meter widget
#
variable version 1.2
#
# ulis, (C) 2005
# Emmanuel Frecon, (C) 2006
#
# ------------------------------------
# ####################################
# ==========================
#
# package
#
# ==========================
package provide ASimpleMeter $version
package require Tk
# ====================
#
# entry point
#
# ====================
namespace export meter
# ====================
#
# global variables. Current recognised options for a meter
# widget are the following:
#
# -bd is the border around the meter
# -bg is the color to use for the background
# -cmd is a command that can periodically be called to update the
# value of a meter widget. Any occurence of the string %widget%
# will be replaced by the path to the widget.
# -gcolor is the color of the meter gauge background
# -font is the font to use when showing meter values
# -height is the height of the widget
# -max is the maximum value represented by the meter
# -min is the minimum value represented by the meter
# -maxcolor is the color of the maximum needle, empty to disable.
# -mincolor is the color of the minimum needle, empty to disable.
# -mcolor is the color of the min/max text labels.
# -ncolor is the color of the main needle.
# -relief is the relief of the widget
# -sections is a list of sections on the gauge display. Each
# section is a list with the value at which it starts, its amount
# (in value space) and its color.
# -showval is a boolean telling whether to show labels on the meter or not
# -vcolor is the color of the current meter label value, when appropriate
# -width is the width of the meter
#
# ====================
variable {}
array set {} {
-bd 1
-bg ""
-cmd ""
-delay 100
-gcolor green
-font "Helvetica 8"
-height 50
-max 100
-maxcolor blue
-mincolor blue
-mcolor grey75
-min 0
-ncolor orange
-relief groove
-sections {{75 25 red}}
-showval on
-vcolor black
-width 100
}
}
# ::meter::meter -- Create, get or set options
#
# This procedure is able to either set or get the default
# options for the meter module, or to create a new meter,
# depending on its arguments.
#
# Arguments:
# args get as a first argument to get a default option, set to set it,
# otherwise the name of a widget followed by its options.
#
# Results:
# Return the value of the option or the name of the widget,
# depending on the "mode" of the command.
#
# Side Effects:
# None.
proc ::meter::meter {args} {
set rc [catch {
set cmd [lindex $args 0]
switch -glob -- -$cmd {
-get { return [uplevel 1 ::meter::meter:dget $args] }
-set { return [uplevel 1 ::meter::meter:dset $args] }
default {
if {[string index $cmd 0] != "."} {
error "use is 'meter path options' or 'meter set options'\
or 'meter get key'"
}
return [uplevel 1 ::meter::meter:create $args]
}
}
} msg]
if {$rc == 1} { return -code error $msg } else { return $msg }
}
# ::meter::meter:dget -- Get default options
#
# This procedure will get one of the default options for all
# widgets that will be created in the near future.
#
# Arguments:
# get Unused
# args Only the first argument is used, one dash-led option
#
# Results:
# Return the value of the option or an error
#
# Side Effects:
# None.
proc ::meter::meter:dget {get args} {
variable {}
if {[llength $args] != 1} {
return -code error "use is 'meter get key'"
}
set key [lindex $args 0]
switch -glob -- $key {
-bg -
-bac* { set (-bg) }
-bd -
-bor* { set (-bd) }
-cmd -
-com* { set (-command) }
-del* { set (-delay) }
-fon* { set (-font) }
-gco* { set (-gcolor) }
-hei* { set (-height) }
-max { set (-max) }
-maxco* { set (-maxcolor) }
-minco* { set (-mincolor) }
-mco* { set (-mcolor) }
-min* { set (-min) }
-nco* { set (-ncolor) }
-rel* { set (-relief) }
-sec* { set (-sections) }
-sho* { set (-showval) }
-vco* { set (-vcolor) }
-wid* { set (-width) }
default { error "unknown meter default option '$key'" }
}
}
# ::meter::meter:set -- Set a default option
#
# This procedure will set one or several default options for all
# widgets that will be created in the future.
#
# Arguments:
# set Unused
# args List of option values pairs, options are dash-led
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:dset {set args} {
variable {}
if {[llength $args] % 2 != 0} {
error "use is 'meter set \[key value]...'"
}
foreach {key value} $args {
switch -glob -- $key {
-bg -
-bac* { set (-bg) $value }
-bd -
-bor* { set (-bd) $value }
-cmd -
-com* { set (-command) $value }
-del* { set (-delay) $value }
-fon* { set (-font) $value }
-gco* { set (-gcolor) $value }
-hei* { set (-height) $value }
-max { set (-max) $value }
-maxco* { set (-maxcolor) $value }
-minco* { set (-mincolor) $value }
-mco* { set (-mcolor) $value }
-min* { set (-min) $value }
-nco* { set (-ncolor) $value }
-rel* { set (-relief) $value }
-sec* { set (-sections) $value }
-sho* { set (-showval) $value }
-vco* { set (-vcolor) $value }
-wid* { set (-width) $value }
default { error "unknown meter default option '$key'" }
}
}
}
# ::modname::meter:create -- Create a new meter
#
# This procedure will create a new meter which Tk path is given
# as a first argument. This is a pseudo-widget and the
# procedure also creates a command under the name of the widget
# to operate on the widget, as is usual with Tk.
#
# Arguments:
# w Full Tk path to widget
# args List of option values pairs, options are dash-led
#
# Results:
# Return the Tk path to the widget (its name!)
#
# Side Effects:
# None.
proc ::meter::meter:create {w args} {
variable {}
# initial options
set initial [list]
foreach key [array names {} -*] {
lappend initial $key $($key)
}
# create canvas
canvas $w -highlightt 1
set bg [$w cget -bg]
$w create arc 0 0 0 0 -start 20 -extent 140 \
-style pie -tags [list gauge meter]
$w create arc 0 0 0 0 -start 0 -extent 180 \
-style pie -fill $bg -outline "" -tags bottom
$w create arc 0 0 0 0 -extent 0 -width 2 -start 160 \
-style pie -tags needle
$w create arc 0 0 0 0 -extent 0 -width 1 -start 20 \
-style pie -tags minneedle -state hidden
$w create arc 0 0 0 0 -extent 0 -width 1 -start 160 \
-style pie -tags maxneedle -state hidden
$w create text 0 0 -text "" -tags min
$w create text 0 0 -text "" -tags max
$w create text 0 0 -text "" -tags value
$w raise maxneedle
$w raise minneedle
$w raise needle
$w raise bottom
# build reference
rename $w ::meter::_$w
interp alias {} ::$w {} ::meter::meter:dispatch $w
# set options
meter:stop $w
if {$initial != ""} { uplevel 1 ::meter::meter:config $w $initial }
if {$args != ""} { uplevel 1 ::meter::meter:config $w $args }
# return reference
return $w
}
# ::meter::meter:dispatch -- Dispatch meter operations
#
# This procedure dispatch further operations on a meter widget
# that has previously been created. The procedure implements
# the command that is associated to the widget. The commands
# that are implemented by the meter are cget, configure, get,
# getall, invoke, set, start, stop, reset. Other commands are
# blindly passed further to the canvas that implements the
# widget.
#
# Arguments:
# w Full Tk path to the widget
# args Operation to perform and its arguments.
#
# Results:
# None
#
# Side Effects:
# None.
proc ::meter::meter:dispatch {w args} {
set cmd [lindex $args 0]
set args [lrange $args 1 end]
set rc [catch {
switch -glob -- -$cmd {
-cge* { return [uplevel 1 ::meter::meter:cget $w $args] }
-con* { return [uplevel 1 ::meter::meter:config $w $args] }
-get { return [uplevel 1 ::meter::meter:vget $w $args] }
-getall { return [uplevel 1 ::meter::meter:getall $w $args] }
-reset { return [uplevel 1 ::meter::meter:reset $w $args] }
-inv* { return [uplevel 1 ::meter::meter:invoke $w $args] }
-set { return [uplevel 1 ::meter::meter:vset $w $args] }
-sta* { return [uplevel 1 ::meter::meter:start $w $args] }
-sto* { return [uplevel 1 ::meter::meter:stop $w $args] }
default { return [uplevel 1 ::meter::_$w $cmd $args] }
}
} msg]
if {$rc == 1} { return -code error $msg } else { return $msg }
}
# ::meter::meter:cget -- Get a widget option
#
# This procedure retreives an options that has been set for a
# given meter widget.
#
# Arguments:
# w Full Tk path to the widget
# args Dash-led option to be retrieved.
#
# Results:
# Return the value of the option or an error on unknown options.
#
# Side Effects:
# None.
proc ::meter::meter:cget {w args} {
variable {}
if {[llength $args] != 1} {
error "use is 'path cget key'"
}
set _w ::meter::_$w
set key [lindex $args 0]
switch -glob -- $key {
-cmd -
-com* { set ($w:-command) }
-del* { set ($w:-delay) }
-gco* { set ($w:-gcolor) }
-fon* { set ($w:-font) }
-max { set ($w:-max) }
-maxco* { set ($w:-maxcolor) }
-minco* { set ($w:-mincolor) }
-mco* { set ($w:-mcolor) }
-min* { set ($w:-min) }
-nco* { set ($w:-ncolor) }
-sec* { set ($w:-sections) }
-sho* { set ($w:-showval) }
-vco* { set ($w:-vcolor) }
-var* {
set rc [catch { set ($w:-variable) }]
if {$rc == 1} {
error "meter option -variable value is not defined"
}
}
default { $_w cget $key }
}
}
# ::meter::meter:config -- (re)configure a meter
#
# This procedure (re)configure a widget that has previously been
# created. The new values for the options that are passed in
# the parameters are taken into account and the appearance
# and/or behaviour of the meter is modified accordingly.
#
# Arguments:
# w Full Tk path to the widget
# args New dash-led option and value pairs.
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:config {w args} {
variable {}
if {[llength $args] % 2 != 0} {
error "use is 'path config \[key value]...'"
}
set _w ::meter::_$w
set cflag 0
set sflag 0
foreach {key value} $args {
switch -glob -- $key {
-bg -
-bac* {
if {$value == ""} { set value [$_w cget -bg] }
$_w config $key $value
$_w itemconfig bottom -fill $value
}
-hei* -
-wid* { $_w config $key $value; set sflag 1 }
-cmd -
-com* { set ($w:-command) $value }
-del* { set ($w:-delay) $value }
-gco* {
set ($w:-gcolor) $value
$_w itemconfig gauge -fill $value -outline $value
}
-fon* {
set ($w:-font) $value
$_w itemconfigure min -font $value -justify left -anchor e
$_w itemconfigure max -font $value -justify right -anchor w
$_w itemconfigure value -font $value -justify center \
-anchor center
}
-max { set ($w:-max) $value; set cflag 1 }
-maxco* { set ($w:-maxcolor) $value; set cflag 1 }
-minco* { set ($w:-mincolor) $value; set cflag 1 }
-min* { set ($w:-min) $value; set cflag 1 }
-mco* {
set ($w:-mcolor) $value
$_w itemconfigure min -fill $value
$_w itemconfigure max -fill $value
}
-nco* {
set ($w:-ncolor) $value
$_w itemconfig needle -fill $value -outline $value
}
-sec* { set ($w:-sections) $value; set sflag 1 }
-sho* { set ($w:-showval) $value; set sflag 1 }
-var* {
set ($w:-variable) $value
trace add variable $value write [list ::meter::meter:change $w]
}
-vco* {
set ($w:-vcolor) $value
$_w itemconfigure value -fill $value
}
default { $_w config $key $value }
}
}
if {$cflag} {
set ($w:coef) [expr {140.0 / ($($w:-max) - $($w:-min))}]
}
if {$cflag || $sflag} {
$_w delete section
set width [$_w cget -width]
set height [$_w cget -height]
set coef $($w:coef)
set xb0 0
set xb1 [expr {$width * 0.500}]
set yb0 0
set yb1 [expr {$height * 1.000}]
$_w coords bottom $xb0 $yb0 $xb1 $yb1
set xt0 0
set xt1 [expr {$width * 0.800}]
set yt0 0
set yt1 [expr {$height * 1.600}]
$_w coords gauge $xt0 $yt0 $xt1 $yt1
$_w coords needle $xt0 $yt0 $xt1 $yt1
$_w coords minneedle $xt0 $yt0 $xt1 $yt1
$_w coords maxneedle $xt0 $yt0 $xt1 $yt1
foreach section $($w:-sections) {
foreach {start extent color} $section {
set start [expr {160 - ($start + $extent - $($w:-min)) * $coef}]
set extent [expr {$extent * $coef}]
$_w create arc $xt0 $yt0 $xt1 $yt1 \
-start $start -extent $extent -style pie \
-fill $color -outline $color -tags [list section meter]
}
}
$_w move meter [expr {$width * 0.100}] [expr {$height * 0.200}]
$_w move needle [expr {$width * 0.100}] [expr {$height * 0.200}]
$_w move minneedle [expr {$width * 0.100}] [expr {$height * 0.200}]
$_w move maxneedle [expr {$width * 0.100}] [expr {$height * 0.200}]
$_w move bottom [expr {$width * 0.250}] [expr {$height * 0.500}]
$_w raise minneedle
$_w raise maxneedle
$_w raise needle
$_w raise bottom
if { $($w:-maxcolor) eq "" } {
$_w itemconfigure maxneedle -state hidden
} else {
$_w itemconfigure maxneedle -state normal -fill $($w:-maxcolor) \
-outline $($w:-maxcolor)
}
if { $($w:-mincolor) eq "" } {
$_w itemconfigure minneedle -state hidden
} else {
$_w itemconfigure minneedle -state normal -fill $($w:-mincolor) \
-outline $($w:-mincolor)
}
if { [string is true $($w:-showval)] } {
$_w coords min [expr {0.2*$width}] [expr {0.9*$height}]
$_w coords max [expr {0.8*$width}] [expr {0.9*$height}]
$_w coords value [expr {0.5*$width}] [expr {0.85*$height}]
$_w itemconfigure min -text $($w:-min)
$_w itemconfigure max -text $($w:-max)
$_w itemconfigure value -text "?"
foreach i [list min max value] {
$_w itemconfigure $i -state normal
$_w raise $i
}
} else {
foreach i [list min max value] {
$_w itemconfigure $i -state hidden
}
}
}
}
# ::meter::meter:vget -- Get meter value
#
# This procedure actively computes the current value of a meter.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# Value of the meter
#
# Side Effects:
# None.
proc ::meter::meter:vget {w} {
return [lindex [meter:getall $w] 1]
}
# ::meter::meter:getall -- Get meter value and min/max
#
# This procedure actively computes the current value of a meter,
# as well as the minimum and maximum that it has reached since
# it was started.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# A list composed of the minimum since start, the current value,
# and the maximum.
#
# Side Effects:
# None.
proc ::meter::meter:getall {w} {
variable {}
set _w ::meter::_$w
set mincurrent [$_w itemcget minneedle -start]
set current [$_w itemcget needle -start]
set maxcurrent [$_w itemcget maxneedle -start]
return [list \
[expr {(160-$mincurrent) / $($w:coef)}] \
[expr {(160-$current) / $($w:coef)}] \
[expr {(160-$maxcurrent) / $($w:coef)}]]
}
# ::meter::meter:needleset -- Set a needle to a value
#
# This procedure moves an existing widget needle to a given value
#
# Arguments:
# w Full Tk path to the widget
# needle Tag of needle to move
# value Value to show
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:needleset {w needle value} {
variable {}
set _w ::meter::_$w
set angle [expr 160 - ($($w:coef) * $value)]
$_w itemconfig $needle -start $angle
}
# ::meter::meter:vset -- Set meter value
#
# This procedure sets the current value shown by the meter and
# automatically registers and updates the minimum and maximum
# values that are associated to the meter.
#
# Arguments:
# w Full Tk path to the widget
# value New value to be shown.
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:vset {w value} {
variable {}
# Get current minimum and maximum and update their needles (and
# underlying values) if necessary.
foreach {min v max} [meter:getall $w] break
if { $value > $max } { meter:needleset $w maxneedle $value }
if { $value < $min } { meter:needleset $w minneedle $value }
# Set main needle in place.
meter:needleset $w needle $value
# Update the text shown.
set _w ::meter::_$w
$_w itemconfig value -text $value
}
# ::meter::meter:reset -- Reset min/max
#
# This procedure will reset the minimum and maximum for the
# widget.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# None
#
# Side Effects:
# None.
proc ::meter::meter:reset {w} {
variable {}
set _w ::meter::_$w
$_w itemconfigure minneedle -start 20
$_w itemconfigure maxneedle -start 160
}
# ::meter::meter:change -- Set value on variable changes
#
# This procedure is a trace callback that sees to automatically
# update the meter whenever the variable that it is associated
# to changes.
#
# Arguments:
# w Full Tk path to the widget
# args Unused
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:change {w args} {
variable {}
::meter::meter:vset $w [set $($w:-variable)]
}
# ::meter::meter:stop -- Stop meter
#
# This procedure stops a given meter to periodically updates
# itself.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:stop {w} {
variable {}
set ($w:stop) 1
}
# ::meter::meter:start -- Start meter
#
# This procedure starts a given meter to periodically updates
# itself.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:start {w} {
variable {}
set ($w:stop) 0
meter:invoke $w
}
# ::meter::meter:invoke -- Invoke bound command
#
# This procedure automatically invoke the command that can be
# associated to a meter so that it will periodically updates
# itself.
#
# Arguments:
# w Full Tk path to the widget
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::meter::meter:invoke {w} {
variable {}
if {$($w:stop)} { return }
set script $($w:-command)
if {$script != ""} {
set map [list %widget% $w]
eval [string map $map $script]
}
after $($w:-delay) ::meter::meter:invoke $w
}
namespace import ::meter::meter
