ulis, 2006-01-03. Un package (relativement) rapidement hacké pour afficher une valeur dynamique sur un vieux cadran à aiguille.
Pourquoi
Pour animer Tk.
Comment
Avec le canvas.
Installation
Utilisation
package require ASimpleNeedle needle .n -text U -var ::val
création d'un widget
needle <path> [<option> <value>]...
récupération d'une valeur par défaut
needle get <option>
modification d'une valeur par défaut
needle set [<option> <value>]...
-background couleur du fond du widget -bg couleur du fond du widget -c:center couleur du pivot de l'aiguille -c:dial couleur du fond du cadran -c:frame couleur du tour de l'écran -c:needle couleur de l'aiguille -c:ridge couleur de l'arête de l'aiguille -centercolor couleur du pivot de l'aiguille -delay délai entre deux invocation du script -dial couleur du fond du cadran -font police du texte -frame couleur du tour de l'écran -max valeur maximale -min valeur minimale -needle couleur de l'aiguille -ridge couleur de l'arête de l'aiguille -script script -size diamètre du cadran -text texte du cadran -variable variable globale contenant la valeur
récupération de la valeur d'une option
<path> cget <option>
modification de la valeur des options
<path> config [<option> <value>]...
récupération de la valeur courante
<path> get
invocation de la commande
<path> invoke
positionnement de l'aiguille
<path> set <value>
démarrage de l'invocation automatique de la commande
<path> start
arrêt de l'invocation automatique de la commande
<path> stop
Package ASimpleNeedle.tcl
if {[info exists ::needle::version]} { return }
namespace eval ::needle \
{
# beginning of ::needle namespace definition
# ####################################
#
# needle widget
#
variable version 1.0
#
# ulis, (C) 2005
#
# ------------------------------------
# ####################################
# ==========================
#
# package
#
# ==========================
package provide ASimpleNeedle $version
package require Tk
# ====================
#
# entry point
#
# ====================
namespace export needle
# ====================
#
# global variables
#
# ====================
variable {}
array set {} \
{
pi 3.14159265
-bg ""
-center gray50
-delay 100
-dial gray95
-frame gray50
-font ""
-min 0
-max 100
-needle red
-ridge #a00000
-script ""
-size 100
-text ""
}
# ====================
#
# needle proc
#
# ====================
proc needle {args} \
{
set rc [catch \
{
set cmd [lindex $args 0]
switch -glob -- -$cmd \
{
-get { return [uplevel 1 ::needle::needle:dget $args] }
-set { return [uplevel 1 ::needle::needle:dset $args] }
default \
{
if {[string index $cmd 0] != "."} \
{ error "use is 'needle path options' or 'needle set options' or 'needle get key'" }
return [uplevel 1 ::needle::needle:create $args]
}
}
} msg]
if {$rc == 1} { return -code error $msg } else { return $msg }
}
# ====================
#
# get proc
#
# ====================
proc needle:dget {get args} \
{
variable {}
if {[llength $args] != 1} \
{ return -code error "use is 'needle get key'" }
set key [lindex $args 0]
switch -glob -- $key \
{
-bg -
-bac* { set (-bg) }
-cen* -
-c:c* { set (-center) }
-dia* -
-c:d* { set (-dial) }
-fra* -
-c:f* { set (-frame) }
-nee* -
-c:n* { set (-needle) }
-rid* -
-c:r* { set (-ridge) }
-del* { set (-delay) }
-fon* { set (-font) }
-max* { set (-max) }
-min* { set (-min) }
-scr* { set (-script) }
-siz* { set (-size) }
-tex* { set (-text) }
default \
{ error "unknown needle default key '$key'" }
}
}
# ====================
#
# set proc
#
# ====================
proc needle:dset {set args} \
{
variable {}
if {[llength $args] % 2 != 0} \
{ error "use is 'needle set \[key value]...'" }
foreach {key value} $args \
{
switch -glob -- $key \
{
-bg -
-bac* { set (-bg) $value }
-cen* -
-c:d* { set (-center) $value }
-dia* -
-c:d* { set (-dial) $value }
-fra* -
-c:f* { set (-frame) $value }
-nee* -
-c:n* { set (-needle) $value }
-rid* -
-c:r* { set (-ridge) $value }
-del* { set (-delay) $value }
-fon* { set (-font) $value }
-max* { set (-max) $value }
-min* { set (-min) $value }
-scr* { set (-script) $value }
-siz* { set (-size) $value }
-tex* { set (-text) $value }
default \
{ error "unknown needle default key '$key'" }
}
}
}
# ====================
#
# create proc
#
# ====================
proc needle:create {w args} \
{
variable {}
# initial options
set initial [list]
foreach key [array names {} -*] \
{ lappend initial $key $($key) }
# create canvas
canvas $w -highlightt 1
$w create oval 0 0 0 0 -tags frame0
$w create text 0 0 -anchor s -tags frame1
$w create arc 0 0 0 0 -style arc -start 45 -extent 90 -tags frame2
$w create line 0 0 0 0 -tags frame3
$w create line 0 0 0 0 -tags frame4
$w create line 0 0 0 0 -tags frame5
$w create line 0 0 0 0 -tags frame6
$w create line 0 0 0 0 -tags frame7
$w create polygon 0 0 0 0 0 0 -tags {left needle}
$w create polygon 0 0 0 0 0 0 -tags {right needle}
$w create line 0 0 0 0 -tags middle
$w create oval 0 0 0 0 -outline "" -tags center
# build reference
rename $w ::needle::_$w
interp alias {} ::$w {} ::needle::needle:dispatch $w
# set options
needle:stop $w
if {$initial != ""} { uplevel 1 ::needle::needle:config $w $initial }
if {$args != ""} { uplevel 1 ::needle::needle:config $w $args }
# return reference
return $w
}
# ====================
#
# dispatch proc
#
# ====================
proc needle:dispatch {w args} \
{
set cmd [lindex $args 0]
set args [lrange $args 1 end]
set rc [catch \
{
switch -glob -- -$cmd \
{
-cge* { return [uplevel 1 ::needle::needle:cget $w $args] }
-con* { return [uplevel 1 ::needle::needle:config $w $args] }
-get { return [uplevel 1 ::needle::needle:vget $w $args] }
-inv* { return [uplevel 1 ::needle::needle:invoke $w $args] }
-set { return [uplevel 1 ::needle::needle:vset $w $args] }
-sta* { return [uplevel 1 ::needle::needle:start $w $args] }
-sto* { return [uplevel 1 ::needle::needle:stop $w $args] }
default \
{ return [uplevel 1 ::needle::_$w $cmd $args] }
}
} msg]
if {$rc == 1} { return -code error $msg } else { return $msg }
}
# ====================
#
# cget proc
#
# ====================
proc needle:cget {w args} \
{
variable {}
if {[llength $args] != 1} \
{ error "use is 'needle cget path key'" }
set _w ::needle::_$w
set key [lindex $args 0]
switch -glob -- $key \
{
-del* { set ($w:-delay) }
-cen* -
-c:c* { set ($w:-dial) }
-dia* -
-c:d* { set ($w:-dial) }
-fra* -
-c:f* { set ($w:-frame) }
-nee* -
-c:n* { set ($w:-needle) }
-rid* -
-c:r* { set ($w:-ridge) }
-fon* { set ($w:-font) }
-max* { set ($w:-max) }
-min* { set ($w:-min) }
-scr* { set ($w:-size) }
-siz* { set ($w:-size) }
-tex* { set ($w:-text) }
-var* \
{
set rc [catch { set ($w:-variable) }]
if {$rc == 1} { error "needle option -variable value is not defined" }
}
default { $_w cget $key }
}
}
# ====================
#
# config proc
#
# ====================
proc needle:config {w args} \
{
puts "needle:config $w {$args}"
variable {}
if {[llength $args] % 2 != 0} \
{ error "use is 'needle config path \[key value]...'" }
set _w ::needle::_$w
set mflag 0
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
}
-cen* -
-c:c* \
{
set ($w:-center) $value
$_w itemconfig center -fill $value
}
-dia* -
-c:d* \
{
set ($w:-dial) $value
$_w itemconfig frame0 -fill $value
}
-fra* -
-c:f* \
{
set ($w:-frame) $value
$_w itemconfig frame0 -outline $value
}
-nee* -
-c:n* \
{
set ($w:-needle) $value
$_w itemconfig needle -fill $value -outline $value
}
-rid* -
-c:r* \
{
set ($w:-ridge) $value
$_w itemconfig middle -fill $value
}
-del* { set ($w:-delay) $value }
-fon* \
{
set ($w:-font) $value
if {$value != ""} { $_w itemconfig frame1 -font $font }
}
-max* { set ($w:-max) $value; set mflag 1 }
-min* { set ($w:-min) $value; set mflag 1 }
-scr* { set ($w:-script) $value }
-siz* { set ($w:-size) $value; set sflag 1 }
-tex* \
{
set ($w:-text) $value
$_w itemconfig frame1 -text $value
}
-var* \
{
set ($w:-variable) $value
trace add variable $value write [list ::needle::needle:change $w]
}
default \
{ $_w config $key $value }
}
}
if {$mflag} \
{
set ($w:value) $($w:-min)
set alpha [expr {135 * 90.0 / ($($w:-max) - $($w:-min))}]
set ro [expr {$alpha * $(pi) / 180.0}]
set ($w:current) $ro
}
if {$mflag || $cflag} \
{
set ($w:coef) [expr {90.0 / ($($w:-max) - $($w:-min))}]
}
if {$sflag} \
{
set pi $(pi)
set size $($w:-size)
set size1 [expr {$size * 0.6}]
set size2 [expr {$size * 0.1}]
set size3 [expr {$size * 0.02}]
set size4 [expr {$size * 0.04}]
set size5 [expr {$size - $size3}]
set size6 [expr {$size * 0.5}]
set sizeb [expr {round($size * 0.25)}]
set xc [expr {$size * 0.5}]
set yc [expr {$size * 0.8}]
set x0 [expr {$xc - $size4}]
set y0 [expr {$yc - $size4}]
set x1 [expr {$xc + $size4}]
set y1 [expr {$yc + $size4}]
set x2 [expr {$xc - $size6}]
set y2 [expr {$yc - $size6}]
set x3 [expr {$xc + $size6}]
set y3 [expr {$yc + $size6}]
$_w config -width $size -height $size
$_w coords frame0 $size3 $size3 $size5 $size5
$_w itemconfig frame0 -width $size3
$_w coords frame1 $xc [expr {$yc - $size4}]
$_w coords frame2 $x2 $y2 $x3 $y3
$_w itemconfig frame2 -width $size4
set y4 [expr {$y2 - 2 * $size4}]
set y5 [expr {$y2 - 2 * $size3}]
$_w coords frame3 $xc $y2 $xc $y4
$_w itemconfig frame3 -width $size3
set ro6 [expr {46 * $pi / 180.0}]
set cos6 [expr {cos($ro6)}]
set sin6 [expr {sin($ro6)}]
set x6 [expr {$xc + $size6 * $cos6}]
set y6 [expr {$yc - $size6 * $sin6}]
set x7 [expr {$xc + ($size6 + 2 * $size4) * $cos6}]
set y7 [expr {$yc - ($size6 + 2 * $size4) * $sin6}]
$_w coords frame4 $x6 $y6 $x7 $y7
$_w itemconfig frame4 -width $size3
set ro8 [expr {134 * $pi / 180.0}]
set cos8 [expr {cos($ro8)}]
set sin8 [expr {sin($ro8)}]
set x8 [expr {$xc + $size6 * $cos8}]
set y8 [expr {$yc - $size6 * $sin8}]
set x9 [expr {$xc + ($size6 + 2 * $size4) * $cos8}]
set y9 [expr {$yc - ($size6 + 2 * $size4) * $sin8}]
$_w coords frame5 $x8 $y8 $x9 $y9
$_w itemconfig frame5 -width $size3
set ro10 [expr {(46 + 21.5) * $pi / 180.0}]
set cos10 [expr {cos($ro10)}]
set sin10 [expr {sin($ro10)}]
set x10 [expr {$xc + $size6 * $cos10}]
set y10 [expr {$yc - $size6 * $sin10}]
set x11 [expr {$xc + ($size6 + 2 * $size4) * $cos10}]
set y11 [expr {$yc - ($size6 + 2 * $size4) * $sin10}]
$_w coords frame6 $x10 $y10 $x11 $y11
$_w itemconfig frame6 -width $size3
set ro12 [expr {(134 - 21.5) * $pi / 180.0}]
set cos12 [expr {cos($ro12)}]
set sin12 [expr {sin($ro12)}]
set x12 [expr {$xc + $size6 * $cos12}]
set y12 [expr {$yc - $size6 * $sin12}]
set x13 [expr {$xc + ($size6 + 2 * $size4) * $cos12}]
set y13 [expr {$yc - ($size6 + 2 * $size4) * $sin12}]
$_w coords frame7 $x12 $y12 $x13 $y13
$_w itemconfig frame7 -width $size3
$_w coords center $x0 $y0 $x1 $y1
if {$($w:-font) == ""} \
{
set actual "[font actual [$_w itemcget frame1 -font]] -size -$sizeb"
set font [eval font create $actual]
$_w itemconfig frame1 -font $font
}
set ($w:xc) $xc
set ($w:yc) $yc
set ($w:size1) $size1
set ($w:size2) $size2
set ($w:size3) $size3
}
if {$mflag || $cflag || $sflag} \
{
needle:vset $w $($w:value)
}
}
# ====================
#
# get proc
#
# ====================
proc needle:vget {w} \
{
variable {}
return $($w:value)
}
# ====================
#
# set proc
#
# ====================
proc needle:vset {w value} \
{
variable {}
catch { after cancel $($w:id) }
set ($w:value) $value
set min $($w:-min)
set max $($w:-max)
set alpha [expr {45 + ($value - $min) * 90.0 / ($max - $min)}]
set ro [expr {$alpha * $(pi) / 180.0}]
set current $($w:current)
set diff [expr {abs($current - $ro)}]
if {$diff < 1.e-7} { return }
set incr [expr {$ro > $current ? 1 : -1}]
set current [expr {$current + $incr * $diff / 2.5}]
set ($w:current) $current
set xc $($w:xc)
set yc $($w:yc)
set size1 $($w:size1)
set size2 $($w:size2)
set size3 $($w:size3)
set cos [expr {cos($current)}]
set sin [expr {sin($current)}]
set xt [expr {$xc - $size1 * $cos}]
set yt [expr {$yc - $size1 * $sin}]
set xb [expr {$xc + $size2 * $cos}]
set yb [expr {$yc + $size2 * $sin}]
set xl [expr {$xc - $size3 * $sin}]
set yl [expr {$yc + $size3 * $cos}]
set xr [expr {$xc + $size3 * $sin}]
set yr [expr {$yc - $size3 * $cos}]
$w coords left $xt $yt $xl $yl $xb $yb
$w coords right $xt $yt $xr $yr $xb $yb
$w coords middle $xt $yt $xb $yb
update
set ($w:id) [after 20 ::needle::needle:vset $w $value]
}
# ====================
#
# change proc
#
# ====================
proc needle:change {w args} \
{
variable {}
::needle::needle:vset $w [set $($w:-variable)]
}
# ====================
#
# stop proc
#
# ====================
proc needle:stop {w} \
{
variable {}
set ($w:stop) 1
}
# ====================
#
# start proc
#
# ====================
proc needle:start {w} \
{
variable {}
set ($w:stop) 0
needle:invoke $w
}
# ====================
#
# invoke proc
#
# ====================
proc needle:invoke {w} \
{
variable {}
if {$($w:stop)} { return }
set script $($w:-script)
if {$script != ""} \
{
set map [list]
foreach name [array names {} $w%] \
{
set param [lindex [split $name %] 1]
lappend map %$param% $($name)
}
eval [string map $map $script]
}
after $($w:-delay) ::needle::needle:invoke $w
}
}
namespace import ::needle::needleScript pkgIndex.tcl
package ifneeded ASimpleNeedle 1.0 [list source [file join $dir ASimpleNeedle.tcl]]
Demo
package require ASimpleNeedle
wm title . "needle"
wm protocol . WM_DELETE_WINDOW exit
needle .n -text U -var ::val
pack .n -padx 10 -pady 10
proc setNeedle {} \
{
set ::val [expr {rand() * 100.0}]
after [expr {500 + int(500 * rand())}] setNeedle
}
setNeedle
focus -force .
raise .Voir aussi
Discussion
Catégorie Paquet | Catégorie Interface utilisateur