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::needle
Script 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