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 } repeat
Voir aussi
Discussion