Posted to tcl by Florentis at Tue Aug 25 23:54:41 GMT 2026view pretty
# adapted from "https://wiki.tcl-lang.org/page/HSV+colorPicker"
# To be executed with tip-759 branch
catch {namespace delete ::gColorNS}
namespace eval ::gColorNS {
# Variables du namespace
variable canvas_size 300
variable radius [($canvas_size / 2.1)]
variable ring_thickness [($radius / 8)]
variable cx [($canvas_size / 2)]
variable cy [($canvas_size / 2)]
variable triangle_coords {}
variable triangle_id
variable hue_marker_id
variable sv_marker_id
variable cumulative_angle 0
variable current_saturation 0.5
variable current_value 0.5
variable current_hue 0
variable hue_marker_coords {}
variable hue_ring_image
variable active_tag ""
variable canvas {}
variable info_frame {}
variable info_bg {}
variable last_update_time 0
variable update_threshold_ms 30
variable pending_update_after_id 0
variable rgbvar {}
variable hexvar {}
# Fonctions de conversion de coordonnées et couleurs
proc ::tcl::mathfunc::polar_to_cartesian {radius angle cx cy} {(
radian = $angle * acos(-1) / 180;
x = $cx + $radius * cos($radian);
y = $cy - $radius * sin($radian);
[format "%.5f" $x], [format "%.5f" $y]
)}
proc hsv_to_rgb {h s v} {
# "Muted" arithmetic substitution : script to set variables
[( h = fmod($h, 360.0);
c = $v*$s;
x = $c*(1 - abs(fmod($h / 60.0, 2) - 1));
m = $v-$c )]
# Inlined arithmetic substitution : complex test to assign list of variables
lassign [(
$h < 60 ? ($c, $x, 0)
: $h < 120 ? ($x, $c, 0)
: $h < 180 ? (0, $c, $x)
: $h < 240 ? (0, $x, $c)
: $h < 300 ? ($x, 0, $c)
: ($c, 0, $x)
)] r g b
# Inlined arithmetic substitution : to return a list of value
[( round(($r + $m)*255), round(($g + $m)*255), round(($b + $m)*255) )]
}
proc rgb_to_hsv {r g b} {(
r = $r / 255.0;
g = $g / 255.0;
b = $b / 255.0;
cmax = max($r, max($g, $b));
cmin = min($r, min($g, $b));
diff = $cmax - $cmin;
abs($diff) < 0.00001 ? (h = 0)
: abs($cmax - $r) < 0.00001 ? (h = 60 * fmod(($g - $b)/$diff, 6))
: abs($cmax - $g) < 0.00001 ? (h = 60 * (($b - $r)/$diff + 2))
: (h = 60 * (($r - $g)/$diff + 4));
$h < 0 ? (h = $h + 360):;
$cmax == 0 ? (s = 0) : (s = $diff/$cmax);
($h,$s,$cmax)
)}
#geometry functions
proc point_in_triangle {px py t1 t2 t3} {(
[lassign $t1 x1 y1
lassign $t2 x2 y2
lassign $t3 x3 y3];
(denom = ($y2-$y3)*($x1-$x3) + ($x3-$x2)*($y1-$y3)) == 0 ? [return 0] :;
a = (($y2-$y3)*($px-$x3)+($x3-$x2)*($py-$y3)) / $denom;
b = (($y3-$y1)*($px-$x3)+($x1-$x3)*($py-$y3)) / $denom;
c = 1.0 - $a - $b;
$a >= 0 && $b >= 0 && $c >= 0
)}
proc calculate_edge_distance {px py t1 t2 t3} {
[( edges = (($t1,$t2),($t2,$t3),($t3,$t1));
min_distance = 999999999 )]
foreach edge $edges {
lassign $edge p1 p2
lassign $p1 x1 y1
lassign $p2 x2 y2
[( A = $y2-$y1; B = $x1-$x2;
C = $x2*$y1 - $x1*$y2;
distance = abs($A * $px + $B * $py + $C) / hypot($A, $B);
$distance < $min_distance ? (min_distance = $distance) : )]
}
[point_in_triangle $px $py $t1 $t2 $t3] ? -$min_distance : $min_distance
}
proc project_point_to_edge {px py p1 p2} {
lassign $p1 x1 y1
lassign $p2 x2 y2
[( dx = $x2 - $x1;
dy = $y2 - $y1;
$dx == 0 && $dy == 0 ? [return $p1]:;
t = ((($px - $x1) * $dx) + (($py - $y1) * $dy)) / (($dx * $dx) + ($dy * $dy));
t = max(0, min(1, $t));
$x1 + $t * $dx, $y1 + $t * $dy )]
}
proc constrain_to_triangle {px py t1 t2 t3} {
if {[point_in_triangle $px $py $t1 $t2 $t3]} {
return [($px,$py)]
}
[( edges = (($t1,$t2), ($t2,$t3), ($t3, $t1));
min_dist = 1e9;
closest_point = {})]
foreach edge $edges {(
[lassign $edge p1 p2];
proj = [project_point_to_edge $px $py $p1 $p2];
dist = hypot([lindex $proj 0] - $px, [lindex $proj 1] - $py);
$dist < $min_dist ? ( min_dist = $dist; closest_point = $proj):;
)};
return $closest_point
}
proc calculate_saturation {px py t1 t2 t3} {
lassign $t1 x1 y1
lassign $t2 x2 y2
lassign $t3 x3 y3
[( denom = ($y2-$y3)*($x1-$x3) + ($x3-$x2)*($y1-$y3);
$denom == 0 ? [return 0.0]:;
alpha = (($y2-$y3)*($px-$x3) + ($x3-$x2)*($py-$y3))/$denom ;
max(0.0, min(1.0, $alpha)) )]
}
proc calculate_value {px py t1 t2 t3} {
lassign $t1 x1 y1
lassign $t2 x2 y2
lassign $t3 x3 y3
[( denom = ($y2-$y3)*($x1-$x3) + ($x3-$x2)*($y1-$y3);
$denom == 0 ? [return 0.0]:;
alpha = (($y2-$y3)*($px-$x3) + ($x3-$x2)*($py-$y3)) / $denom;
beta = (($y3-$y1)*($px-$x3) + ($x1-$x3)*($py-$y3)) / $denom;
gamma = 1.0 - $alpha - $beta;
max(0.0, min(1.0, 1.0 - $gamma)) )]
}
#UI drawings
proc point_in_ring {x y} {(
[ variable cx
variable cy
variable radius
variable ring_thickness];
dx = $x - $cx;
dy = $y - $cy;
distance = hypot($dx, $dy);
$distance <= $radius && $distance >= $radius - $ring_thickness
)}
proc create_hue_ring_image {} {
variable canvas_size
variable radius
variable ring_thickness
variable cx
variable cy
variable info_bg
variable canvas
[( img = [image create photo -width $canvas_size -height $canvas_size];
# Convertir la couleur de fond en valeurs RGB
[lassign [winfo rgb . $info_bg] bg_r bg_g bg_b];
bg_r = $bg_r >> 8;
bg_g = $bg_g >> 8;
bg_b = $bg_b >> 8;
inner_radius = $radius - $ring_thickness;
outer_radius = $radius;
bg_color = "#FFFFFF"; )]
if {[package vsatisfies $::tcl_patchLevel 8.7-]} { append bg_color "00" }
foreach y [lseq $canvas_size] {
set row {}
foreach x [lseq $canvas_size] {
[( dx = $x - $cx;
dy = $y - $cy;
distance = hypot($dx, $dy) )]
if {$distance <= $outer_radius && $distance >= $inner_radius} {(
angle = atan2(-$dy, $dx) * 180 / acos(-1);
$angle < 0 ? (angle = $angle + 360):;
[ lassign [hsv_to_rgb $angle 1.0 1.0] r g b ];
# Calculer l'alpha pour le lissage des bords
alpha = 1.0;
($distance > $outer_radius - 1.5 || $distance < $inner_radius + 1.5) ? (
$distance > $outer_radius - 1.5 ? (alpha = 1.0-($distance-($outer_radius-1.5))/1.5)
: (alpha = ($distance - $inner_radius) / 1.5)):;
# Mélanger avec la couleur de fond
r = round($alpha * $r + (1.0 - $alpha) * $bg_r);
g = round($alpha * $g + (1.0 - $alpha) * $bg_g);
b = round($alpha * $b + (1.0 - $alpha) * $bg_b);
[lappend row [format "#%02x%02x%02x" $r $g $b]];
)} else {
lappend row $bg_color
}
}
$img put [list [join $row " "]] -to 0 $y
if {![package vsatisfies $::tcl_patchLevel 8.7-]} {
foreach {r g b} [winfo rgb . $bg_color] {(
bg_color = ($r>>8, $g>>8, $b>>8)
)}
foreach j [lseq $canvas_size] {
foreach i [lseq $canvas_size] {
if {[$img get $i $j] == $bg_color} {
$img transparency set $i $j 1
}
}
}
}
}
$canvas create image 0 0 -anchor nw -image $img -tags hue_ring
}
proc fill_triangle {hue} {
variable triangle_coords
variable sv_marker_id
variable current_saturation
variable current_value
variable canvas
variable info_bg
[( # Détecter la plateforme
is_macos = ([tk windowingsystem] eq "aqua");
# Ajuster le facteur d'échelle selon la plateforme
# Pour macOS, on utilise 1/2 (0.5) pour une meilleure qualité
# Pour Linux, on reste à 1/2 (0.5) pour éviter des problèmes de redimensionnement
scale_factor = 0.5;
# Nombre de sous-pixels pour l'antialiasing des bords (uniquement pour macOS)
subpixel_count = $is_macos ? 2 : 1;
# Largeur de la bordure à pleine résolution (en pixels)
border_width = $is_macos ? 6 : 1;
# Précalculer les valeurs RGB de la couleur de fond (pour optimisation)
[lassign [winfo rgb $canvas $info_bg] bg_r bg_g bg_b ];
bg_r = $bg_r >> 8;
bg_g = $bg_g >> 8;
bg_b = $bg_b >> 8;
info_bg = [format "#%02x%02x%02x" $bg_r $bg_g $bg_b];
# Obtenir les coordonnées du triangle
t1 = [lrange $triangle_coords 0 1];
t2 = [lrange $triangle_coords 2 3];
t3 = [lrange $triangle_coords 4 5] )]
# Effacer les éléments existants
foreach item [$canvas find withtag triangle_fill] { $canvas delete $item }
[( # Trouver les limites du triangle
xs = ([lindex $t1 0], [lindex $t2 0], [lindex $t3 0]);
ys = ([lindex $t1 1], [lindex $t2 1], [lindex $t3 1]);
minX = int(floor([lindex [lsort -real $xs] 0]));
maxX = int(ceil([lindex [lsort -real $xs] end]));
minY = int(floor([lindex [lsort -real $ys] 0]));
maxY = int(ceil([lindex [lsort -real $ys] end]));
width = $maxX - $minX;
height = $maxY - $minY;
($width <= 0 || $height <= 0) ? [return]:;
# Dimensions de l'image à résolution réduite
small_width = int(ceil($width * $scale_factor));
small_height = int(ceil($height * $scale_factor));
# Créer une image plus petite pour le calcul
smallImage = [image create photo -width $small_width -height $small_height] )]
# Calculer l'image à résolution réduite
foreach j [lseq $small_height] {
[( pixelRow = {} )]
foreach i [lseq $small_width] {
# Calculer les coordonnées correspondantes dans l'espace d'origine
[( px = $minX + $i / $scale_factor;
py = $minY + $j / $scale_factor;
# Calculer la distance au bord
distance_to_edge = [calculate_edge_distance $px $py $t1 $t2 $t3];
# Vérifier si nous sommes près du bord
is_border = ($distance_to_edge >= 0 && $distance_to_edge <= $border_width); )]
# Traitement spécial pour les bords sous macOS
if {$is_border && $is_macos} {
[( #Pour les bords sur macOS, calculer plusieurs sous-pixels pour une meilleure précision
subpixels = {};
# 3×3 sous-pixels par pixel (ajustable)
subpixel_count = 2 )]
foreach sub_j [lseq $subpixel_count] {
for sub_i [lseq $subpixel_count] {
[( sub_px = $px + ($sub_i - 0.5) / ($subpixel_count * $scale_factor);
sub_py = $py + ($sub_j - 0.5) / ($subpixel_count * $scale_factor);
sub_distance = [calculate_edge_distance $sub_px $sub_py $t1 $t2 $t3] )]
if {$sub_distance <= 1.5} {
[( sub_alpha = $sub_distance <= 0 ? 1.0 : (1.0 - ($sub_distance / 1.5)) )]
# Utiliser la fonction calculate_saturation_and_value si elle existe
# Sinon, utiliser les fonctions individuelles
if {[info procs calculate_saturation_and_value] ne ""} {
lassign [calculate_saturation_and_value $sub_px $sub_py $t1 $t2 $t3] sub_s sub_v
} else {(
sub_s = [calculate_saturation $sub_px $sub_py $t1 $t2 $t3];
sub_v = [calculate_value $sub_px $sub_py $t1 $t2 $t3];
)}
lassign [hsv_to_rgb $hue $sub_s $sub_v] sub_r sub_g sub_b
[( sub_r = round($sub_alpha * $sub_r + (1.0 - $sub_alpha) * $bg_r);
sub_g = round($sub_alpha * $sub_g + (1.0 - $sub_alpha) * $bg_g);
sub_b = round($sub_alpha * $sub_b + (1.0 - $sub_alpha) * $bg_b) )]
lappend subpixels [($sub_r, $sub_g, $sub_b)]
} else {
lappend subpixels [($bg_r, $bg_g, $bg_b)]
}
}
}
# Moyenner les sous-pixels pour obtenir la couleur finale
lassign [(0,0,0)] avg_r avg_g avg_b
foreach subpixel $subpixels {(
[lassign $subpixel sub_r sub_g sub_b];
avg_r = $avg_r + $sub_r;
avg_g = $avg_g + $sub_g;
avg_b = $avg_b + $sub_b
)}
set total_subpixels [llength $subpixels]
if {$total_subpixels > 0} {(
avg_r = int($avg_r / $total_subpixels);
avg_g = int($avg_g / $total_subpixels);
avg_b = int($avg_b / $total_subpixels)
)}
lappend pixelRow [format "#%02x%02x%02x" $avg_r $avg_g $avg_b]
} elseif {$distance_to_edge <= 1.5} {
# Traitement normal pour les pixels intérieurs ou sur Linux
[( alpha = $distance_to_edge <= 0 ? 1.0 : (1.0 - ($distance_to_edge / 1.5)) )]
# Utiliser la fonction calculate_saturation_and_value si elle existe
# Sinon, utiliser les fonctions individuelles
if {[info procs calculate_saturation_and_value] ne ""} {
lassign [calculate_saturation_and_value $px $py $t1 $t2 $t3] s v
} else {(
s = [calculate_saturation $px $py $t1 $t2 $t3];
v = [calculate_value $px $py $t1 $t2 $t3]
)}
lassign [hsv_to_rgb $hue $s $v] r g b
[( r = round($alpha * $r + (1.0 - $alpha) * $bg_r);
g = round($alpha * $g + (1.0 - $alpha) * $bg_g);
b = round($alpha * $b + (1.0 - $alpha) * $bg_b) )]
lappend pixelRow [format "#%02x%02x%02x" $r $g $b]
} else {
lappend pixelRow $info_bg
}
}
$smallImage put [list [join $pixelRow " "]] -to 0 $j
}
[( # Créer l'image finale à taille réelle :
triangleImage = [image create photo -width $width -height $height];
# Agrandir l'image (en utilisant l'opération zoom de Tk)
# zoom_factor sera 2 avec scale_factor=0.5
zoom_factor = int(ceil(1.0 / $scale_factor)) )]
$triangleImage copy $smallImage -zoom $zoom_factor
# S'assurer que l'image finale a exactement les dimensions souhaitées
if {[image width $triangleImage] != $width || [image height $triangleImage] != $height} {
set temp [image create photo -width $width -height $height]
$temp copy $triangleImage -subsample 1 1 -to 0 0 $width $height
image delete $triangleImage
set triangleImage $temp
}
# Nettoyer l'image temporaire
image delete $smallImage
# Placer l'image finale sur le canvas
$canvas create image $minX $minY -anchor nw -image $triangleImage -tags triangle_fill
$canvas raise hue_ring
$canvas raise hue_marker
if {$sv_marker_id ne ""} {
$canvas delete $sv_marker_id
}
[( # Code pour le marqueur :
marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
+ [lindex $t2 0] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 0] * (1 - $current_value);
marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
+ [lindex $t2 1] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 1] * (1 - $current_value);
marker_x = int(round($marker_x));
marker_y = int(round($marker_y));
sv_marker_id = [$canvas create oval [($marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5)] \
-fill "black" -outline "white" -tags sv_marker ]
)]
}
#color management
proc set_color_from_hex {hex_color} {
variable current_hue
variable current_saturation
variable current_value
variable triangle_coords
variable hue_marker_id
variable sv_marker_id
variable radius
variable ring_thickness
variable cx
variable cy
variable cumulative_angle
variable canvas
if {[string length $hex_color] == 7 && [string index $hex_color 0] eq "#"} {
scan [string range $hex_color 1 end] "%2x%2x%2x" r g b
} else {
error "Format de couleur invalide. Utilisez le format #RRGGBB"
}
lassign [rgb_to_hsv $r $g $b] h s v
[( current_hue = $h;
current_saturation = $s;
current_value = $v;
cumulative_angle = $h;
# Calcul de l'angle pour la rotation du triangle
current_angle = atan2($cy -[lindex $triangle_coords 1], [lindex $triangle_coords 0] - $cx)* 180 / acos(-1);
$current_angle < 0 ? (current_angle = $current_angle + 360):;
angle_diff = (a = $h - $current_angle) > 180 ? $a-360 : $a <-180 ? $a+360 : $a ;
)]
rotate_triangle $angle_diff 0
[( inner_pt = polar_to_cartesian($radius - $ring_thickness, $h, $cx, $cy);
outer_pt = polar_to_cartesian($radius, $h, $cx, $cy);
[$canvas coords $hue_marker_id {*}$inner_pt {*}$outer_pt];
t1=[lrange $triangle_coords 0 1];
t2=[lrange $triangle_coords 2 3];
t3=[lrange $triangle_coords 4 5];
marker_x = [lindex $t1 0] * ($s * $v)
+ [lindex $t2 0] * ($v * (1 - $s))
+ [lindex $t3 0] * (1 - $v);
marker_y = [lindex $t1 1] * ($s * $v)
+ [lindex $t2 1] * ($v * (1 - $s))
+ [lindex $t3 1] * (1 - $v); )]
$canvas coords $sv_marker_id [($marker_x-5, $marker_y-5, $marker_x+5, $marker_y+5 )]
fill_triangle $h
update_color_display
}
# Procédures de contrôle HSV
proc increment_hue {step} {
variable current_hue
variable cumulative_angle
variable radius
variable ring_thickness
variable cx
variable cy
variable hue_marker_id
variable canvas
[( new_hue = (h = $current_hue + $step) >= 360 ? ($h - 360) : $h;
angle_diff = $new_hue - $current_hue;
cumulative_angle = $new_hue;
# Mise à jour du marqueur de teinte
inner_pt = polar_to_cartesian($radius - $ring_thickness, $new_hue, $cx, $cy);
outer_pt = polar_to_cartesian($radius, $new_hue, $cx, $cy); )]
$canvas coords $hue_marker_id {*}$inner_pt {*}$outer_pt
rotate_triangle $angle_diff 1
update_color_display
}
proc incdec_hue {step value} {(
[variable last_incdechue];
(step = $step * ($last_incdechue - $value)) < 0 ?
( step = abs($step); [::gColorNS::decrement_hue $step])
: [::gColorNS::increment_hue $step];
last_incdechue = $value
)}
proc incdec_saturation {step value} {
variable last_incdecsaturation
set step [( $step * ($last_incdecsaturation - $value) )]
::gColorNS::decrement_saturation $step
set last_incdecsaturation $value
}
proc incdec_value {step value} {
variable last_incdecvalue
set step [($step * ($last_incdecvalue - $value))]
::gColorNS::decrement_value $step
set last_incdecvalue $value
}
proc update_scale_values {} {
variable current_hue
variable current_saturation
variable current_value
variable last_incdechue
variable last_incdecsaturation
variable last_incdecvalue
variable info_frame
foreach {component scale} {hue 1 saturation 100.0 value 100.0} {
set value [set current_$component]
set value [($value * $scale)]
set last_incdec$component $value
$info_frame.hsv_controls.$component.scale configure -value $value
}
}
proc update_all {{inpcolor ""}} {
if {$inpcolor eq {}} {
set inpcolor $::gColorNS::hexvar
}
catch {
set_color_from_hex $inpcolor
update_color_display
update_scale_values
}
return 1
}
proc decrement_hue {step} {
variable current_hue
variable cumulative_angle
variable radius
variable ring_thickness
variable cx
variable cy
variable hue_marker_id
variable canvas
[( new_hue = (h = ($current_hue - $step)) < 0 ? $h+360 : $h;
angle_diff = $new_hue - $current_hue;
cumulative_angle = $new_hue;
# Mise à jour du marqueur de teinte
inner_pt = polar_to_cartesian($radius - $ring_thickness, $new_hue, $cx, $cy);
outer_pt = polar_to_cartesian($radius, $new_hue, $cx, $cy) )]
$canvas coords $hue_marker_id {*}$inner_pt {*}$outer_pt
rotate_triangle $angle_diff 1
update_color_display
}
proc increment_saturation {step} {
variable current_saturation
variable current_value
variable current_hue
variable triangle_coords
variable sv_marker_id
variable canvas
[( new_saturation = min(1.0, $current_saturation + $step) )]
if {$new_saturation != $current_saturation} {
[( current_saturation=$new_saturation;
# Mise à jour de la position du marqueur SV
t1=[lrange $triangle_coords 0 1];
t2=[lrange $triangle_coords 2 3];
t3=[lrange $triangle_coords 4 5];
marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
+ [lindex $t2 0] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 0] * (1 - $current_value);
marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
+ [lindex $t2 1] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 1] * (1 - $current_value);
)]
$canvas coords $sv_marker_id \
[($marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5)]
fill_triangle $current_hue
update_color_display
}
}
proc decrement_saturation {step} {
variable current_saturation
variable current_value
variable current_hue
variable triangle_coords
variable sv_marker_id
variable canvas
[( new_saturation = max(0.0, $current_saturation - $step) )]
if {$new_saturation != $current_saturation} {
[( current_saturation=$new_saturation;
# Mise à jour de la position du marqueur SV
t1=[lrange $triangle_coords 0 1];
t2=[lrange $triangle_coords 2 3];
t3=[lrange $triangle_coords 4 5];
marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
+ [lindex $t2 0] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 0] * (1 - $current_value);
marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
+ [lindex $t2 1] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 1] * (1 - $current_value); )]
$canvas coords $sv_marker_id \
[( $marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5 )]
fill_triangle $current_hue
update_color_display
}
}
proc increment_value {step} {
variable current_value
variable current_saturation
variable current_hue
variable triangle_coords
variable sv_marker_id
variable canvas
[(new_value = min(1.0, $current_value + $step) )]
if {$new_value != $current_value} {
[( current_value=$new_value;
# Mise à jour de la position du marqueur SV
t1=[lrange $triangle_coords 0 1];
t2=[lrange $triangle_coords 2 3];
t3=[lrange $triangle_coords 4 5];
marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
+ [lindex $t2 0] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 0] * (1 - $current_value);
marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
+ [lindex $t2 1] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 1] * (1 - $current_value);
)]
$canvas coords $sv_marker_id \
[( $marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5 )]
fill_triangle $current_hue
update_color_display
}
}
proc decrement_value {step} {
variable current_value
variable current_saturation
variable current_hue
variable triangle_coords
variable sv_marker_id
variable canvas
[( new_value = max(0.0, $current_value - $step) )]
if {$new_value != $current_value} {
[( current_value=$new_value;
# Mise à jour de la position du marqueur SV
t1=[lrange $triangle_coords 0 1];
t2=[lrange $triangle_coords 2 3];
t3=[lrange $triangle_coords 4 5];
marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
+ [lindex $t2 0] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 0] * (1 - $current_value);
marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
+ [lindex $t2 1] * ($current_value * (1 - $current_saturation))
+ [lindex $t3 1] * (1 - $current_value); )]
$canvas coords $sv_marker_id \
[( $marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5)]
fill_triangle $current_hue
update_color_display
}
}
proc rotate_triangle {angle {update_hue 0}} {
variable triangle_coords
variable cx
variable cy
variable current_hue
variable sv_marker_id
variable hue_marker_coords
variable triangle_id
variable canvas
set rotated {}
foreach i [lseq 3 by 2] {
[( x = [lindex $triangle_coords $i];
y = [lindex $triangle_coords [($i + 1)]];
dx = $x - $cx;
dy = $y - $cy;
distance = hypot($dx, $dy);
current_angle = atan2(-$dy, $dx) * 180 / acos(-1);
new_angle = (a = $current_angle + $angle) < 0 ? $a+360 : $a > 360 ? $a-360 : $a )]
lappend rotated {*}[(polar_to_cartesian($distance,$new_angle,$cx,$cy))]
}
set triangle_coords $rotated
$canvas coords $triangle_id {*}$rotated
if {$update_hue} {(
current_hue = (h = $current_hue + $angle) < 0 ? $h+360 : $h >= 360 ? $h-360 : $h
)}
set t_h [lrange $triangle_coords 0 1]
set hue_marker_coords $t_h
if {$sv_marker_id ne ""} {(
sv_coords = [$canvas coords $sv_marker_id];
sv_x = ([lindex $sv_coords 0] + [lindex $sv_coords 2]) / 2;
sv_y = ([lindex $sv_coords 1] + [lindex $sv_coords 3]) / 2;
dx = $sv_x - $cx;
dy = $sv_y - $cy;
distance = hypot($dx, $dy);
current_angle = atan2(-$dy, $dx) * 180 / acos(-1);
new_angle = (a = $current_angle + $angle) < 0 ? $a+360 : $a >= 360 ? $a-360 : $a;
new_coords = polar_to_cartesian($distance,$new_angle,$cx,$cy);
[ $canvas coords $sv_marker_id \
[( [lindex $new_coords 0]-5, [lindex $new_coords 1]-5,
[lindex $new_coords 0]+5, [lindex $new_coords 1]+5 )] ];
)}
fill_triangle $current_hue
}
#ui update
proc throttle_update_hue_marker {x y} {
variable last_update_time
variable update_threshold_ms
set current_time [clock milliseconds]
if {![info exists last_update_time] || \
($current_time - $last_update_time) >= $update_threshold_ms} {
update_hue_marker $x $y
set last_update_time $current_time
}
}
proc update_hue_marker {x y} {
variable cx
variable cy
variable radius
variable ring_thickness
variable hue_marker_id
variable current_hue
variable cumulative_angle
variable canvas
variable pending_update_after_id
# Mettre à jour uniquement le marqueur de teinte immédiatement
[( dx = $x - $cx;
dy = $y - $cy;
new_angle = (a = atan2(-$dy, $dx) * 180 / acos(-1)) < 0 ? $a+360 : $a;
inner_pt = polar_to_cartesian($radius-$ring_thickness, $new_angle, $cx, $cy);
outer_pt = polar_to_cartesian($radius, $new_angle, $cx, $cy); )]
$canvas coords $hue_marker_id {*}$inner_pt {*}$outer_pt
# Annuler toute mise à jour en attente
if {[info exists pending_update_after_id]} {
after cancel $pending_update_after_id
}
# Programmer la mise à jour complète après un délai
set pending_update_after_id [after 0 [list ::gColorNS::complete_hue_update $new_angle $cumulative_angle]]
}
proc complete_hue_update {new_angle old_angle} {
variable cumulative_angle
[( delta_angle = (a = $new_angle - $old_angle) > 180 ? $a-360 : $a < -180 ? $a+360 : $a;
cumulative_angle = $new_angle; )]
rotate_triangle $delta_angle 1
update_color_display
}
proc update_color_display {} {
variable current_hue
variable current_saturation
variable current_value
variable info_frame
set rgb [hsv_to_rgb $current_hue $current_saturation $current_value]
set hex [format "#%02x%02x%02x" {*}$rgb]
$info_frame.color_display configure -bg $hex
set ::gColorNS::rgbvar [join $rgb {, }]
set ::gColorNS::hexvar $hex
}
proc update_sv_marker {x y} {
variable triangle_coords
variable sv_marker_id
variable current_saturation
variable current_value
variable canvas
[( t1=[lrange $triangle_coords 0 1];
t2=[lrange $triangle_coords 2 3];
t3=[lrange $triangle_coords 4 5];
constrained_point = [constrain_to_triangle $x $y $t1 $t2 $t3];
px=[lindex $constrained_point 0];
py=[lindex $constrained_point 1]; )]
$canvas coords $sv_marker_id \
[($px-5, $py-5, $px+5, $py+5)]
[( current_saturation = [calculate_saturation $px $py $t1 $t2 $t3];
current_value = [calculate_value $px $py $t1 $t2 $t3]; )]
update_color_display
}
# Procédure principale de configuration de l'interface utilisateur
proc setup_ui {parent_frame {inpcolor #ffffff} {okttl OK} {cancelttl Cancel}} {
variable canvas_size
variable radius
variable ring_thickness
variable cx
variable cy
variable triangle_coords
variable triangle_id
variable hue_marker_id
variable sv_marker_id
variable current_hue
variable current_value
variable current_saturation
variable canvas
variable info_frame
variable info_bg
variable cumulative_angle
[( main=[ttk::frame $parent_frame.m];
info=[ttk::frame $parent_frame.i];
info_frame=$info;
canvas="$main.canvas" )]
catch {set info_bg [. cget -bg]}
[( ![info exists info_bg] || $info_bg eq {} ? (info_bg = "white"):;)]
canvas $canvas -width $canvas_size -height $canvas_size -bg $info_bg -bd 0 -highlightthickness 0
if {[tk windowingsystem] in {aqua win32}} {
label $info.color_display -width 10 -height 6 -bg $inpcolor
} else {
label $info.color_display -width 12 -height 6 -bg $inpcolor
}
ttk::label $info.label_rgb -text "RGB:" -width 5
ttk::label $info.label_hex -text "Hex:" -width 5
ttk::entry $info.entry_rgb -textvariable ::gColorNS::rgbvar -width 12
ttk::separator $info.separ -orient horizontal
ttk::entry $info.entry_hex -textvariable ::gColorNS::hexvar -width 12 \
-validate focusout -validatecommand ::gColorNS::update_all
ttk::frame $info.frbutton
ttk::button $info.frbutton.button_ok -text $okttl \
-command {set ::gColorNS::isOK 1}
ttk::button $info.frbutton.button_cancel -text $cancelttl \
-command {set ::gColorNS::isOK 0}
# Frame pour les contrôles HSV
ttk::frame $info.hsv_controls
# Contrôles pour H, S, V
foreach {component} {hue saturation value} {
set label [string totitle [string range $component 0 2]]
ttk::frame $info.hsv_controls.$component
ttk::label $info.hsv_controls.$component.label -text $label: -width 5
pack $info.hsv_controls.$component -side top -fill x
pack $info.hsv_controls.$component.label -side left
set scaleto [($component eq "hue" ? 360 : 100.0)]
ttk::scale $info.hsv_controls.$component.scale \
-command [list ::gColorNS::incdec_$component \
[($component eq "hue" ? 1 : 0.01)]] \
-orient horizontal -from 0 -to $scaleto -takefocus 0
pack $info.hsv_controls.$component.scale -side left -expand 1 -fill x
}
set current_hue 0
set cumulative_angle 0
create_hue_ring_image
[( inner_radius = $radius - $ring_thickness * 1.5;
t1 = polar_to_cartesian($inner_radius,0,$cx,$cy);
t2 = polar_to_cartesian($inner_radius,120,$cx,$cy);
t3 = polar_to_cartesian($inner_radius,-120,$cx,$cy);
triangle_coords = [list {*}$t1 {*}$t2 {*}$t3];
triangle_id = [$canvas create polygon $triangle_coords -outline $info_bg -tags triangle];
inner_coords = polar_to_cartesian($radius - $ring_thickness, 0, $cx, $cy);
outer_coords = polar_to_cartesian($radius, 0, $cx, $cy);
hue_marker_id = [$canvas create line \
[lindex $inner_coords 0] [lindex $inner_coords 1] \
[lindex $outer_coords 0] [lindex $outer_coords 1] \
-fill black -width 2 -tags hue_marker];
sv_x = ([lindex $t1 0] + [lindex $t2 0] + [lindex $t3 0]) / 3;
sv_y = ([lindex $t1 1] + [lindex $t2 1] + [lindex $t3 1]) / 3;
marker_size = $ring_thickness / 2;
sv_marker_id = [$canvas create oval \
[( $sv_x - $marker_size, $sv_y - $marker_size,
$sv_x + $marker_size, $sv_y + $marker_size)] \
-fill black -outline white -tags sv_marker];
)]
bind $canvas <Button-1> {
set x %x
set y %y
if {[::gColorNS::point_in_ring $x $y]} {
set ::gColorNS::active_tag "hue_ring"
::gColorNS::update_hue_marker $x $y
} elseif {[::gColorNS::point_in_triangle $x $y \
[lrange $::gColorNS::triangle_coords 0 1] \
[lrange $::gColorNS::triangle_coords 2 3] \
[lrange $::gColorNS::triangle_coords 4 5]]} {
set ::gColorNS::active_tag "sv_area"
::gColorNS::update_sv_marker $x $y
}
}
bind $canvas <B1-Motion> {
set x %x
set y %y
if {$::gColorNS::active_tag eq "hue_ring"} {
::gColorNS::throttle_update_hue_marker $x $y
} elseif {$::gColorNS::active_tag eq "sv_area"} {
::gColorNS::update_sv_marker $x $y
}
}
bind $canvas <ButtonRelease-1> {
set ::gColorNS::active_tag ""
::gColorNS::update_scale_values
}
fill_triangle $current_hue
grid $main
grid $canvas -row 0 -column 0 -rowspan 7 -sticky nswe
grid $info -row 0 -column 1 -rowspan 7 -sticky nswe
grid $info.label_rgb -sticky w -pady 0 -padx 2 -row 0 -column 0
grid $info.entry_rgb -sticky w -pady 0 -row 0 -column 1
grid $info.label_hex -sticky w -padx 2 -row 1 -column 0
grid $info.entry_hex -sticky w -row 1 -column 1
grid $info.hsv_controls -sticky ew -padx 4 -pady 4 -row 2 -column 0 -columnspan 2
grid $info.color_display -pady 4 -row 3 -column 0 -columnspan 2
grid $info.separ -sticky nswe -row 4 -column 0 -columnspan 2
grid $info.frbutton -sticky nswe -pady 4 -row 5 -column 0 -columnspan 2
grid $info.frbutton.button_ok -sticky es -padx 2 -row 0 -column 0
grid $info.frbutton.button_cancel -sticky es -padx 2 -row 0 -column 1
grid rowconfigure $info 3 -weight 111
update_all $inpcolor
}
proc run {args} {
# Runs the picker.
# args - list of options
# Options:
# "-color value" to set HEX color value, e.g. -color #ff4b4b
# "-title ttl" to set the picker's title, e.g. -title "Choose item color"
# "-oktitle ttl" to name OK button, e.g. -oktitle "To clipboard"
# "-canceltitle ttl" to name Cancel button, e.g. -canceltitle "Otmena"
# "-geometry +X+Y" to position the picker, e.g. -geometry +100+200
# "-parent win" to set parent window path, e.g. -parent .mywin
# "-modal bool" to set modal mode (default 1), e.g. -modal 0
# "-topmost bool" to set topmost mode (default 0), e.g. -topmost 1
# parse options
foreach {opt def} {geometry - color #ffffff parent - \
title Color oktitle OK canceltitle Cancel modal 1 topmost 0} {
set $opt $def
catch {set $opt [dict get $args -$opt]}
}
# create picker's window
set win .gColor
if {$parent eq {-}} {
set parent [lindex [winfo children .] end]
}
set win [string trimright $parent .].gColor
toplevel $win
# populate the picker's window
set wfr $win.f
if {[catch {set bg [. cget -bg]}]} {set bg #d9d9d9}
frame $wfr -background $bg
setup_ui $wfr $color $oktitle $canceltitle
grid $wfr -sticky news
# wm options
wm title $win $title
wm attributes $win -topmost $topmost
if {[regexp {^\+\d+\+\d+$} $geometry]} {
wm geometry $win $geometry
}
wm protocol $win WM_DELETE_WINDOW {set ::gColorNS::isOK 0}
wm transient $win $parent
wm resizable $win 0 0
# wait for the user's choice
set wgr [grab current]
catch {grab release $wgr}
if {$modal} {catch {grab set $win}}
bind $win <Escape> {set ::gColorNS::isOK 0}
set ::gColorNS::isOK {}
after 1 ;# solves an issue with doubleclicking buttons
if {![winfo viewable $win]} {
tkwait visibility $win
}
tkwait variable ::gColorNS::isOK
catch {grab release $win}
catch {grab set $wgr}
catch {destroy $win}
# get the user's choice and return HEX value or {}
if {$::gColorNS::isOK > 0} {
return $::gColorNS::hexvar
}
return {}
}
# ________________________ EONS _________________________ #
}
if {[info exist ::argv0] && [info exist ::argv] && \
[file normalize $::argv0] eq [file normalize [info script]]} {
wm withdraw .
set clr #ffffff
while 1 {
set clr [gColorNS::run -color $clr -oktitle {To clipboard} {*}$::argv]
if {$clr eq {}} break
clipboard clear
clipboard append -type STRING $clr
}
exit
}