widget volume hifi

 

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 1

Exemple 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> exit

Exemple 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