Eric Melski

# colors.tcl, an app to help choose a foreground color for a given background.
#
# R/G/B ranges from 0-255 / 0-255 / 0-255
# H/S/V ranges from 0-360 / 0-100 / 0-100
# H/S/L ranges from 0-100 / 0-100 / 0-100
#
# Copyright (c) 2010 Eric Melski
# All rights reserved.
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
#     * Redistributions of source code must retain the above copyright notice,
#       this list of conditions and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * Neither the name of Electric Cloud nor the names of its employees may
#       be used to endorse or promote products derived from this software
#       without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.

package require Tk
package require tile

# Take HSV in the range 0.0-1.0 and convert to RGB in the range 0-255.

proc hsv2rgb {h s v} {
    if {$s <= 0.0} {
	# achromatic
	set v [expr {int($v * 255)}]
	return "$v $v $v"
    } else {
	set v [expr {double(255 * $v)}]
        if {$h >= 1.0} { set h 0.0 }
        set h [expr {6.0 * $h}]
        set f [expr {double($h) - int($h)}]
        set p [expr {int($v * (1.0 - $s))}]
        set q [expr {int($v * (1.0 - ($s * $f)))}]
        set t [expr {int($v * (1.0 - ($s * (1.0 - $f))))}]
	set v [expr {int($v)}]
        switch [expr {int($h)}] {
            0 { return "$v $t $p" }
            1 { return "$q $v $p" }
	    2 { return "$p $v $t" }
	    3 { return "$p $q $v" }
	    4 { return "$t $p $v" }
	    5 { return "$v $p $q" }
        }
    }
}

# Take HSL in the range 0-1 and convert to RGB in the range 0-255.

proc hsl2rgb {h s l} {
    set r $l
    set g $l
    set b $l

    set v [expr {($l <= 0.5) ? ($l * (1.0 + $s)) : ($l + $s - $l * $s)}]
    if { $v > 0 } {
        set m     [expr {$l + $l - $v}]
        set sv    [expr {($v - $m) / $v}]
        set h     [expr {$h * 6}]
        set hi    [expr {int($h)}]
        set delta [expr {$h - $hi}]
        set vsf   [expr {$v * $sv * $delta}]
        set mid1  [expr {$m + $vsf}]
        set mid2  [expr {$v - $vsf}]
        switch $hi {
            0 { set r $v ; set g $mid1 ; set b $m }
            1 { set r $mid2 ; set g $v ; set b $m }
            2 { set r $m ; set g $v ; set b $mid1 }
            3 { set r $m ; set g $mid2 ; set b $v }
            4 { set r $mid1 ; set g $m ; set b $v }
            5 { set r $v ; set g $m ; set b $mid2 }
        }
    }
    set r [expr {round($r * 255)}]
    set g [expr {round($g * 255)}]
    set b [expr {round($b * 255)}]
    return [list $r $g $b]
}

# Take RGB in the range 0-255 and convert to HSV in the range 0.0 - 1.0.

proc rgb2hsv {r g b} {
    set min [expr {$g < $b   ? $g : $b}]
    set min [expr {$r < $min ? $r : $min}]

    set max [expr {$g > $b   ? $g : $b}]
    set max [expr {$r > $max ? $r : $max}]

    set delta [expr {$max - $min}]
    set v [expr {double($max) / 255}]
    if { $delta == 0 } {
        set h 0
    } elseif { $max == $r } {
        set h [expr {round(60 * (double($g - $b) / $delta))}]
    } elseif { $max == $g } {
        set h [expr {round(60 * (double($b - $r) / $delta) + 120)}]
    } else {
        set h [expr {round(60 * (double($r - $g) / $delta) + 240)}]
    }
    if { $h < 0 } {
        set h [expr {$h + 360}]
    }
    if { $max == 0 } {
        set s 0
    } else {
        set s [expr {1.0 - double($min)/$max}]
    }
    set h [expr {double($h) / 360}]
    return [list $h $s $v]
}

# Take RGB in the range 0-255 and convert to HSL in the range 0.0 - 1.0

proc rgb2hsl {r g b} {
    set r [expr {double($r) / 255}]
    set g [expr {double($g) / 255}]
    set b [expr {double($b) / 255}]

    set h 0
    set s 0
    set l 0
    set v [expr {$r > $g ? $r : $g}]
    set v [expr {$v > $b ? $v : $b}]
    set m [expr {$r < $g ? $r : $g}]
    set m [expr {$m < $b ? $m : $b}]
    set l [expr {($m + $v) / 2}]
    if { $l <= 0.0 } {
        return [list $h $s $l]
    }
    set vm [expr {$v - $m}]
    set s  $vm
    if { $s > 0.0 } {
        set s [expr {$s / (($l <= 0.5) ? ($v + $m) : (2.0 - $v - $m))}]
    } else {
        return [list $h $s $l]
    }
    set r2 [expr {($v - $r) / $vm}]
    set g2 [expr {($v - $g) / $vm}]
    set b2 [expr {($v - $b) / $vm}]
    if { $r == $v } {
        set h [expr {($g == $m) ? 5.0 + $b2 : 1.0 - $g2}]
    } elseif { $g == $v } {
        set h [expr {($b == $m) ? 1.0 + $r2 : 3.0 - $b2}]
    } else {
        set h [expr {($r == $m) ? 3.0 + $g2 : 5.0 - $r2}]
    }
    set h [expr {$h / 6.0}]
    return [list $h $s $l]
}

