ulis 2008-01-20. Un paquet rapidement fait pour afficher un compteur qui défile (ou autre chose).
Pourquoi
J'en ai eu besoin pour un jeu.
Comment
Heu, faut vraiment le dire ???
Bin avec un canvas...
Description
# ###################### # # paquet compteur # set version 1.0 # # (C) ulis, 2008 # # Licence NOL (No Obligation Licence) # # ---------------------- # commands: # compteur ?create? $w ?-option value?... # create widget # compteur get ?-option? # get default value (or get default names list) # compteur set ?-option value?... # set default values (or get default values list) # ---------------------- # operations: # $w cget ?-option? # get option value (or get option names list) # $w config ?-option value?... # set option values (or get option values list) # $w value ?value? # set value (or get value) # ---------------------- # options: # -bg couleur d'arrière-plan d'un digit # -count nombre de digits # -delay délai de défilement # -fg couleur d'avant-plan d'un digit # -font police d'un digit # -height hauteur du compteur # -value valeurs du compteur (digits) # -width largeur du compteur # ######################
Configuration
Installation
Utilisation
package require compteur
Script pkgIndex.tcl
package ifneeded compteur 1.0 [list source [file join $dir compteur.tcl]]
Paquet
if {[info exists ::compteur::version]} { return }
namespace eval compteur \
{
# ######################
#
# paquet compteur
#
set version 1.0
#
# (C) ulis, 2008
#
# Licence NOL (No Obligation Licence)
#
# ----------------------
# commands:
# compteur ?create? $w ?-option value?...
# create widget
# compteur get ?-option?
# get default value (or get default names list)
# compteur set ?-option value?...
# set default values (or get default values list)
# ----------------------
# operations:
# $w cget ?-option?
# get option value (or get option names list)
# $w config ?-option value?...
# set option values (or get option values list)
# $w value ?value?
# set value (or get value)
# ----------------------
# options:
# -bg couleur d'arrière-plan d'un digit
# -count nombre de digits
# -delay délai de défilement
# -fg couleur d'avant-plan d'un digit
# -font police d'un digit
# -height hauteur du compteur
# -value valeurs du compteur (digits)
# -width largeur du compteur
# ######################
namespace export compteur
package require Tk
package provide compteur $version
variable {}
array set {} \
{
-bg red
-count 10
-delay 5
-fg gold
-font {Courier -38 bold}
-height 40
-value 0
-width 240
}
proc compteur {{oper ""} args} \
{
if {[string match .* $oper]} \
{
set args [linsert $args 0 $oper]
set oper create
}
set code [catch \
{
switch -glob -- $oper \
{
get { uplevel 1 ::compteur::compteur:get $args }
set { uplevel 1 ::compteur::compteur:set $args }
cre* { uplevel 1 ::compteur::compteur:create $args }
default { error "use is 'compteur create|get|set|\$w ...'" }
}
} result]
return -code $code $result
}
proc compteur:get {args} \
{
variable {}
set count [llength $args]
if {$count > 1} { error "use is 'compteur get ?-option?" }
switch $count \
{
0 \
{
return [lsort [array names {} -*]]
}
1 \
{
set option [lindex $args 0]
switch -glob -- $option \
{
-bac* -
-bg { set (-bg) }
-cou* { set (-count) }
-del* { set (-delay) }
-for* -
-fg { set (-fg) }
-fon* { set (-font) }
-hei* { set (-height) }
-val* { set (-value) }
-wid* { set (-width) }
default { error "unknown compteur option '$option'" }
}
}
}
}
proc compteur:set {args} \
{
variable {}
set count [llength $args]
if {$count % 2 != 0} { error "use is 'compteur set ?-option value?..." }
if {$count == 0} \
{
set result [list]
foreach name [lsort [array names {} -*]] \
{ lappend result $name $($name) }
return $result
} \
else \
{
foreach {key value} $args \
{
switch -glob -- $key \
{
-bac* -
-bg { set (-bg) $value }
-cou* { set (-count) $value }
-del* { set (-delay) $value }
-for* -
-fg { set (-fg) $value }
-fon* { set (-font) $value }
-hei* { set (-height) $value }
-val* { set (-value) $value }
-wid* { set (-width) $value }
default { error "unknown compteur option '$option'" }
}
}
}
}
proc compteur:create {w args} \
{
variable {}
# create widget
canvas $w -bd 0 -highlightt 0
# create megawidget reference
rename $w ::compteur::_$w
eval [format \
{
proc ::%s {args} \
{ uplevel 1 ::compteur::compteur:dispatch %s $args }
} $w $w]
# configure
set ($w:-width) 1
set ($w:-count) 1
set defaults [list]
foreach key [array names {} -*] { lappend defaults $key $($key) }
uplevel 1 ::compteur::compteur:config $w $defaults $args
# return reference
return $w
}
proc compteur:dispatch {w {oper ""} args} \
{
set code [catch \
{
switch -glob -- $oper \
{
cge* { uplevel 1 ::compteur::compteur:cget $w $args }
con* { uplevel 1 ::compteur::compteur:config $w $args }
val* { uplevel 1 ::compteur::compteur:value $w $args }
default { error "use is '\$w cget|config ...'" }
}
} result]
return -code $code $result
}
proc compteur:cget {w args} \
{
variable {}
set count [llength $args]
if {$count > 1} { error "use is '$w cget ?-option?" }
switch $count \
{
0 \
{
return [lsort [array names {} -*]]
}
1 \
{
set option [lindex $args 0]
switch -glob -- $option \
{
-bac* -
-bg { set ($w:-bg) }
-cou* { set ($w:-count) }
-del* { set ($w:-delay) }
-for* -
-fg { set ($w:-fg) }
-fon* { set ($w:-font) }
-hei* { set ($w:-height) }
-val* { set ($w:-value) }
-wid* { set ($w:-width) }
default { error "unknown compteur option '$option'" }
}
}
}
}
proc compteur:config {w args} \
{
variable {}
set count [llength $args]
if {$count % 2 != 0} { error "use is '$w config ?-option value?..." }
if {$count == 0} \
{
set result [list]
foreach name [lsort [array names {} -*]] \
{ lappend result $name $($w:$name) }
return $result
} \
else \
{
set flag1 0
set flag2 0
set flag3 0
set _w ::compteur::_$w
foreach {key value} $args \
{
switch -glob -- $key \
{
-bac* -
-bg { set:color $w -bg $value; set flag1 1 }
-cou* { set:positive $w -count $value; set flag2 1 }
-del* { set:positive $w -delay $value }
-for* -
-fg { set:color $w -fg $value; set flag1 1 }
-fon* { set:font $w -font $value; set flag2 1 }
-hei* { set:pixels $w -height $value; set flag2 1 }
-val* { set ($w:-value) $value; set flag3 1 }
-wid* { set:pixels $w -width $value; set flag2 1 }
default { error "unknown compteur option '$option'" }
}
}
# checks
if {$flag1} { fix:aspect $w }
if {$flag2} { fix:geometry $w }
if {$flag3} { fix:value $w }
}
}
proc compteur:value {w args} \
{
variable {}
set count [llength $args]
if {$count > 1} { error "use is '$w value ?value?..." }
if {$count == 0} \
{
return $($w:-value)
} \
else \
{
set value [lindex $args 0]
set ($w:-value) $value
fix:value $w
}
}
proc fix:aspect {w} \
{
variable {}
# fix digits
set _w ::compteur::_$w
$_w itemconf rect -fill $($w:-bg)
$_w itemconf text -fill $($w:-fg)
}
proc fix:geometry {w} \
{
variable {}
# compute digit width
set ($w:digit:width) [expr {$($w:-width) / $($w:-count)}]
# check for overflow
if {[string length $($w:-value)] > $($w:-count)} \
{ error "compteur overflow: '$($w:-value)' ($($w:-count) digits max)" }
# fix canvas sizes
set _w ::compteur::_$w
$_w config -width $($w:-width) -height $($w:-height)
# fix digits
set dw $($w:digit:width)
set dh $($w:-height)
set x $($w:-width)
for {set i 0} {$i < $($w:-count)} {incr i} \
{
incr x -$dw
set x0 [expr {$x + 1}]
set x1 [expr {$x + 2}]
set x2 [expr {$x + $dw - 2}]
set x3 [expr {$x + $dw - 1}]
set y0 0
set y1 2
set y2 [expr {$dh - 2}]
set y3 $dh
lappend list $x1 $y3 $x0 $y2
lappend list $x0 [expr {$y1 - 1}] $x1 $y0
lappend list $x2 $y0 $x3 $y1
incr x1
incr x2 -1
incr y2 -1
incr y3
lappend list $x3 $y2 $x2 $y3
$_w coords digit$i-rect $list
set x0 [expr {$x + 1}]
$_w coords digit$i-text1 $x0 0
$_w coords digit$i-text2 $x0 $($w:-height)
}
}
proc fix:value {w} \
{
variable {}
# check for overflow
set value $($w:-value)
if {[string length $value] > $($w:-count)} \
{ error "compteur overflow: '$value' ($($w:-count) digits max)" }
# set value
set i 0
while {$value ne ""} \
{
set digit [string index $value end]
set value [string range $value 0 end-1]
set:digit $w $i $digit
incr i
}
}
proc set:color {w option value} \
{
variable {}
set code [catch {winfo rgb . $value}]
if {$code == 1} { error "bad color '$value'" }
set ($w:$option) $value
}
proc set:positive {w option value} \
{
variable {}
if {![string is integer -strict $value]} { error "invalid value: '$value'" }
if {$value < 0} { error "negative value: '$value'" }
set ($w:$option) $value
}
proc set:pixels {w option value} \
{
variable {}
set code [catch {winfo pixels . $value}]
if {$code == 1} { error "bad pixels distance value '$value'" }
set ($w:$option) $value
}
proc set:font {w option value} \
{
variable {}
set code [catch {font actual $value}]
if {$code == 1} { error "bad font '$value'" }
set ($w:$option) $value
}
proc set:digit {w i digit} \
{
variable {}
if {![info exists ($w:digit:$i)]} { create:digit $w $i }
if {$($w:actual:$i) != $digit} \
{
set ($w:final:$i) $digit
roll:digit $w $i
}
}
proc create:digit {w i} \
{
variable {}
set _w ::compteur::_$w
set dw $($w:digit:width)
set dh $($w:-height)
set x [expr {$($w:-width) - $($w:digit:width) * ($i + 1)}]
set x0 [expr {$x + 1}]
set x1 [expr {$x + 2}]
set x2 [expr {$x + $dw - 2}]
set x3 [expr {$x + $dw - 1}]
set y0 0
set y1 2
set y2 [expr {$dh - 2}]
set y3 $dh
lappend list $x1 $y3 $x0 $y2
lappend list $x0 [expr {$y1 - 1}] $x1 $y0
lappend list $x2 $y0 $x3 $y1
incr x1
incr x2 -1
incr y2 -1
incr y3
lappend list $x3 $y2 $x2 $y3
$_w create polygon $list -fill $($w:-bg) \
-tags [list digit$i digit$i-rect rect]
$_w create text $x 0 -anchor nw \
-tags [list digit$i digit$i-text1 text] \
-text "" -font $($w:-font) -fill $($w:-fg)
$_w create text $x $dh -anchor nw \
-tags [list digit$i digit$i-text2 text] \
-text "" -font $($w:-font) -fill $($w:-fg)
set ($w:digit:$i) 1
set ($w:actual:$i) 0
set ($w:rolling:$i) 0
}
proc roll:digit {w i {recurse 0}} \
{
variable {}
set _w ::compteur::_$w
set actual $($w:actual:$i)
set final $($w:final:$i)
if {$actual == $final} \
{
set ($w:rolling:$i) 0
return
} \
else \
{
if {$recurse || !$($w:rolling:$i)} \
{
set ($w:rolling:$i) 1
$_w itemconfig digit$i-text2 -text $final
set ($w:actual:$i) $final
set ($w:position:$i) 0
after 1 ::compteur::_roll:digit $w $i
}
}
}
proc _roll:digit {w i} \
{
variable {}
set _w ::compteur::_$w
if {$($w:position:$i) < $($w:-height)} \
{
$_w move digit$i-text1 0 -1
$_w move digit$i-text2 0 -1
incr ($w:position:$i)
after $($w:-delay) ::compteur::_roll:digit $w $i
update
} \
else \
{
set actual [$_w itemcget digit$i-text2 -text]
$_w itemconf digit$i-text1 -text $actual
$_w move digit$i-text1 0 $($w:-height)
$_w move digit$i-text2 0 $($w:-height)
after $($w:-delay) ::compteur::roll:digit $w $i 1
}
}
}
namespace import ::compteur::*Demo
# ###################
# demo
# ###################
package require compteur
grid [compteur .cp -value " " -width 138 -count 6]
set ::value 0
proc repeat {} \
{
set incr [expr {int(100 * rand())}]
incr ::value $incr
.cp value $::value
after [expr {int(1000 * rand())}] repeat
}
repeatVoir aussi
Discussion