daily pastebin goal
70%
SHARE
TWEET

Eric Melski

a guest Aug 29th, 2010 137 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
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top