proc adjust {who what args} {
    upvar #0 $who c

    # First figure out whether we're trying to go from RGB to HSV
    # or vice versa.

    if { $what eq "rgb" } {
        foreach {h s v} [rgb2hsv $c(rgb,r) $c(rgb,g) $c(rgb,b)] { break }
        set c(hsv,h) [expr {round(360 * $h)}]
        set c(hsv,s) [expr {round(100 * $s)}]
        set c(hsv,v) [expr {round(100 * $v)}]
        foreach {h s l} [rgb2hsl $c(rgb,r) $c(rgb,g) $c(rgb,b)] { break }
        set c(hsl,h) [expr {round($h * 100)}]
        set c(hsl,s) [expr {round($s * 100)}]
        set c(hsl,l) [expr {round($l * 100)}]
    } elseif { $what eq "hsv" } {
        set h [expr {double($c(hsv,h)) / 360}]
        set s [expr {double($c(hsv,s)) / 100}]
        set v [expr {double($c(hsv,v)) / 100}]
        foreach {r g b} [hsv2rgb $h $s $v] { break }
        foreach {h s l} [rgb2hsl $r $g $b] { break }
        set c(rgb,r) $r
        set c(rgb,g) $g
        set c(rgb,b) $b
        set c(hsl,h) [expr {round($h * 100)}]
        set c(hsl,s) [expr {round($s * 100)}]
        set c(hsl,l) [expr {round($l * 100)}]
    } elseif { $what eq "hsl" } {
        set h [expr {double($c(hsl,h)) / 100}]
        set s [expr {double($c(hsl,s)) / 100}]
        set l [expr {double($c(hsl,l)) / 100}]
        foreach {r g b} [hsl2rgb $h $s $l] { break }
        foreach {h s v} [rgb2hsv $r $g $b] { break }
        set c(rgb,r) $r
        set c(rgb,g) $g
        set c(rgb,b) $b
        set c(hsv,h) [expr {round($h * 360)}]
        set c(hsv,s) [expr {round($s * 100)}]
        set c(hsv,v) [expr {round($v * 100)}]
    }

    set c(hex) [format "%02x%02x%02x" $c(rgb,r) $c(rgb,g) $c(rgb,b)]
    .label configure -$who "#$c(hex)"
}

proc sethex {who} {
    upvar #0 $who c
    set c(rgb,r) [scan [string range $c(hex) 0 1] %x]
    set c(rgb,g) [scan [string range $c(hex) 2 3] %x]
    set c(rgb,b) [scan [string range $c(hex) 4 5] %x]
    foreach {h s v} [rgb2hsv $c(rgb,r) $c(rgb,g) $c(rgb,b)] { break }
    set c(hsv,h) [expr {round(360 * $h)}]
    set c(hsv,s) [expr {round(100 * $s)}]
    set c(hsv,v) [expr {round(100 * $v)}]
    foreach {h s l} [rgb2hsl $c(rgb,r) $c(rgb,g) $c(rgb,b)] { break }
    set c(hsl,h) [expr {round(100 * $h)}]
    set c(hsl,s) [expr {round(100 * $s)}]
    set c(hsl,l) [expr {round(100 * $l)}]
    .label configure -$who "#$c(hex)"
}

array set bg {
    rgb,r 0
    rgb,g 0
    rgb,b 0
    hsv,h 0
    hsv,s 0
    hsv,v 0
    hsl,h 0
    hsl,s 0
    hsl,l 0
    hex 000000
}

array set fg {
    rgb,r 255
    rgb,g 255
    rgb,b 255
    hsv,h 0
    hsv,s 0
    hsv,v 100
    hsl,h 0
    hsl,s 0
    hsl,l 100
    hex ffffff
}

spinbox .bgRED -from 0 -to 255 -incr 1 -textvar bg(rgb,r) \
    -command {adjust bg rgb}
spinbox .bgGRN -from 0 -to 255 -incr 1 -textvar bg(rgb,g) \
    -command {adjust bg rgb}
spinbox .bgBLU -from 0 -to 255 -incr 1 -textvar bg(rgb,b) \
    -command {adjust bg rgb}
spinbox .bgHUE -from 0 -to 360 -incr 1 -textvar bg(hsv,h) \
    -command {adjust bg hsv}
