dc 10/06/08 (Il fallait bien donner un nom à ça...)
Voici donc un petit package appelé vHF, qui permet d'accéder à un widget volumeHF. L'obtention des couleurs dégradées se fait grâce à http://wiki.tcl.tk/9079
Code
# auteur : david cobac [string map {# @} david.cobac#gmail.com]
# date : 11/06/2008
bind VhfScale <4> [list ::vHF::incremente %W]
bind VhfScale <5> [list ::vHF::decremente %W]
bind VhfScale <Destroy> [list ::vHF::destruction %W]
bind VhfScale <Enter> [list ::vHF::entrer %W]
bind VhfScale <Leave> [list ::vHF::partir %W]
#
namespace eval ::vHF {
variable version 1.2.1
variable {}
variable pi [expr {acos(-1)}]
#
package provide vHF $version
#
namespace export *
#
array set {} {
-chfn 8
-chfnColor gray30
-chfnGColor1 green
-chfnGColor2 red
-chfnGradient 1
-chfnLines 1
-chfnLWidth 1
-chfnLNb 40
-diam 100
-disp 1
-dispColor white
-dispGColor1 green
-dispGColor2 red
-dispGradient 1
-end 135
-format %.1f
-from 0
-length 20
-resolution 1
-repColor red
-start -135
-to 100
-value 0
-variable {}
-width 2
}
set (-bg) [ttk::style lookup TFrame -background]
set (-activefg) [ttk::style lookup TFrame -background active]
set (-fg) [ttk::style lookup TScale -background]
}
proc ::vHF::volumeHF {{w ""} args} {
variable {}
foreach key [array names {} -*] {
set ($w:$key) $($key)
}
#
ttk::frame $w -class VhfScale
canvas $w.cv -bd 0 -highlightt 0 -bg $($w:-bg)
pack $w.cv -expand 1 -fill both
bind $w.cv <4> [list event generate $w <4>]
bind $w.cv <5> [list event generate $w <5>]
bind $w.cv <Enter> [list event generate $w <Enter>]
bind $w.cv <Leave> [list event generate $w <Leave>]
# on réarrange l'ordre des événements pour être
# sûr de traiter le bind de la classe avant
bindtags $w [list VhfScale $w . all]
# avant de créer une procédure du nom du widget $w
# on se permet de récupérer la commande traitant la
# frame conteneur
rename $w _$w
#
eval [format {
proc ::%s {args} {
uplevel 1 ::vHF::operation %s $args
}
} $w $w]
#
set ($w:init) 0
if {$args ne ""} {
# :init va me servir à savoir si config est appelée
# maintenant à la création ou non comme ça j'en déduis
# qu'il faudra faire dans config les trois procédures
# suivantes
set ($w:init) 1
uplevel 1 ::vHF::config $w $args
set ($w:init) 0
} else {
::vHF::actualiseVariables $w
::vHF::constructionBouton $w
::vHF::actualiseRepere $w
}
#
return $w
}
proc ::vHF::destruction {w} {
variable {}
array unset {} $w:*
}
proc ::vHF::operation {w {oper ""} args} {
switch -glob -- $oper {
cge* { uplevel 1 ::vHF::cget $w $args }
con* { uplevel 1 ::vHF::config $w $args }
default { error "unknown vHF operation '$oper' : should be 'cget' or 'configure'" }
}
}
proc ::vHF::cget {w args} {
variable {}
if {[llength $args] ne 1} { error "use is '$w cget -option'" }
set key [lindex $args 0]
switch -glob -- $key {
-activefg { return $($w:-activefg) }
-bg { return $($w:-bg) }
-chfn { return $($w:-chfn) }
-chfnC* { return $($w:-chfnColor) }
-chfnGColor1 { return $($w:-chfnGColor1) }
-chfnGColor2 { return $($w:-chfnGColor2) }
-chfnGr* { return $($w:-chfnGradient) }
-chfnLi* { return $($w:-chfnLines) }
-chfnLN* { return $($w:-chfnLNb) }
-chfnLW* { return $($w:-chfnLWidth) }
-diam { return $($w:-diam) }
-disp { return $($w:-disp) }
-dispC* { return $($w:-dispColor) }
-dispGColor1 { return $($w:-dispGColor1) }
-dispGColor2 { return $($w:-dispGColor2) }
-dispGr* { return $($w:-dispGradient) }
-end { return $($w:-end) }
-fg { return $($w:-fg) }
-format { return $($w:-format) }
-from { return $($w:-from) }
-len* { return $($w:-length) }
-repC* { return $($w:-repColor) }
-res* { return $($w:-resolution) }
-start { return $($w:-start) }
-to { return $($w:-to) }
-value { return $($w:-value) }
-var* { return $($w:-variable) }
-wid* { return $($w:-width) }
default { return [_$w cget $key] }
}
}
proc ::vHF::config {w args} {
variable {}
# vérifications
if {[llength $args] % 2 != 0} {
error "use is '$w configure ?-option value?...'"
}
# on traite la demande sans option en renvoyant
# toutes les valeurs d'options actuellement employées :
if {$args eq ""} {
set sortie ""
foreach {key value} [array get {} *:-*] {
regexp {.*:(-.*)} $key -> option
lappend sortie [list $option $value]
}
return $sortie
}
# modification de la valeur des options
#
foreach {key value} $args {
switch -glob -- $key {
-activefg {
set ($w:-activefg) $value
}
-bg {
set ($w:-bg) $value
$w.cv configure -bg $value
}
-chfn {
if { [string is integer $value] && $value >=0 } {
set ($w:-chfn) $value
} else {
error "$value is not a valid integer for -chfn option"
}
::vHF::actualiseVariables $w
::vHF::constructionBouton $w
}
-chfnC* {
set ($w:-chfnColor) $value
}
-chfnGColor1 {
set ($w:-chfnGColor1) $value
}
-chfnGColor2 {
set ($w:-chfnGColor2) $value
}
-chfnGr* {
if { $value eq 0 || $value eq 1 } {
set ($w:-chfnGradient) $value
} else {
error "$value is not a valid integer for -chfnGradient option"
}
}
-chfnLi* {
if { $value eq 0 || $value eq 1 } {
set ($w:-chfnLines) $value
} else {
error "$value is not a valid integer for -chfnLines option"
}
::vHF::actualiseVariables $w
::vHF::constructionBouton $w
}
-chfnLN* {
if { [string is integer $value] && $value >=0 } {
set ($w:-chfnLNb) $value
} else {
error "$value is not a valid integer for -chfnLNb option"
}
::vHF::actualiseVariables $w
::vHF::constructionBouton $w
}
-chfnLW* {
if { [string is integer $value] && $value >=0 } {
set ($w:-chfnLWidth) $value
} else {
error "$value is not a valid integer for -chfnLWidth option"
}
::vHF::actualiseVariables $w
::vHF::constructionBouton $w
}
-diam {
if { [string is integer $value] && $value >=0 } {
set ($w:-diam) $value
} else {
error "$value is not a valid integer for -diam option"
}
::vHF::actualiseVariables $w
::vHF::constructionBouton $w
}
-disp {
if { $value eq 0 || $value eq 1 } {
set ($w:-disp) $value
} else {
error "$value is not a valid integer for -disp option"
}
}
-dispC* {
set ($w:-dispColor) $value
}
-dispGColor1 {
set ($w:-dispGColor1) $value
}
-dispGColor2 {
set ($w:-dispGColor2) $value
}
-dispGr* {
if { $value eq 0 || $value eq 1 } {
set ($w:-dispGradient) $value
} else {
error "$value is not a valid integer for -dispGradient option"
}
}
-end {
set ($w:-end) $value
}
-fg {
set ($w:-fg) $value
$w.cv itemconfigure ptCercle -fill $value
$w.cv itemconfigure rayon -fill $value
$w.cv itemconfigure gdCercle -outline $value
}
-format {
set ($w:-format) $value
}
-from {
set ($w:-from) $value
if { $($w:-value) < $value } {
set ($w:-value) $value
}
}
-len* {
if { [string is integer $value] && $value >=0 } {
set ($w:-length) $value
} else {
error "$value is not a valid integer for -length option"
}
}
-repC* {
set ($w:-repColor) $value
$w.cv itemconfigure repere -fill $value
}
-res* {
# pour s'assurer de la précision dans les angles
# on fait de résolution un flottant
set ($w:-resolution) [expr {$value * 1.}]
}
-start {
set ($w:-start) $value
}
-to {
set ($w:-to) $value
if { $($w:-value) > $value } {
set ($w:-value) $value
}
}
-value {
if { $value > $($w:-to) } {
set value $($w:-to)
} elseif { $value < $($w:-from) } {
set value $($w:-from)
}
set ($w:-value) $value
# liaison avec l'option -variable
if { $($w:-variable) ne "" } {
uplevel #0 set $($w:-variable) $value
}
}
-var* {
# pour effacer la trace sur la précédente variable
set ($w:-variablePrecedente) $($w:-variable)
set ($w:-variable) $value
::vHF::miseEnPlaceTrace $w
# récupération de la valeur actuelle de cette variable
# si elle existe
::vHF::liaisonVariableValue $w
}
-wid* {
if { [string is integer $value] && $value >=0 } {
set ($w:-width) $value
} else {
error "$value is not a valid integer for -width option"
}
}
default {
# pour une option inconnue de vHF, elle s'applique
# à la frame conteneur
_$w configure $key $value
}
}
}
::vHF::actualiseVariables $w
if {$($w:init) eq 1} {
::vHF::constructionBouton $w
}
::vHF::actualiseRepere $w
}
proc ::vHF::entrer {w} {
variable {}
set value $($w:-activefg)
$w.cv itemconfigure ptCercle -fill $value
$w.cv itemconfigure rayon -fill $value
$w.cv itemconfigure gdCercle -outline $value
}
proc ::vHF::partir {w} {
variable {}
set value $($w:-fg)
$w.cv itemconfigure ptCercle -fill $value
$w.cv itemconfigure rayon -fill $value
$w.cv itemconfigure gdCercle -outline $value
}
proc ::vHF::incremente {w} {
variable {}
set v [expr {$($w:-value) + $($w:-resolution)}]
if {$($w:-chfnLines) eq 1 && $($w:-value) < $($w:-to)} {
::vHF::rayonTourne $w -1
}
$w configure -value $v
}
proc ::vHF::decremente {w} {
variable {}
set v [expr {$($w:-value) - $($w:-resolution)}]
if {$($w:-chfnLines) eq 1 && $($w:-value) > $($w:-from)} {
::vHF::rayonTourne $w +1
}
$w configure -value $v
}
# renvoit un angle entre -from et -to
# correspondant à la valeur entre -start et -end
proc ::vHF::value2angle {w x} {
variable {}
return [expr { $($w:-start) + 1.*($x - $($w:-from)) *\
($($w:-end) - $($w:-start)) /\
($($w:-to) - $($w:-from)) }]
}
proc ::vHF::rotation {x y xc yc angleDeg} {
variable pi
set angleRad [expr {$pi*$angleDeg/180}]
set xp [expr {$xc+cos($angleRad)*($x-$xc)-sin($angleRad)*($y-$yc)}]
set yp [expr {$yc+sin($angleRad)*($x-$xc)+cos($angleRad)*($y-$yc)}]
return [list $xp $yp]
}
proc ::vHF::rayonTourne {w sens} {
variable {}
## rotation des rayons du chanfrein
set listeRayons [$w.cv find withtag rayon]
foreach l $listeRayons {
# x0 et y0 sont xc et yc -> on les laisse
lassign [$w.cv coords $l] x0 y0 x1 y1
$w.cv coords $l $($w:centrex) $($w:centrey) \
{*}[::vHF::rotation $x1 $y1 $($w:centrex) $($w:centrey) \
[expr {$sens*$($w:uniteRotation)}] ]
}
}
proc ::vHF::liaisonVariableValue {w args} {
variable {}
if { [catch {
set v [uplevel #0 set $($w:-variable)]
}] } {
# la variable passée n'existe pas encore !!
set v 0
}
$w configure -value $v
}
proc ::vHF::miseEnPlaceTrace {w} {
variable {}
# effacer les traces précédentes
if {$($w:-variablePrecedente) ne ""} {
uplevel #0 trace remove variable $($w:-variablePrecedente) write \
\{::vHF::liaisonVariableValue $w\}
}
# mise en place de la trace
if {$($w:-variable) ne ""} {
uplevel #0 trace add variable $($w:-variable) write \
\{::vHF::liaisonVariableValue $w\}
}
}
proc ::vHF::actualiseVariables {w} {
variable {}
# pas tout à fait le diamètre !
set ($w:diametreptCercle) [expr {$($w:-diam)-$($w:-chfn)}]
# rayon utile pour la proc actualiseRepere
set ($w:rayonptCercle) [expr {.5*($($w:diametreptCercle)-$($w:-chfn))}]
set ($w:rayonpptCercle) [expr {$($w:rayonptCercle) - $($w:-length)}]
#
# l'angle de rotation unité est calculée sur la base d'une rotation minimale
# correspondant à la résolution (en partant du début),
# ensuite une fois cet angle trouvé, on a notre rotation unité en soustrayant
# à la position de départ
set angleDeg [::vHF::value2angle $w [expr {$($w:-resolution) + $($w:-from)}]]
set ($w:uniteRotation) [expr {$($w:-start) - $angleDeg}]
#
# la liste des couleurs contient autant d'éléments que de valeurs possibles
# prises par le widget
set nb [expr {int(($($w:-to) - $($w:-from)) / $($w:-resolution) +1)}]
set ($w:chfnDegrade) [::transx::rgbs $nb $($w:-chfnGColor1) $($w:-chfnGColor2)]
set ($w:dispDegrade) [::transx::rgbs $nb $($w:-dispGColor1) $($w:-dispGColor2)]
set ($w:indice) [expr {int( ($($w:-value) - $($w:-from)) / $($w:-resolution) )}]
}
proc ::vHF::actualiseRepere {w} {
variable {}
variable pi
$w.cv delete repere
set angle [::vHF::value2angle $w $($w:-value)]
set lcos [expr {cos($angle*$pi/180-$pi/2)}]
set lsin [expr {sin($angle*$pi/180-$pi/2)}]
$w.cv create line \
[expr {$($w:centrex)+$($w:rayonpptCercle)*$lcos}]\
[expr {$($w:centrey)+$($w:rayonpptCercle)*$lsin}]\
[expr {$($w:centrex)+$($w:rayonptCercle)*$lcos}]\
[expr {$($w:centrey)+$($w:rayonptCercle)*$lsin}]\
-width $($w:-width) -fill $($w:-repColor) -tags repere
if {$($w:-chfnGradient) eq 1} {
$w.cv itemconfigure gdCercle -fill [lindex $($w:chfnDegrade) $($w:indice)]
}
if {$($w:-disp) eq 1} {
set nb [format $($w:-format) $($w:-value)]
if {$($w:-dispGradient) eq 1} {
$w.cv itemconfigure valeur -text $nb -fill [lindex $($w:dispDegrade) $($w:indice)]
} else {
$w.cv itemconfigure valeur -text $nb -fill $($w:-dispColor)
}
} else {
$w.cv itemconfigure valeur -text ""
}
update
}
proc ::vHF::constructionBouton {w} {
variable {}
variable pi
set ($w:centrex) [expr {.5*$($w:-diam)}]
set ($w:centrey) $($w:centrex)
#
$w.cv delete all
#
$w.cv configure -width $($w:-diam) -height $($w:-diam)
$w.cv create oval \
1 1 \
[expr {$($w:-diam)-1}] [expr {$($w:-diam)-1}] \
-fill $($w:-chfnColor) -width 2 -outline $($w:-fg) -tags gdCercle
if {$($w:-chfnLines) eq 1} {
for {set r 0} {$r<360} {incr r [expr {360/$($w:-chfnLNb)}]} {
$w.cv create line \
$($w:centrex) $($w:centrey) \
[expr {$($w:centrex)*(1+cos($r*$pi/180))}] \
[expr {$($w:centrey)*(1+sin($r*$pi/180))}] \
-width $($w:-chfnLWidth) -fill $($w:-fg) -tags rayon
}
}
$w.cv create oval \
$($w:-chfn) $($w:-chfn) \
$($w:diametreptCercle) $($w:diametreptCercle) \
-fill $($w:-fg) -width 1 -outline $($w:-fg) -tags ptCercle
#
$w.cv create text $($w:centrex) $($w:centrey) \
-tags valeur -fill white
}
################################################################################################
################################################################################################
### Following namespace from international wiki page : 'Gradients Color Transitions'
### http://wiki.tcl.tk/9079
###
### author : Rohan Pall
### date : 09/06/03
namespace eval transx {
proc rgbs {n c1 c2} {
# Color intensities are from 0 to 65535, 2 byte colors.
foreach {r1 g1 b1} [winfo rgb . $c1] break
foreach {r2 g2 b2} [winfo rgb . $c2] break
#puts "c1: $r1 $g1 $b1"
#puts "c2: $r2 $g2 $b2"
# Normalize intensities to 0 to 255, 1 byte colors.
foreach el {r1 g1 b1 r2 g2 b2} {
set $el [expr {[set $el] * 255 / 65535}].0
}
#puts "c1: $r1 $g1 $b1"
#puts "c2: $r2 $g2 $b2"
if {$n == 1} {
set r_step 0.0 ; set g_step 0.0 ; set b_step 0.0
} else {
set r_step [expr {($r2-$r1) / ($n-1)}]
set g_step [expr {($g2-$g1) / ($n-1)}]
set b_step [expr {($b2-$b1) / ($n-1)}]
}
#puts "$r_step $g_step $b_step"
set steps {}
for {set i 0} {$i < $n} {incr i} {
set r [expr {int($r_step * $i + $r1)}]
set g [expr {int($g_step * $i + $g1)}]
set b [expr {int($b_step * $i + $b1)}]
#puts "$r $g $b"
lappend steps [format "#%.2X%.2X%.2X" $r $g $b]
}
return $steps
}
}Exemples d'utilisation
Certains exemples utilisent les extensions pixane et shape pour fournir une interface circulaire. Pour l'exemple, mon fichier volumeHF.tcl se situe dans le répertoire VolumeHF avec le fichier pkgIndex.tcl suivant :
package ifneeded vHF 1.2.1 [list source [file join $dir volumeHF-1.2.1.tcl]]
Exemple 1
### contrôle du volume Master de la carte son via 'amixer' (linux) ###
#### les paquets requis
package require Tk
package require pixane
package require shape
package require vHF 1.2.1
#
namespace import vHF::*
#### dimension du bouton 30x30... enfin à peu près ;)
set dim 30
##
wm overrideredirect . 1
wm geometry . -0-0
## création du masque pour la transparence
set itk [image create photo]
set ipx [pixane create -tkphoto $itk]
pixane resize $ipx $dim $dim
pixane blank $ipx
pixane oval $ipx [expr {$dim/2}] [expr {$dim/2}] [expr {$dim/2 - 2}]
## utilisation du masque
proc rafraichir {} {
shape set . photo $::itk
}
bind . <Configure> [list rafraichir]
#### Le volume
## on change la valeur du volume
proc changeSon {} {
exec amixer set Master $::niveauMaster
}
## on récupère la valeur du volume
## régulièrement (si jamais c'est changé par un autre programme)
proc recupNiveauMaster {} {
set out [exec amixer get Master]
regexp -line {Mono: Playback ([\d]+)} $out -> nv
set ::niveauMaster $nv
after 500 recupNiveauMaster
}
#### notre widget !!
volumeHF .c -diam $dim -chfn 4 -length 2 \
-disp 1 -format %.0f -dispColor red -chfnGradient 1 \
-chfnLines 0 -variable niveauMaster -from 0 -to 39 \
-dispGradient 1 -fg black -activefg black
pack .c
## le début de la liaison avec le volume
recupNiveauMaster
## le binding
bind .c <4> [list changeSon]
bind .c <5> [list changeSon]
bind . <3> [list destroy .]Exemple 2
package require Tk
package require vHF 1.2.1
namespace import vHF::*
proc recalcule {w} {
update
set l [winfo width $w]
set h [winfo height $w]
set dim [expr {min($l,$h)}]
$w configure -diam $dim
}
volumeHF .v
bind .v <Configure> [list recalcule .v]
pack .v -fill both -expand 1Exemple 3
### réglage du gamma de l'écran sous X11 ###
package require Tk
package require vHF 1.2.1
namespace import vHF::*
proc setGammaRGB {c} {
set nv [set ::$c]
if {$::link eq 1} {
set option -gamma
set ::red $nv
set ::green $nv
set ::blue $nv
} else {
set option -[string index $c 0]gamma
}
exec xgamma -q $option $nv
}
set red 1
set green 1
set blue 1
set i -1
set optionsG {-from .1 -to 10 -resolution .1 -diam 30 -length 4\
-chfnLines 0 -chfn 1 -repColor black}
foreach v { red green blue } {
volumeHF .$v -fg $v -variable $v \
{*}$optionsG
grid .$v -row 0 -column [incr i]
bind .$v <4> [list setGammaRGB $v]
bind .$v <5> [list setGammaRGB $v]
}
set link 1
ttk::checkbutton .cb -text liaison -variable link
grid .cb -row 1 -columnspan 3 -sticky news
bind all <3> exitExemple 4
package require Tk package require vHF 1.2.1 namespace import vHF::* volumeHF .c -variable nb -to 1 -resolution .01 -format %.2f volumeHF .d -variable nb -to 1 -resolution .1 -format %.1f volumeHF .e -variable nb -to 1 -resolution 1 -format %.0f ttk::scale .s -variable nb pack .c .d .e .s