Posted to tcl by FLORENTIS at Wed Aug 26 00:09:56 GMT 2026view raw

  1. # It's allways better to not change what you have paste...
  2. # Adapted from "https://wiki.tcl-lang.org/page/HSV+colorPicker"
  3. # To be executed with tip-759 branch
  4.  
  5. catch {namespace delete ::gColorNS}
  6. namespace eval ::gColorNS {
  7. # Variables du namespace
  8. variable canvas_size 300
  9. variable radius [($canvas_size / 2.1)]
  10. variable ring_thickness [($radius / 8)]
  11. variable cx [($canvas_size / 2)]
  12. variable cy [($canvas_size / 2)]
  13. variable triangle_coords {}
  14. variable triangle_id
  15. variable hue_marker_id
  16. variable sv_marker_id
  17. variable cumulative_angle 0
  18. variable current_saturation 0.5
  19. variable current_value 0.5
  20. variable current_hue 0
  21. variable hue_marker_coords {}
  22. variable hue_ring_image
  23. variable active_tag ""
  24. variable canvas {}
  25. variable info_frame {}
  26. variable info_bg {}
  27. variable last_update_time 0
  28. variable update_threshold_ms 30
  29. variable pending_update_after_id 0
  30. variable rgbvar {}
  31. variable hexvar {}
  32.  
  33. # Fonctions de conversion de coordonnées et couleurs
  34. proc ::tcl::mathfunc::polar_to_cartesian {radius angle cx cy} {(
  35. radian = $angle * acos(-1) / 180;
  36. x = $cx + $radius * cos($radian);
  37. y = $cy - $radius * sin($radian);
  38. [format "%.5f" $x], [format "%.5f" $y]
  39. )}
  40.  
  41. proc hsv_to_rgb {h s v} {
  42. # "Muted" arithmetic substitution : script to set variables
  43. [( h = fmod($h, 360.0);
  44. c = $v*$s;
  45. x = $c*(1 - abs(fmod($h / 60.0, 2) - 1));
  46. m = $v-$c )]
  47.  
  48. # Inlined arithmetic substitution : complex test to assign list of variables
  49. lassign [(
  50. $h < 60 ? ($c, $x, 0)
  51. : $h < 120 ? ($x, $c, 0)
  52. : $h < 180 ? (0, $c, $x)
  53. : $h < 240 ? (0, $x, $c)
  54. : $h < 300 ? ($x, 0, $c)
  55. : ($c, 0, $x)
  56. )] r g b
  57.  
  58. # Inlined arithmetic substitution : to return a list of value
  59. [( round(($r + $m)*255), round(($g + $m)*255), round(($b + $m)*255) )]
  60. }
  61.  
  62. proc rgb_to_hsv {r g b} {(
  63. r = $r / 255.0;
  64. g = $g / 255.0;
  65. b = $b / 255.0;
  66.  
  67. cmax = max($r, max($g, $b));
  68. cmin = min($r, min($g, $b));
  69. diff = $cmax - $cmin;
  70.  
  71. abs($diff) < 0.00001 ? (h = 0)
  72. : abs($cmax - $r) < 0.00001 ? (h = 60 * fmod(($g - $b)/$diff, 6))
  73. : abs($cmax - $g) < 0.00001 ? (h = 60 * (($b - $r)/$diff + 2))
  74. : (h = 60 * (($r - $g)/$diff + 4));
  75.  
  76. $h < 0 ? (h = $h + 360):;
  77.  
  78. $cmax == 0 ? (s = 0) : (s = $diff/$cmax);
  79.  
  80. ($h,$s,$cmax)
  81. )}
  82.  
  83. #geometry functions
  84. proc point_in_triangle {px py t1 t2 t3} {(
  85. [lassign $t1 x1 y1
  86. lassign $t2 x2 y2
  87. lassign $t3 x3 y3];
  88.  
  89. (denom = ($y2-$y3)*($x1-$x3) + ($x3-$x2)*($y1-$y3)) == 0 ? [return 0] :;
  90.  
  91. a = (($y2-$y3)*($px-$x3)+($x3-$x2)*($py-$y3)) / $denom;
  92. b = (($y3-$y1)*($px-$x3)+($x1-$x3)*($py-$y3)) / $denom;
  93. c = 1.0 - $a - $b;
  94.  
  95. $a >= 0 && $b >= 0 && $c >= 0
  96. )}
  97.  
  98. proc calculate_edge_distance {px py t1 t2 t3} {
  99. [( edges = (($t1,$t2),($t2,$t3),($t3,$t1));
  100. min_distance = 999999999 )]
  101.  
  102. foreach edge $edges {
  103. lassign $edge p1 p2
  104. lassign $p1 x1 y1
  105. lassign $p2 x2 y2
  106.  
  107. [( A = $y2-$y1; B = $x1-$x2;
  108. C = $x2*$y1 - $x1*$y2;
  109. distance = abs($A * $px + $B * $py + $C) / hypot($A, $B);
  110. $distance < $min_distance ? (min_distance = $distance) :; )]
  111. }
  112.  
  113. [( [point_in_triangle $px $py $t1 $t2 $t3] ? -$min_distance : $min_distance )]
  114. }
  115.  
  116. proc project_point_to_edge {px py p1 p2} {
  117. lassign $p1 x1 y1
  118. lassign $p2 x2 y2
  119.  
  120. [( dx = $x2 - $x1;
  121. dy = $y2 - $y1;
  122.  
  123. $dx == 0 && $dy == 0 ? [return $p1]:;
  124.  
  125. t = ((($px - $x1) * $dx) + (($py - $y1) * $dy)) / (($dx * $dx) + ($dy * $dy));
  126. t = max(0, min(1, $t));
  127.  
  128. $x1 + $t * $dx, $y1 + $t * $dy )]
  129. }
  130.  
  131. proc constrain_to_triangle {px py t1 t2 t3} {
  132. if {[point_in_triangle $px $py $t1 $t2 $t3]} {
  133. return [($px,$py)]
  134. }
  135.  
  136. [( edges = (($t1,$t2), ($t2,$t3), ($t3, $t1));
  137. min_dist = 1e9;
  138. closest_point = {})]
  139.  
  140. foreach edge $edges {(
  141. [lassign $edge p1 p2];
  142. proj = [project_point_to_edge $px $py $p1 $p2];
  143. dist = hypot([lindex $proj 0] - $px, [lindex $proj 1] - $py);
  144.  
  145. $dist < $min_dist ? (
  146. min_dist = $dist;
  147. closest_point = $proj):;
  148. )};
  149.  
  150. return $closest_point
  151. }
  152.  
  153. proc calculate_saturation {px py t1 t2 t3} {
  154. lassign $t1 x1 y1
  155. lassign $t2 x2 y2
  156. lassign $t3 x3 y3
  157. [( denom = ($y2-$y3)*($x1-$x3) + ($x3-$x2)*($y1-$y3);
  158. $denom == 0 ? [return 0.0]:;
  159. alpha = (($y2-$y3)*($px-$x3) + ($x3-$x2)*($py-$y3))/$denom ;
  160. max(0.0, min(1.0, $alpha)) )]
  161. }
  162.  
  163.  
  164. proc calculate_value {px py t1 t2 t3} {
  165. lassign $t1 x1 y1
  166. lassign $t2 x2 y2
  167. lassign $t3 x3 y3
  168. [( denom = ($y2-$y3)*($x1-$x3) + ($x3-$x2)*($y1-$y3);
  169. $denom == 0 ? [return 0.0]:;
  170. alpha = (($y2-$y3)*($px-$x3) + ($x3-$x2)*($py-$y3)) / $denom;
  171. beta = (($y3-$y1)*($px-$x3) + ($x1-$x3)*($py-$y3)) / $denom;
  172. gamma = 1.0 - $alpha - $beta;
  173.  
  174. max(0.0, min(1.0, 1.0 - $gamma)) )]
  175. }
  176.  
  177. #UI drawings
  178. proc point_in_ring {x y} {(
  179. [ variable cx
  180. variable cy
  181. variable radius
  182. variable ring_thickness];
  183.  
  184. dx = $x - $cx;
  185. dy = $y - $cy;
  186. distance = hypot($dx, $dy);
  187.  
  188. $distance <= $radius && $distance >= $radius - $ring_thickness
  189. )}
  190.  
  191. proc create_hue_ring_image {} {
  192. variable canvas_size
  193. variable radius
  194. variable ring_thickness
  195. variable cx
  196. variable cy
  197. variable info_bg
  198. variable canvas
  199.  
  200. [( img = [image create photo -width $canvas_size -height $canvas_size];
  201.  
  202. # Convertir la couleur de fond en valeurs RGB
  203. [lassign [winfo rgb . $info_bg] bg_r bg_g bg_b];
  204. bg_r = $bg_r >> 8;
  205. bg_g = $bg_g >> 8;
  206. bg_b = $bg_b >> 8;
  207.  
  208. inner_radius = $radius - $ring_thickness;
  209. outer_radius = $radius;
  210.  
  211. bg_color = "#FFFFFF"; )]
  212.  
  213. if {[package vsatisfies $::tcl_patchLevel 8.7-]} { append bg_color "00" }
  214.  
  215. foreach y [lseq $canvas_size] {
  216. set row {}
  217. foreach x [lseq $canvas_size] {
  218. [( dx = $x - $cx;
  219. dy = $y - $cy;
  220. distance = hypot($dx, $dy) )]
  221.  
  222. if {$distance <= $outer_radius && $distance >= $inner_radius} {(
  223.  
  224. angle = atan2(-$dy, $dx) * 180 / acos(-1);
  225. $angle < 0 ? (angle = $angle + 360):;
  226.  
  227. [ lassign [hsv_to_rgb $angle 1.0 1.0] r g b ];
  228.  
  229. # Calculer l'alpha pour le lissage des bords
  230. alpha = 1.0;
  231.  
  232. ($distance > $outer_radius - 1.5 || $distance < $inner_radius + 1.5) ? (
  233. $distance > $outer_radius - 1.5 ? (alpha = 1.0-($distance-($outer_radius-1.5))/1.5)
  234. : (alpha = ($distance - $inner_radius) / 1.5)):;
  235.  
  236. # Mélanger avec la couleur de fond
  237. r = round($alpha * $r + (1.0 - $alpha) * $bg_r);
  238. g = round($alpha * $g + (1.0 - $alpha) * $bg_g);
  239. b = round($alpha * $b + (1.0 - $alpha) * $bg_b);
  240.  
  241. [lappend row [format "#%02x%02x%02x" $r $g $b]];
  242. )} else {
  243. lappend row $bg_color
  244. }
  245. }
  246. $img put [list [join $row " "]] -to 0 $y
  247.  
  248. if {![package vsatisfies $::tcl_patchLevel 8.7-]} {
  249. foreach {r g b} [winfo rgb . $bg_color] {(
  250. bg_color = ($r>>8, $g>>8, $b>>8)
  251. )}
  252. foreach j [lseq $canvas_size] {
  253. foreach i [lseq $canvas_size] {
  254. if {[$img get $i $j] == $bg_color} {
  255. $img transparency set $i $j 1
  256. }
  257. }
  258. }
  259. }
  260. }
  261. $canvas create image 0 0 -anchor nw -image $img -tags hue_ring
  262. }
  263.  
  264. proc fill_triangle {hue} {
  265. variable triangle_coords
  266. variable sv_marker_id
  267. variable current_saturation
  268. variable current_value
  269. variable canvas
  270. variable info_bg
  271.  
  272. [( # Détecter la plateforme
  273. is_macos = ([tk windowingsystem] eq "aqua");
  274. # Ajuster le facteur d'échelle selon la plateforme
  275. # Pour macOS, on utilise 1/2 (0.5) pour une meilleure qualité
  276. # Pour Linux, on reste à 1/2 (0.5) pour éviter des problèmes de redimensionnement
  277. scale_factor = 0.5;
  278.  
  279. # Nombre de sous-pixels pour l'antialiasing des bords (uniquement pour macOS)
  280. subpixel_count = $is_macos ? 2 : 1;
  281.  
  282. # Largeur de la bordure à pleine résolution (en pixels)
  283. border_width = $is_macos ? 6 : 1;
  284.  
  285. # Précalculer les valeurs RGB de la couleur de fond (pour optimisation)
  286. [lassign [winfo rgb $canvas $info_bg] bg_r bg_g bg_b ];
  287. bg_r = $bg_r >> 8;
  288. bg_g = $bg_g >> 8;
  289. bg_b = $bg_b >> 8;
  290. info_bg = [format "#%02x%02x%02x" $bg_r $bg_g $bg_b];
  291.  
  292. # Obtenir les coordonnées du triangle
  293. t1 = [lrange $triangle_coords 0 1];
  294. t2 = [lrange $triangle_coords 2 3];
  295. t3 = [lrange $triangle_coords 4 5]; )]; #end SubArithme
  296.  
  297. # Effacer les éléments existants
  298. foreach item [$canvas find withtag triangle_fill] { $canvas delete $item }
  299.  
  300. [( #<SubArithme>
  301. # Trouver les limites du triangle
  302. xs = ([lindex $t1 0], [lindex $t2 0], [lindex $t3 0]);
  303. ys = ([lindex $t1 1], [lindex $t2 1], [lindex $t3 1]);
  304.  
  305. minX = int(floor([lindex [lsort -real $xs] 0]));
  306. maxX = int(ceil([lindex [lsort -real $xs] end]));
  307. minY = int(floor([lindex [lsort -real $ys] 0]));
  308. maxY = int(ceil([lindex [lsort -real $ys] end]));
  309.  
  310. width = $maxX - $minX;
  311. height = $maxY - $minY;
  312.  
  313. ($width <= 0 || $height <= 0) ? [return]:;
  314.  
  315. # Dimensions de l'image à résolution réduite
  316. small_width = int(ceil($width * $scale_factor));
  317. small_height = int(ceil($height * $scale_factor));
  318.  
  319. # Créer une image plus petite pour le calcul
  320. smallImage = [image create photo -width $small_width -height $small_height];
  321. )]; # </SubArithme>
  322.  
  323. # Calculer l'image à résolution réduite
  324. foreach j [lseq $small_height] {
  325. [( pixelRow = {} )]
  326. foreach i [lseq $small_width] {
  327. # Calculer les coordonnées correspondantes dans l'espace d'origine
  328. [( px = $minX + $i / $scale_factor;
  329. py = $minY + $j / $scale_factor;
  330.  
  331. # Calculer la distance au bord
  332. distance_to_edge = [calculate_edge_distance $px $py $t1 $t2 $t3];
  333.  
  334. # Vérifier si nous sommes près du bord
  335. is_border = ($distance_to_edge >= 0 && $distance_to_edge <= $border_width); )]
  336.  
  337. # Traitement spécial pour les bords sous macOS
  338. if {$is_border && $is_macos} {
  339. [( #Pour les bords sur macOS, calculer plusieurs sous-pixels pour une meilleure précision
  340. subpixels = {};
  341. # 3×3 sous-pixels par pixel (ajustable)
  342. subpixel_count = 2 )]
  343.  
  344. foreach sub_j [lseq $subpixel_count] {
  345. foreach sub_i [lseq $subpixel_count] {
  346. [( sub_px = $px + ($sub_i - 0.5) / ($subpixel_count * $scale_factor);
  347. sub_py = $py + ($sub_j - 0.5) / ($subpixel_count * $scale_factor);
  348. sub_distance = [calculate_edge_distance $sub_px $sub_py $t1 $t2 $t3] )]
  349.  
  350. if {$sub_distance <= 1.5} {
  351. [( sub_alpha = $sub_distance <= 0 ? 1.0 : (1.0 - ($sub_distance / 1.5)) )]
  352.  
  353. # Utiliser la fonction calculate_saturation_and_value si elle existe
  354. # Sinon, utiliser les fonctions individuelles
  355. if {[info procs calculate_saturation_and_value] ne ""} {
  356. lassign [calculate_saturation_and_value $sub_px $sub_py $t1 $t2 $t3] sub_s sub_v
  357. } else {(
  358. sub_s = [calculate_saturation $sub_px $sub_py $t1 $t2 $t3];
  359. sub_v = [calculate_value $sub_px $sub_py $t1 $t2 $t3];
  360. )}
  361.  
  362. lassign [hsv_to_rgb $hue $sub_s $sub_v] sub_r sub_g sub_b
  363.  
  364. [( sub_r = round($sub_alpha * $sub_r + (1.0 - $sub_alpha) * $bg_r);
  365. sub_g = round($sub_alpha * $sub_g + (1.0 - $sub_alpha) * $bg_g);
  366. sub_b = round($sub_alpha * $sub_b + (1.0 - $sub_alpha) * $bg_b);
  367. )]
  368.  
  369. lappend subpixels [($sub_r, $sub_g, $sub_b)]
  370. } else {
  371. lappend subpixels [($bg_r, $bg_g, $bg_b)]
  372. }
  373. }
  374. }
  375.  
  376. # Moyenner les sous-pixels pour obtenir la couleur finale
  377. lassign [(0,0,0)] avg_r avg_g avg_b
  378.  
  379. foreach subpixel $subpixels {(
  380. [lassign $subpixel sub_r sub_g sub_b];
  381. avg_r = $avg_r + $sub_r;
  382. avg_g = $avg_g + $sub_g;
  383. avg_b = $avg_b + $sub_b
  384. )}
  385.  
  386. set total_subpixels [llength $subpixels]
  387.  
  388. if {$total_subpixels > 0} {(
  389. avg_r = int($avg_r / $total_subpixels);
  390. avg_g = int($avg_g / $total_subpixels);
  391. avg_b = int($avg_b / $total_subpixels)
  392. )}
  393.  
  394. lappend pixelRow [format "#%02x%02x%02x" $avg_r $avg_g $avg_b]
  395.  
  396. } elseif {$distance_to_edge <= 1.5} {
  397. # Traitement normal pour les pixels intérieurs ou sur Linux
  398. [( alpha = $distance_to_edge <= 0 ? 1.0 : (1.0 - ($distance_to_edge / 1.5)) )]
  399.  
  400. # Utiliser la fonction calculate_saturation_and_value si elle existe
  401. # Sinon, utiliser les fonctions individuelles
  402. if {[info procs calculate_saturation_and_value] ne ""} {
  403. lassign [calculate_saturation_and_value $px $py $t1 $t2 $t3] s v
  404. } else {(
  405. s = [calculate_saturation $px $py $t1 $t2 $t3];
  406. v = [calculate_value $px $py $t1 $t2 $t3];
  407. )}
  408.  
  409. lassign [hsv_to_rgb $hue $s $v] r g b
  410.  
  411. [( r = round($alpha * $r + (1.0 - $alpha) * $bg_r);
  412. g = round($alpha * $g + (1.0 - $alpha) * $bg_g);
  413. b = round($alpha * $b + (1.0 - $alpha) * $bg_b); )]
  414.  
  415. lappend pixelRow [format "#%02x%02x%02x" $r $g $b]
  416. } else {
  417. lappend pixelRow $info_bg
  418. }
  419. }
  420.  
  421. $smallImage put [list [join $pixelRow " "]] -to 0 $j
  422. }
  423. [( # Créer l'image finale à taille réelle :
  424. triangleImage = [image create photo -width $width -height $height];
  425.  
  426. # Agrandir l'image (en utilisant l'opération zoom de Tk)
  427. # zoom_factor sera 2 avec scale_factor=0.5
  428. zoom_factor = int(ceil(1.0 / $scale_factor)) )]
  429. $triangleImage copy $smallImage -zoom $zoom_factor
  430.  
  431. # S'assurer que l'image finale a exactement les dimensions souhaitées
  432. if {[image width $triangleImage] != $width || [image height $triangleImage] != $height} {
  433. set temp [image create photo -width $width -height $height]
  434. $temp copy $triangleImage -subsample 1 1 -to 0 0 $width $height
  435. image delete $triangleImage
  436. set triangleImage $temp
  437. }
  438.  
  439. # Nettoyer l'image temporaire
  440. image delete $smallImage
  441.  
  442. # Placer l'image finale sur le canvas
  443. $canvas create image $minX $minY -anchor nw -image $triangleImage -tags triangle_fill
  444. $canvas raise hue_ring
  445. $canvas raise hue_marker
  446.  
  447. if {$sv_marker_id ne ""} {
  448. $canvas delete $sv_marker_id
  449. }
  450.  
  451. [( # Code pour le marqueur :
  452. marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
  453. + [lindex $t2 0] * ($current_value * (1 - $current_saturation))
  454. + [lindex $t3 0] * (1 - $current_value);
  455.  
  456. marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
  457. + [lindex $t2 1] * ($current_value * (1 - $current_saturation))
  458. + [lindex $t3 1] * (1 - $current_value);
  459.  
  460. marker_x = int(round($marker_x));
  461. marker_y = int(round($marker_y));
  462.  
  463. sv_marker_id = [$canvas create oval [($marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5)] \
  464. -fill "black" -outline "white" -tags sv_marker ]
  465. )]
  466. }
  467.  
  468. #color management
  469. proc set_color_from_hex {hex_color} {
  470. variable current_hue
  471. variable current_saturation
  472. variable current_value
  473. variable triangle_coords
  474. variable hue_marker_id
  475. variable sv_marker_id
  476. variable radius
  477. variable ring_thickness
  478. variable cx
  479. variable cy
  480. variable cumulative_angle
  481. variable canvas
  482.  
  483. if {[string length $hex_color] == 7 && [string index $hex_color 0] eq "#"} {
  484. scan [string range $hex_color 1 end] "%2x%2x%2x" r g b
  485. } else {
  486. error "Format de couleur invalide. Utilisez le format #RRGGBB"
  487. }
  488.  
  489. lassign [rgb_to_hsv $r $g $b] h s v
  490.  
  491. [( current_hue = $h;
  492. current_saturation = $s;
  493. current_value = $v;
  494. cumulative_angle = $h;
  495.  
  496. # Calcul de l'angle pour la rotation du triangle
  497. current_angle = atan2($cy -[lindex $triangle_coords 1], [lindex $triangle_coords 0] - $cx)* 180 / acos(-1);
  498.  
  499. $current_angle < 0 ? (current_angle = $current_angle + 360):;
  500.  
  501. angle_diff = $h - $current_angle;
  502.  
  503. $angle_diff > 180 ? ( angle_diff = $angle_diff - 360)
  504. : $angle_diff < -180 ? (angle_diff = $angle_diff + 360) :; )]
  505.  
  506. rotate_triangle $angle_diff 0
  507.  
  508. [( inner_pt = polar_to_cartesian($radius - $ring_thickness, $h, $cx, $cy);
  509. outer_pt = polar_to_cartesian($radius, $h, $cx, $cy);
  510.  
  511. [$canvas coords $hue_marker_id {*}$inner_pt {*}$outer_pt];
  512.  
  513. t1=[lrange $triangle_coords 0 1];
  514. t2=[lrange $triangle_coords 2 3];
  515. t3=[lrange $triangle_coords 4 5];
  516.  
  517. marker_x = [lindex $t1 0] * ($s * $v)
  518. + [lindex $t2 0] * ($v * (1 - $s))
  519. + [lindex $t3 0] * (1 - $v);
  520.  
  521. marker_y = [lindex $t1 1] * ($s * $v)
  522. + [lindex $t2 1] * ($v * (1 - $s))
  523. + [lindex $t3 1] * (1 - $v); )]
  524.  
  525. $canvas coords $sv_marker_id [($marker_x-5, $marker_y-5, $marker_x+5, $marker_y+5 )]
  526.  
  527. fill_triangle $h
  528. update_color_display
  529. }
  530.  
  531. # Procédures de contrôle HSV
  532. proc increment_hue {step} {
  533. variable current_hue
  534. variable cumulative_angle
  535. variable radius
  536. variable ring_thickness
  537. variable cx
  538. variable cy
  539. variable hue_marker_id
  540. variable canvas
  541.  
  542. [( new_hue = (h = $current_hue + $step) >= 360 ? ($h - 360) : $h;
  543. angle_diff = $new_hue - $current_hue;
  544. cumulative_angle = $new_hue;
  545.  
  546. # Mise à jour du marqueur de teinte
  547. inner_pt = polar_to_cartesian($radius - $ring_thickness, $new_hue, $cx, $cy);
  548. outer_pt = polar_to_cartesian($radius, $new_hue, $cx, $cy); )]
  549.  
  550. $canvas coords $hue_marker_id {*}$inner_pt {*}$outer_pt
  551.  
  552. rotate_triangle $angle_diff 1
  553. update_color_display
  554. }
  555.  
  556. proc incdec_hue {step value} {(
  557. [variable last_incdechue];
  558. (step = $step * ($last_incdechue - $value)) < 0 ?
  559. ( step = abs($step); [::gColorNS::decrement_hue $step];)
  560. : [::gColorNS::increment_hue $step];
  561.  
  562. last_incdechue = $value
  563. )}
  564.  
  565. proc incdec_saturation {step value} {
  566. variable last_incdecsaturation
  567. set step [($step * ($last_incdecsaturation - $value))]
  568. ::gColorNS::decrement_saturation $step
  569. set last_incdecsaturation $value
  570. }
  571.  
  572. proc incdec_value {step value} {
  573. variable last_incdecvalue
  574. set step [($step * ($last_incdecvalue - $value))]
  575. ::gColorNS::decrement_value $step
  576. set last_incdecvalue $value
  577. }
  578.  
  579. proc update_scale_values {} {
  580. variable current_hue
  581. variable current_saturation
  582. variable current_value
  583. variable last_incdechue
  584. variable last_incdecsaturation
  585. variable last_incdecvalue
  586. variable info_frame
  587. foreach {component scale} {hue 1 saturation 100.0 value 100.0} {
  588. set value [set current_$component]
  589. set value [($value * $scale)]
  590. set last_incdec$component $value
  591. $info_frame.hsv_controls.$component.scale configure -value $value
  592. }
  593. }
  594.  
  595. proc update_all {{inpcolor ""}} {
  596. if {$inpcolor eq {}} {
  597. set inpcolor $::gColorNS::hexvar
  598. }
  599. catch {
  600. set_color_from_hex $inpcolor
  601. update_color_display
  602. update_scale_values
  603. }
  604. return 1
  605. }
  606.  
  607. proc decrement_hue {step} {
  608. variable current_hue
  609. variable cumulative_angle
  610. variable radius
  611. variable ring_thickness
  612. variable cx
  613. variable cy
  614. variable hue_marker_id
  615. variable canvas
  616.  
  617. [( new_hue = (h = ($current_hue - $step)) < 0 ? $h+360 : $h;
  618. angle_diff = $new_hue - $current_hue;
  619. cumulative_angle = $new_hue;
  620.  
  621. # Mise à jour du marqueur de teinte
  622. inner_pt = polar_to_cartesian($radius - $ring_thickness, $new_hue, $cx, $cy);
  623. outer_pt = polar_to_cartesian($radius, $new_hue, $cx, $cy) )]
  624.  
  625. $canvas coords $hue_marker_id {*}$inner_pt {*}$outer_pt
  626. rotate_triangle $angle_diff 1
  627. update_color_display
  628. }
  629.  
  630. proc increment_saturation {step} {
  631. variable current_saturation
  632. variable current_value
  633. variable current_hue
  634. variable triangle_coords
  635. variable sv_marker_id
  636. variable canvas
  637.  
  638. [( new_saturation = min(1.0, $current_saturation + $step) )]
  639.  
  640. if {$new_saturation != $current_saturation} {
  641. [( current_saturation=$new_saturation;
  642.  
  643. # Mise à jour de la position du marqueur SV
  644. t1=[lrange $triangle_coords 0 1];
  645. t2=[lrange $triangle_coords 2 3];
  646. t3=[lrange $triangle_coords 4 5];
  647.  
  648. marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
  649. + [lindex $t2 0] * ($current_value * (1 - $current_saturation))
  650. + [lindex $t3 0] * (1 - $current_value);
  651.  
  652. marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
  653. + [lindex $t2 1] * ($current_value * (1 - $current_saturation))
  654. + [lindex $t3 1] * (1 - $current_value);
  655. )]
  656.  
  657. $canvas coords $sv_marker_id \
  658. [($marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5)]
  659.  
  660. fill_triangle $current_hue
  661. update_color_display
  662. }
  663. }
  664.  
  665. proc decrement_saturation {step} {
  666. variable current_saturation
  667. variable current_value
  668. variable current_hue
  669. variable triangle_coords
  670. variable sv_marker_id
  671. variable canvas
  672.  
  673. [( new_saturation = max(0.0, $current_saturation - $step) )]
  674. if {$new_saturation != $current_saturation} {
  675. [( current_saturation=$new_saturation;
  676. # Mise à jour de la position du marqueur SV
  677. t1=[lrange $triangle_coords 0 1];
  678. t2=[lrange $triangle_coords 2 3];
  679. t3=[lrange $triangle_coords 4 5];
  680.  
  681. marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
  682. + [lindex $t2 0] * ($current_value * (1 - $current_saturation))
  683. + [lindex $t3 0] * (1 - $current_value);
  684. marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
  685. + [lindex $t2 1] * ($current_value * (1 - $current_saturation))
  686. + [lindex $t3 1] * (1 - $current_value); )]
  687.  
  688. $canvas coords $sv_marker_id \
  689. [( $marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5 )]
  690.  
  691. fill_triangle $current_hue
  692. update_color_display
  693. }
  694. }
  695.  
  696. proc increment_value {step} {
  697. variable current_value
  698. variable current_saturation
  699. variable current_hue
  700. variable triangle_coords
  701. variable sv_marker_id
  702. variable canvas
  703.  
  704. [(new_value = min(1.0, $current_value + $step) )]
  705. if {$new_value != $current_value} {
  706. [( current_value=$new_value;
  707. # Mise à jour de la position du marqueur SV
  708. t1=[lrange $triangle_coords 0 1];
  709. t2=[lrange $triangle_coords 2 3];
  710. t3=[lrange $triangle_coords 4 5];
  711.  
  712. marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
  713. + [lindex $t2 0] * ($current_value * (1 - $current_saturation))
  714. + [lindex $t3 0] * (1 - $current_value);
  715. marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
  716. + [lindex $t2 1] * ($current_value * (1 - $current_saturation))
  717. + [lindex $t3 1] * (1 - $current_value);
  718. )]
  719.  
  720. $canvas coords $sv_marker_id \
  721. [( $marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5 )]
  722.  
  723. fill_triangle $current_hue
  724. update_color_display
  725. }
  726. }
  727.  
  728. proc decrement_value {step} {
  729. variable current_value
  730. variable current_saturation
  731. variable current_hue
  732. variable triangle_coords
  733. variable sv_marker_id
  734. variable canvas
  735.  
  736. [( new_value = max(0.0, $current_value - $step) )]
  737. if {$new_value != $current_value} {
  738. [( current_value=$new_value;
  739. # Mise à jour de la position du marqueur SV
  740. t1=[lrange $triangle_coords 0 1];
  741. t2=[lrange $triangle_coords 2 3];
  742. t3=[lrange $triangle_coords 4 5];
  743.  
  744. marker_x = [lindex $t1 0] * ($current_saturation * $current_value)
  745. + [lindex $t2 0] * ($current_value * (1 - $current_saturation))
  746. + [lindex $t3 0] * (1 - $current_value);
  747.  
  748. marker_y = [lindex $t1 1] * ($current_saturation * $current_value)
  749. + [lindex $t2 1] * ($current_value * (1 - $current_saturation))
  750. + [lindex $t3 1] * (1 - $current_value); )]
  751.  
  752. $canvas coords $sv_marker_id \
  753. [( $marker_x - 5, $marker_y - 5, $marker_x + 5, $marker_y + 5)]
  754.  
  755. fill_triangle $current_hue
  756. update_color_display
  757. }
  758. }
  759.  
  760. proc rotate_triangle {angle {update_hue 0}} {
  761. variable triangle_coords
  762. variable cx
  763. variable cy
  764. variable current_hue
  765. variable sv_marker_id
  766. variable hue_marker_coords
  767. variable triangle_id
  768. variable canvas
  769.  
  770. set rotated {}
  771. foreach i [lseq 3 by 2] {
  772. [( x = [lindex $triangle_coords $i];
  773. y = [lindex $triangle_coords [($i + 1)]];
  774. dx = $x - $cx;
  775. dy = $y - $cy;
  776. distance = hypot($dx, $dy);
  777. current_angle = atan2(-$dy, $dx) * 180 / acos(-1);
  778. new_angle = $current_angle + $angle;
  779. $new_angle < 0 ? (new_angle = $new_angle + 360)
  780. : $new_angle > 360 ? (new_angle = $new_angle - 360)
  781. :; )]
  782.  
  783. lappend rotated {*}[(polar_to_cartesian($distance,$new_angle,$cx,$cy))]
  784. }
  785.  
  786. set triangle_coords $rotated
  787. $canvas coords $triangle_id {*}$rotated
  788.  
  789. if {$update_hue} {(
  790. current_hue = (h = $current_hue + $angle) < 0 ? $h+360 : $h >= 360 ? $h-360 : $h
  791. )}
  792.  
  793. set t_h [lrange $triangle_coords 0 1]
  794. set hue_marker_coords $t_h
  795.  
  796. if {$sv_marker_id ne ""} {(
  797. sv_coords = [$canvas coords $sv_marker_id];
  798. sv_x = ([lindex $sv_coords 0] + [lindex $sv_coords 2]) / 2;
  799. sv_y = ([lindex $sv_coords 1] + [lindex $sv_coords 3]) / 2;
  800. dx = $sv_x - $cx;
  801. dy = $sv_y - $cy;
  802. distance = hypot($dx, $dy);
  803. current_angle = atan2(-$dy, $dx) * 180 / acos(-1);
  804. new_angle = (a = $current_angle + $angle) < 0 ? $a+360 : $a >= 360 ? $a-360 : $a;
  805.  
  806. new_coords = polar_to_cartesian($distance,$new_angle,$cx,$cy);
  807. [ $canvas coords $sv_marker_id \
  808. [( [lindex $new_coords 0]-5, [lindex $new_coords 1]-5,
  809. [lindex $new_coords 0]+5, [lindex $new_coords 1]+5 )] ];
  810. )}
  811.  
  812. fill_triangle $current_hue
  813. }
  814.  
  815. #ui update
  816. proc throttle_update_hue_marker {x y} {
  817. variable last_update_time
  818. variable update_threshold_ms
  819.  
  820. set current_time [clock milliseconds]
  821. if {![info exists last_update_time] || \
  822. ($current_time - $last_update_time) >= $update_threshold_ms} {
  823. update_hue_marker $x $y
  824. set last_update_time $current_time
  825. }
  826. }
  827.  
  828. proc update_hue_marker {x y} {
  829. variable cx
  830. variable cy
  831. variable radius
  832. variable ring_thickness
  833. variable hue_marker_id
  834. variable current_hue
  835. variable cumulative_angle
  836. variable canvas
  837. variable pending_update_after_id
  838.  
  839. # Mettre à jour uniquement le marqueur de teinte immédiatement
  840. [( dx = $x - $cx;
  841. dy = $y - $cy;
  842. new_angle = atan2(-$dy, $dx) * 180 / acos(-1);
  843. $new_angle < 0 ? (new_angle = $new_angle + 360):;
  844.  
  845. inner_pt = polar_to_cartesian($radius-$ring_thickness, $new_angle, $cx, $cy);
  846. outer_pt = polar_to_cartesian($radius, $new_angle, $cx, $cy); )]
  847.  
  848. $canvas coords $hue_marker_id {*}$inner_pt {*}$outer_pt
  849.  
  850. # Annuler toute mise à jour en attente
  851. if {[info exists pending_update_after_id]} {
  852. after cancel $pending_update_after_id
  853. }
  854.  
  855. # Programmer la mise à jour complète après un délai
  856. set pending_update_after_id [after 0 [list ::gColorNS::complete_hue_update $new_angle $cumulative_angle]]
  857. }
  858.  
  859. proc complete_hue_update {new_angle old_angle} {
  860. variable cumulative_angle
  861.  
  862. [( delta_angle = (a = $new_angle - $old_angle) > 180 ? $a-360 : $a < -180 ? $a+360 : $a;
  863. cumulative_angle = $new_angle; )]
  864.  
  865. rotate_triangle $delta_angle 1
  866. update_color_display
  867. }
  868.  
  869. proc update_color_display {} {
  870. variable current_hue
  871. variable current_saturation
  872. variable current_value
  873. variable info_frame
  874.  
  875. set rgb [hsv_to_rgb $current_hue $current_saturation $current_value]
  876. set hex [format "#%02x%02x%02x" {*}$rgb]
  877.  
  878. $info_frame.color_display configure -bg $hex
  879. set ::gColorNS::rgbvar [join $rgb {, }]
  880. set ::gColorNS::hexvar $hex
  881. }
  882.  
  883. proc update_sv_marker {x y} {
  884. variable triangle_coords
  885. variable sv_marker_id
  886. variable current_saturation
  887. variable current_value
  888. variable canvas
  889.  
  890. [( t1=[lrange $triangle_coords 0 1];
  891. t2=[lrange $triangle_coords 2 3];
  892. t3=[lrange $triangle_coords 4 5];
  893.  
  894. constrained_point = [constrain_to_triangle $x $y $t1 $t2 $t3];
  895. px=[lindex $constrained_point 0];
  896. py=[lindex $constrained_point 1]; )]
  897.  
  898. $canvas coords $sv_marker_id \
  899. [($px-5, $py-5, $px+5, $py+5)]
  900.  
  901. [( current_saturation = [calculate_saturation $px $py $t1 $t2 $t3];
  902. current_value = [calculate_value $px $py $t1 $t2 $t3]; )]
  903.  
  904. update_color_display
  905. }
  906.  
  907. # Procédure principale de configuration de l'interface utilisateur
  908. proc setup_ui {parent_frame {inpcolor #ffffff} {okttl OK} {cancelttl Cancel}} {
  909. variable canvas_size
  910. variable radius
  911. variable ring_thickness
  912. variable cx
  913. variable cy
  914. variable triangle_coords
  915. variable triangle_id
  916. variable hue_marker_id
  917. variable sv_marker_id
  918. variable current_hue
  919. variable current_value
  920. variable current_saturation
  921. variable canvas
  922. variable info_frame
  923. variable info_bg
  924. variable cumulative_angle
  925.  
  926. [( main=[ttk::frame $parent_frame.m];
  927. info=[ttk::frame $parent_frame.i];
  928. info_frame=$info;
  929. canvas="$main.canvas" )]
  930.  
  931. catch {set info_bg [. cget -bg]}
  932. if {![info exists info_bg] || $info_bg eq {}} {
  933. set info_bg white
  934. }
  935.  
  936. canvas $canvas -width $canvas_size -height $canvas_size -bg $info_bg -bd 0 -highlightthickness 0
  937.  
  938. if {[tk windowingsystem] in {aqua win32}} {
  939. label $info.color_display -width 10 -height 6 -bg $inpcolor
  940. } else {
  941. label $info.color_display -width 12 -height 6 -bg $inpcolor
  942. }
  943. ttk::label $info.label_rgb -text "RGB:" -width 5
  944. ttk::label $info.label_hex -text "Hex:" -width 5
  945. ttk::entry $info.entry_rgb -textvariable ::gColorNS::rgbvar -width 12
  946. ttk::separator $info.separ -orient horizontal
  947. ttk::entry $info.entry_hex -textvariable ::gColorNS::hexvar -width 12 \
  948. -validate focusout -validatecommand ::gColorNS::update_all
  949. ttk::frame $info.frbutton
  950. ttk::button $info.frbutton.button_ok -text $okttl \
  951. -command {set ::gColorNS::isOK 1}
  952. ttk::button $info.frbutton.button_cancel -text $cancelttl \
  953. -command {set ::gColorNS::isOK 0}
  954.  
  955. # Frame pour les contrôles HSV
  956. ttk::frame $info.hsv_controls
  957. # Contrôles pour H, S, V
  958. foreach {component} {hue saturation value} {
  959. set label [string totitle [string range $component 0 2]]
  960. ttk::frame $info.hsv_controls.$component
  961. ttk::label $info.hsv_controls.$component.label -text $label: -width 5
  962. pack $info.hsv_controls.$component -side top -fill x
  963. pack $info.hsv_controls.$component.label -side left
  964. set scaleto [($component eq "hue" ? 360 : 100.0)]
  965. ttk::scale $info.hsv_controls.$component.scale \
  966. -command [list ::gColorNS::incdec_$component \
  967. [($component eq "hue" ? 1 : 0.01)]] \
  968. -orient horizontal -from 0 -to $scaleto -takefocus 0
  969. pack $info.hsv_controls.$component.scale -side left -expand 1 -fill x
  970. }
  971.  
  972. set current_hue 0
  973. set cumulative_angle 0
  974.  
  975. create_hue_ring_image
  976.  
  977. [( inner_radius = $radius - $ring_thickness * 1.5;
  978. t1 = polar_to_cartesian($inner_radius,0,$cx,$cy);
  979. t2 = polar_to_cartesian($inner_radius,120,$cx,$cy);
  980. t3 = polar_to_cartesian($inner_radius,-120,$cx,$cy);
  981.  
  982. triangle_coords = [list {*}$t1 {*}$t2 {*}$t3];
  983. triangle_id = [$canvas create polygon $triangle_coords -outline $info_bg -tags triangle];
  984.  
  985. inner_coords = polar_to_cartesian($radius - $ring_thickness, 0, $cx, $cy);
  986. outer_coords = polar_to_cartesian($radius, 0, $cx, $cy);
  987. hue_marker_id = [$canvas create line \
  988. [lindex $inner_coords 0] [lindex $inner_coords 1] \
  989. [lindex $outer_coords 0] [lindex $outer_coords 1] \
  990. -fill black -width 2 -tags hue_marker];
  991.  
  992. sv_x = ([lindex $t1 0] + [lindex $t2 0] + [lindex $t3 0]) / 3;
  993. sv_y = ([lindex $t1 1] + [lindex $t2 1] + [lindex $t3 1]) / 3;
  994. marker_size = $ring_thickness / 2;
  995. sv_marker_id = [$canvas create oval \
  996. [( $sv_x - $marker_size, $sv_y - $marker_size,
  997. $sv_x + $marker_size, $sv_y + $marker_size)] \
  998. -fill black -outline white -tags sv_marker];
  999. )]
  1000.  
  1001. bind $canvas <Button-1> {
  1002. set x %x
  1003. set y %y
  1004.  
  1005. if {[::gColorNS::point_in_ring $x $y]} {
  1006. set ::gColorNS::active_tag "hue_ring"
  1007. ::gColorNS::update_hue_marker $x $y
  1008. } elseif {[::gColorNS::point_in_triangle $x $y \
  1009. [lrange $::gColorNS::triangle_coords 0 1] \
  1010. [lrange $::gColorNS::triangle_coords 2 3] \
  1011. [lrange $::gColorNS::triangle_coords 4 5]]} {
  1012. set ::gColorNS::active_tag "sv_area"
  1013. ::gColorNS::update_sv_marker $x $y
  1014. }
  1015. }
  1016.  
  1017. bind $canvas <B1-Motion> {
  1018. set x %x
  1019. set y %y
  1020.  
  1021. if {$::gColorNS::active_tag eq "hue_ring"} {
  1022. ::gColorNS::throttle_update_hue_marker $x $y
  1023. } elseif {$::gColorNS::active_tag eq "sv_area"} {
  1024. ::gColorNS::update_sv_marker $x $y
  1025. }
  1026. }
  1027.  
  1028. bind $canvas <ButtonRelease-1> {
  1029. set ::gColorNS::active_tag ""
  1030. ::gColorNS::update_scale_values
  1031. }
  1032.  
  1033. fill_triangle $current_hue
  1034.  
  1035. grid $main
  1036. grid $canvas -row 0 -column 0 -rowspan 7 -sticky nswe
  1037. grid $info -row 0 -column 1 -rowspan 7 -sticky nswe
  1038. grid $info.label_rgb -sticky w -pady 0 -padx 2 -row 0 -column 0
  1039. grid $info.entry_rgb -sticky w -pady 0 -row 0 -column 1
  1040. grid $info.label_hex -sticky w -padx 2 -row 1 -column 0
  1041. grid $info.entry_hex -sticky w -row 1 -column 1
  1042. grid $info.hsv_controls -sticky ew -padx 4 -pady 4 -row 2 -column 0 -columnspan 2
  1043. grid $info.color_display -pady 4 -row 3 -column 0 -columnspan 2
  1044. grid $info.separ -sticky nswe -row 4 -column 0 -columnspan 2
  1045. grid $info.frbutton -sticky nswe -pady 4 -row 5 -column 0 -columnspan 2
  1046. grid $info.frbutton.button_ok -sticky es -padx 2 -row 0 -column 0
  1047. grid $info.frbutton.button_cancel -sticky es -padx 2 -row 0 -column 1
  1048. grid rowconfigure $info 3 -weight 111
  1049.  
  1050. update_all $inpcolor
  1051.  
  1052. }
  1053.  
  1054. proc run {args} {
  1055.  
  1056. # Runs the picker.
  1057. # args - list of options
  1058. # Options:
  1059. # "-color value" to set HEX color value, e.g. -color #ff4b4b
  1060. # "-title ttl" to set the picker's title, e.g. -title "Choose item color"
  1061. # "-oktitle ttl" to name OK button, e.g. -oktitle "To clipboard"
  1062. # "-canceltitle ttl" to name Cancel button, e.g. -canceltitle "Otmena"
  1063. # "-geometry +X+Y" to position the picker, e.g. -geometry +100+200
  1064. # "-parent win" to set parent window path, e.g. -parent .mywin
  1065. # "-modal bool" to set modal mode (default 1), e.g. -modal 0
  1066. # "-topmost bool" to set topmost mode (default 0), e.g. -topmost 1
  1067.  
  1068. # parse options
  1069. foreach {opt def} {geometry - color #ffffff parent - \
  1070. title Color oktitle OK canceltitle Cancel modal 1 topmost 0} {
  1071. set $opt $def
  1072. catch {set $opt [dict get $args -$opt]}
  1073. }
  1074.  
  1075. # create picker's window
  1076. set win .gColor
  1077. if {$parent eq {-}} {
  1078. set parent [lindex [winfo children .] end]
  1079. }
  1080. set win [string trimright $parent .].gColor
  1081. toplevel $win
  1082.  
  1083. # populate the picker's window
  1084. set wfr $win.f
  1085. if {[catch {set bg [. cget -bg]}]} {set bg #d9d9d9}
  1086. frame $wfr -background $bg
  1087. setup_ui $wfr $color $oktitle $canceltitle
  1088. grid $wfr -sticky news
  1089.  
  1090. # wm options
  1091. wm title $win $title
  1092. wm attributes $win -topmost $topmost
  1093. if {[regexp {^\+\d+\+\d+$} $geometry]} {
  1094. wm geometry $win $geometry
  1095. }
  1096. wm protocol $win WM_DELETE_WINDOW {set ::gColorNS::isOK 0}
  1097. wm transient $win $parent
  1098. wm resizable $win 0 0
  1099.  
  1100. # wait for the user's choice
  1101. set wgr [grab current]
  1102. catch {grab release $wgr}
  1103. if {$modal} {catch {grab set $win}}
  1104. bind $win <Escape> {set ::gColorNS::isOK 0}
  1105. set ::gColorNS::isOK {}
  1106. after 1 ;# solves an issue with doubleclicking buttons
  1107. if {![winfo viewable $win]} {
  1108. tkwait visibility $win
  1109. }
  1110. tkwait variable ::gColorNS::isOK
  1111. catch {grab release $win}
  1112. catch {grab set $wgr}
  1113. catch {destroy $win}
  1114.  
  1115. # get the user's choice and return HEX value or {}
  1116. if {$::gColorNS::isOK > 0} {
  1117. return $::gColorNS::hexvar
  1118. }
  1119. return {}
  1120. }
  1121.  
  1122. # ________________________ EONS _________________________ #
  1123.  
  1124. }
  1125.  
  1126. if {[info exist ::argv0] && [info exist ::argv] && \
  1127. [file normalize $::argv0] eq [file normalize [info script]]} {
  1128. wm withdraw .
  1129. set clr #ffffff
  1130. while 1 {
  1131. set clr [gColorNS::run -color $clr -oktitle {To clipboard} {*}$::argv]
  1132. if {$clr eq {}} break
  1133. clipboard clear
  1134. clipboard append -type STRING $clr
  1135. }
  1136. exit
  1137. }
  1138.  

Add a comment

Please note that this site uses the meta tags nofollow,noindex for all pages that contain comments.
Items are closed for new comments after 1 week