spinbox .bgSAT -from 0 -to 100 -incr 1 -textvar bg(hsv,s) \
    -command {adjust bg hsv}
spinbox .bgVAL -from 0 -to 100 -incr 1 -textvar bg(hsv,v) \
    -command {adjust bg hsv}
spinbox .bgHSLH -from 0 -to 100 -incr 1 -textvar bg(hsl,h) \
    -command {adjust bg hsl}
spinbox .bgHSLS -from 0 -to 100 -incr 1 -textvar bg(hsl,s) \
    -command {adjust bg hsl}
spinbox .bgHSLL -from 0 -to 100 -incr 1 -textvar bg(hsl,l) \
    -command {adjust bg hsl}
ttk::entry .bgHEX -textvar bg(hex)

spinbox .fgRED -from 0 -to 255 -incr 1 -textvar fg(rgb,r) \
    -command {adjust fg rgb}
spinbox .fgGRN -from 0 -to 255 -incr 1 -textvar fg(rgb,g) \
    -command {adjust fg rgb}
spinbox .fgBLU -from 0 -to 255 -incr 1 -textvar fg(rgb,b) \
    -command {adjust fg rgb}
spinbox .fgHUE -from 0 -to 360 -incr 1 -textvar fg(hsv,h) \
    -command {adjust fg hsv}
spinbox .fgSAT -from 0 -to 100 -incr 1 -textvar fg(hsv,s) \
    -command {adjust fg hsv}
spinbox .fgVAL -from 0 -to 100 -incr 1 -textvar fg(hsv,v) \
    -command {adjust fg hsv}
spinbox .fgHSLH -from 0 -to 100 -incr 1 -textvar fg(hsl,h) \
    -command {adjust fg hsl}
spinbox .fgHSLS -from 0 -to 100 -incr 1 -textvar fg(hsl,s) \
    -command {adjust fg hsl}
spinbox .fgHSLL -from 0 -to 100 -incr 1 -textvar fg(hsl,l) \
    -command {adjust fg hsl}

ttk::entry .fgHEX -textvar fg(hex)
ttk::entry .font  -textvar lblfont
set lblfont {Arial -20}

wm title . "Color tester"

label .label -font $lblfont -text "The quick brown fox ..." -bg black -fg white


bind .bgHEX <KeyPress-Return> {sethex bg}
bind .fgHEX <KeyPress-Return> {sethex fg}

foreach x {bg fg} {
    foreach e {<KeyPress-Return> <FocusOut>} {
        bind .${x}RED  $e [list adjust $x rgb]
        bind .${x}GRN  $e [list adjust $x rgb]
        bind .${x}BLU  $e [list adjust $x rgb]
        bind .${x}HUE  $e [list adjust $x hsv]
        bind .${x}SAT  $e [list adjust $x hsv]
        bind .${x}VAL  $e [list adjust $x hsv]
        bind .${x}HSLH $e [list adjust $x hsl]
        bind .${x}HSLS $e [list adjust $x hsl]
        bind .${x}HSLL $e [list adjust $x hsl]
    }
}

bind .font  <KeyPress-Return> {.label configure -font $lblfont}
bind . <Destroy> {set forever 1}

grid x [label .bgl -text "Background"] [label .fgl -text "Foreground"] -padx 2 -pady 2
grid [label .rl -text "R"] .bgRED .fgRED -sticky new -padx 2 -pady 2
grid [label .gl -text "G"] .bgGRN .fgGRN -sticky new -padx 2 -pady 2
grid [label .bl -text "B"] .bgBLU .fgBLU -sticky new -padx 2 -pady 2
grid [ttk::separator .sep1 -orient horizontal] - - -sticky ew -padx 2 -pady 2
grid [label .rh -text "H"] .bgHUE .fgHUE -sticky new -padx 2 -pady 2
grid [label .rs -text "S"] .bgSAT .fgSAT -sticky new -padx 2 -pady 2
grid [label .rv -text "V"] .bgVAL .fgVAL -sticky new -padx 2 -pady 2
grid [ttk::separator .sep2 -orient horizontal] - -sticky ew -padx 2 -pady 2
grid [label .rlh -text "H"] .bgHSLH .fgHSLH -sticky new -padx 2 -pady 2
grid [label .rls -text "S"] .bgHSLS .fgHSLS -sticky new -padx 2 -pady 2
grid [label .rll -text "L"] .bgHSLL .fgHSLL -sticky new -padx 2 -pady 2
grid [ttk::separator .sep3 -orient horizontal] - - -sticky ew -padx 2 -pady 2
grid x .bgHEX .fgHEX -sticky new -padx 2 -pady 2
grid x .font  -      -sticky new -padx 2 -pady 2
grid x .label -      -sticky nsew -padx 2 -pady 2 -ipady 5

set forever 0
vwait forever