Posted to tcl by Florentis at Tue Aug 25 23:54:41 GMT 2026view raw

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

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