Guest User

Eric Melski

a guest
Aug 29th, 2010
177
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. # colors.tcl, an app to help choose a foreground color for a given background.
  2. #
  3. # R/G/B ranges from 0-255 / 0-255 / 0-255
  4. # H/S/V ranges from 0-360 / 0-100 / 0-100
  5. # H/S/L ranges from 0-100 / 0-100 / 0-100
  6. #
  7. # Copyright (c) 2010 Eric Melski
  8. # All rights reserved.
  9. # Redistribution and use in source and binary forms, with or without
  10. # modification, are permitted provided that the following conditions are met:
  11. #
  12. # * Redistributions of source code must retain the above copyright notice,
  13. # this list of conditions and the following disclaimer.
  14. # * Redistributions in binary form must reproduce the above copyright
  15. # notice, this list of conditions and the following disclaimer in the
  16. # documentation and/or other materials provided with the distribution.
  17. # * Neither the name of Electric Cloud nor the names of its employees may
  18. # be used to endorse or promote products derived from this software
  19. # without specific prior written permission.
  20. #
  21. # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
  22. # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  23. # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  24. # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
  25. # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  26. # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  27. # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  28. # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
  29. # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  30. # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  31. # POSSIBILITY OF SUCH DAMAGE.
  32.  
  33. package require Tk
  34. package require tile
  35.  
  36. # Take HSV in the range 0.0-1.0 and convert to RGB in the range 0-255.
  37.  
  38. proc hsv2rgb {h s v} {
  39. if {$s <= 0.0} {
  40. # achromatic
  41. set v [expr {int($v * 255)}]
  42. return "$v $v $v"
  43. } else {
  44. set v [expr {double(255 * $v)}]
  45. if {$h >= 1.0} { set h 0.0 }
  46. set h [expr {6.0 * $h}]
  47. set f [expr {double($h) - int($h)}]
  48. set p [expr {int($v * (1.0 - $s))}]
  49. set q [expr {int($v * (1.0 - ($s * $f)))}]
  50. set t [expr {int($v * (1.0 - ($s * (1.0 - $f))))}]
  51. set v [expr {int($v)}]
  52. switch [expr {int($h)}] {
  53. 0 { return "$v $t $p" }
  54. 1 { return "$q $v $p" }
  55. 2 { return "$p $v $t" }
  56. 3 { return "$p $q $v" }
  57. 4 { return "$t $p $v" }
  58. 5 { return "$v $p $q" }
  59. }
  60. }
  61. }
  62.  
  63. # Take HSL in the range 0-1 and convert to RGB in the range 0-255.
  64.  
  65. proc hsl2rgb {h s l} {
  66. set r $l
  67. set g $l
  68. set b $l
  69.  
  70. set v [expr {($l <= 0.5) ? ($l * (1.0 + $s)) : ($l + $s - $l * $s)}]
  71. if { $v > 0 } {
  72. set m [expr {$l + $l - $v}]
  73. set sv [expr {($v - $m) / $v}]
  74. set h [expr {$h * 6}]
  75. set hi [expr {int($h)}]
  76. set delta [expr {$h - $hi}]
  77. set vsf [expr {$v * $sv * $delta}]
  78. set mid1 [expr {$m + $vsf}]
  79. set mid2 [expr {$v - $vsf}]
  80. switch $hi {
  81. 0 { set r $v ; set g $mid1 ; set b $m }
  82. 1 { set r $mid2 ; set g $v ; set b $m }
  83. 2 { set r $m ; set g $v ; set b $mid1 }
  84. 3 { set r $m ; set g $mid2 ; set b $v }
  85. 4 { set r $mid1 ; set g $m ; set b $v }
  86. 5 { set r $v ; set g $m ; set b $mid2 }
  87. }
  88. }
  89. set r [expr {round($r * 255)}]
  90. set g [expr {round($g * 255)}]
  91. set b [expr {round($b * 255)}]
  92. return [list $r $g $b]
  93. }
  94.  
  95. # Take RGB in the range 0-255 and convert to HSV in the range 0.0 - 1.0.
  96.  
  97. proc rgb2hsv {r g b} {
  98. set min [expr {$g < $b ? $g : $b}]
  99. set min [expr {$r < $min ? $r : $min}]
  100.  
  101. set max [expr {$g > $b ? $g : $b}]
  102. set max [expr {$r > $max ? $r : $max}]
  103.  
  104. set delta [expr {$max - $min}]
  105. set v [expr {double($max) / 255}]
  106. if { $delta == 0 } {
  107. set h 0
  108. } elseif { $max == $r } {
  109. set h [expr {round(60 * (double($g - $b) / $delta))}]
  110. } elseif { $max == $g } {
  111. set h [expr {round(60 * (double($b - $r) / $delta) + 120)}]
  112. } else {
  113. set h [expr {round(60 * (double($r - $g) / $delta) + 240)}]
  114. }
  115. if { $h < 0 } {
  116. set h [expr {$h + 360}]
  117. }
  118. if { $max == 0 } {
  119. set s 0
  120. } else {
  121. set s [expr {1.0 - double($min)/$max}]
  122. }
  123. set h [expr {double($h) / 360}]
  124. return [list $h $s $v]
  125. }
  126.  
  127. # Take RGB in the range 0-255 and convert to HSL in the range 0.0 - 1.0
  128.  
  129. proc rgb2hsl {r g b} {
  130. set r [expr {double($r) / 255}]
  131. set g [expr {double($g) / 255}]
  132. set b [expr {double($b) / 255}]
  133.  
  134. set h 0
  135. set s 0
  136. set l 0
  137. set v [expr {$r > $g ? $r : $g}]
  138. set v [expr {$v > $b ? $v : $b}]
  139. set m [expr {$r < $g ? $r : $g}]
  140. set m [expr {$m < $b ? $m : $b}]
  141. set l [expr {($m + $v) / 2}]
  142. if { $l <= 0.0 } {
  143. return [list $h $s $l]
  144. }
  145. set vm [expr {$v - $m}]
  146. set s $vm
  147. if { $s > 0.0 } {
  148. set s [expr {$s / (($l <= 0.5) ? ($v + $m) : (2.0 - $v - $m))}]
  149. } else {
  150. return [list $h $s $l]
  151. }
  152. set r2 [expr {($v - $r) / $vm}]
  153. set g2 [expr {($v - $g) / $vm}]
  154. set b2 [expr {($v - $b) / $vm}]
  155. if { $r == $v } {
  156. set h [expr {($g == $m) ? 5.0 + $b2 : 1.0 - $g2}]
  157. } elseif { $g == $v } {
  158. set h [expr {($b == $m) ? 1.0 + $r2 : 3.0 - $b2}]
  159. } else {
  160. set h [expr {($r == $m) ? 3.0 + $g2 : 5.0 - $r2}]
  161. }
  162. set h [expr {$h / 6.0}]
  163. return [list $h $s $l]
  164. }
  165.  
  166. proc adjust {who what args} {
  167. upvar #0 $who c
  168.  
  169. # First figure out whether we're trying to go from RGB to HSV
  170. # or vice versa.
  171.  
  172. if { $what eq "rgb" } {
  173. foreach {h s v} [rgb2hsv $c(rgb,r) $c(rgb,g) $c(rgb,b)] { break }
  174. set c(hsv,h) [expr {round(360 * $h)}]
  175. set c(hsv,s) [expr {round(100 * $s)}]
  176. set c(hsv,v) [expr {round(100 * $v)}]
  177. foreach {h s l} [rgb2hsl $c(rgb,r) $c(rgb,g) $c(rgb,b)] { break }
  178. set c(hsl,h) [expr {round($h * 100)}]
  179. set c(hsl,s) [expr {round($s * 100)}]
  180. set c(hsl,l) [expr {round($l * 100)}]
  181. } elseif { $what eq "hsv" } {
  182. set h [expr {double($c(hsv,h)) / 360}]
  183. set s [expr {double($c(hsv,s)) / 100}]
  184. set v [expr {double($c(hsv,v)) / 100}]
  185. foreach {r g b} [hsv2rgb $h $s $v] { break }
  186. foreach {h s l} [rgb2hsl $r $g $b] { break }
  187. set c(rgb,r) $r
  188. set c(rgb,g) $g
  189. set c(rgb,b) $b
  190. set c(hsl,h) [expr {round($h * 100)}]
  191. set c(hsl,s) [expr {round($s * 100)}]
  192. set c(hsl,l) [expr {round($l * 100)}]
  193. } elseif { $what eq "hsl" } {
  194. set h [expr {double($c(hsl,h)) / 100}]
  195. set s [expr {double($c(hsl,s)) / 100}]
  196. set l [expr {double($c(hsl,l)) / 100}]
  197. foreach {r g b} [hsl2rgb $h $s $l] { break }
  198. foreach {h s v} [rgb2hsv $r $g $b] { break }
  199. set c(rgb,r) $r
  200. set c(rgb,g) $g
  201. set c(rgb,b) $b
  202. set c(hsv,h) [expr {round($h * 360)}]
  203. set c(hsv,s) [expr {round($s * 100)}]
  204. set c(hsv,v) [expr {round($v * 100)}]
  205. }
  206.  
  207. set c(hex) [format "%02x%02x%02x" $c(rgb,r) $c(rgb,g) $c(rgb,b)]
  208. .label configure -$who "#$c(hex)"
  209. }
  210.  
  211. proc sethex {who} {
  212. upvar #0 $who c
  213. set c(rgb,r) [scan [string range $c(hex) 0 1] %x]
  214. set c(rgb,g) [scan [string range $c(hex) 2 3] %x]
  215. set c(rgb,b) [scan [string range $c(hex) 4 5] %x]
  216. foreach {h s v} [rgb2hsv $c(rgb,r) $c(rgb,g) $c(rgb,b)] { break }
  217. set c(hsv,h) [expr {round(360 * $h)}]
  218. set c(hsv,s) [expr {round(100 * $s)}]
  219. set c(hsv,v) [expr {round(100 * $v)}]
  220. foreach {h s l} [rgb2hsl $c(rgb,r) $c(rgb,g) $c(rgb,b)] { break }
  221. set c(hsl,h) [expr {round(100 * $h)}]
  222. set c(hsl,s) [expr {round(100 * $s)}]
  223. set c(hsl,l) [expr {round(100 * $l)}]
  224. .label configure -$who "#$c(hex)"
  225. }
  226.  
  227. array set bg {
  228. rgb,r 0
  229. rgb,g 0
  230. rgb,b 0
  231. hsv,h 0
  232. hsv,s 0
  233. hsv,v 0
  234. hsl,h 0
  235. hsl,s 0
  236. hsl,l 0
  237. hex 000000
  238. }
  239.  
  240. array set fg {
  241. rgb,r 255
  242. rgb,g 255
  243. rgb,b 255
  244. hsv,h 0
  245. hsv,s 0
  246. hsv,v 100
  247. hsl,h 0
  248. hsl,s 0
  249. hsl,l 100
  250. hex ffffff
  251. }
  252.  
  253. spinbox .bgRED -from 0 -to 255 -incr 1 -textvar bg(rgb,r) \
  254. -command {adjust bg rgb}
  255. spinbox .bgGRN -from 0 -to 255 -incr 1 -textvar bg(rgb,g) \
  256. -command {adjust bg rgb}
  257. spinbox .bgBLU -from 0 -to 255 -incr 1 -textvar bg(rgb,b) \
  258. -command {adjust bg rgb}
  259. spinbox .bgHUE -from 0 -to 360 -incr 1 -textvar bg(hsv,h) \
  260. -command {adjust bg hsv}
  261. spinbox .bgSAT -from 0 -to 100 -incr 1 -textvar bg(hsv,s) \
  262. -command {adjust bg hsv}
  263. spinbox .bgVAL -from 0 -to 100 -incr 1 -textvar bg(hsv,v) \
  264. -command {adjust bg hsv}
  265. spinbox .bgHSLH -from 0 -to 100 -incr 1 -textvar bg(hsl,h) \
  266. -command {adjust bg hsl}
  267. spinbox .bgHSLS -from 0 -to 100 -incr 1 -textvar bg(hsl,s) \
  268. -command {adjust bg hsl}
  269. spinbox .bgHSLL -from 0 -to 100 -incr 1 -textvar bg(hsl,l) \
  270. -command {adjust bg hsl}
  271. ttk::entry .bgHEX -textvar bg(hex)
  272.  
  273. spinbox .fgRED -from 0 -to 255 -incr 1 -textvar fg(rgb,r) \
  274. -command {adjust fg rgb}
  275. spinbox .fgGRN -from 0 -to 255 -incr 1 -textvar fg(rgb,g) \
  276. -command {adjust fg rgb}
  277. spinbox .fgBLU -from 0 -to 255 -incr 1 -textvar fg(rgb,b) \
  278. -command {adjust fg rgb}
  279. spinbox .fgHUE -from 0 -to 360 -incr 1 -textvar fg(hsv,h) \
  280. -command {adjust fg hsv}
  281. spinbox .fgSAT -from 0 -to 100 -incr 1 -textvar fg(hsv,s) \
  282. -command {adjust fg hsv}
  283. spinbox .fgVAL -from 0 -to 100 -incr 1 -textvar fg(hsv,v) \
  284. -command {adjust fg hsv}
  285. spinbox .fgHSLH -from 0 -to 100 -incr 1 -textvar fg(hsl,h) \
  286. -command {adjust fg hsl}
  287. spinbox .fgHSLS -from 0 -to 100 -incr 1 -textvar fg(hsl,s) \
  288. -command {adjust fg hsl}
  289. spinbox .fgHSLL -from 0 -to 100 -incr 1 -textvar fg(hsl,l) \
  290. -command {adjust fg hsl}
  291.  
  292. ttk::entry .fgHEX -textvar fg(hex)
  293. ttk::entry .font -textvar lblfont
  294. set lblfont {Arial -20}
  295.  
  296. wm title . "Color tester"
  297.  
  298. label .label -font $lblfont -text "The quick brown fox ..." -bg black -fg white
  299.  
  300.  
  301. bind .bgHEX <KeyPress-Return> {sethex bg}
  302. bind .fgHEX <KeyPress-Return> {sethex fg}
  303.  
  304. foreach x {bg fg} {
  305. foreach e {<KeyPress-Return> <FocusOut>} {
  306. bind .${x}RED $e [list adjust $x rgb]
  307. bind .${x}GRN $e [list adjust $x rgb]
  308. bind .${x}BLU $e [list adjust $x rgb]
  309. bind .${x}HUE $e [list adjust $x hsv]
  310. bind .${x}SAT $e [list adjust $x hsv]
  311. bind .${x}VAL $e [list adjust $x hsv]
  312. bind .${x}HSLH $e [list adjust $x hsl]
  313. bind .${x}HSLS $e [list adjust $x hsl]
  314. bind .${x}HSLL $e [list adjust $x hsl]
  315. }
  316. }
  317.  
  318. bind .font <KeyPress-Return> {.label configure -font $lblfont}
  319. bind . <Destroy> {set forever 1}
  320.  
  321. grid x [label .bgl -text "Background"] [label .fgl -text "Foreground"] -padx 2 -pady 2
  322. grid [label .rl -text "R"] .bgRED .fgRED -sticky new -padx 2 -pady 2
  323. grid [label .gl -text "G"] .bgGRN .fgGRN -sticky new -padx 2 -pady 2
  324. grid [label .bl -text "B"] .bgBLU .fgBLU -sticky new -padx 2 -pady 2
  325. grid [ttk::separator .sep1 -orient horizontal] - - -sticky ew -padx 2 -pady 2
  326. grid [label .rh -text "H"] .bgHUE .fgHUE -sticky new -padx 2 -pady 2
  327. grid [label .rs -text "S"] .bgSAT .fgSAT -sticky new -padx 2 -pady 2
  328. grid [label .rv -text "V"] .bgVAL .fgVAL -sticky new -padx 2 -pady 2
  329. grid [ttk::separator .sep2 -orient horizontal] - -sticky ew -padx 2 -pady 2
  330. grid [label .rlh -text "H"] .bgHSLH .fgHSLH -sticky new -padx 2 -pady 2
  331. grid [label .rls -text "S"] .bgHSLS .fgHSLS -sticky new -padx 2 -pady 2
  332. grid [label .rll -text "L"] .bgHSLL .fgHSLL -sticky new -padx 2 -pady 2
  333. grid [ttk::separator .sep3 -orient horizontal] - - -sticky ew -padx 2 -pady 2
  334. grid x .bgHEX .fgHEX -sticky new -padx 2 -pady 2
  335. grid x .font - -sticky new -padx 2 -pady 2
  336. grid x .label - -sticky nsew -padx 2 -pady 2 -ipady 5
  337.  
  338. set forever 0
  339. vwait forever
RAW Paste Data