Yet Another Color Picker edit

tclsh yacp.tcl  # defaults to HSV
tclsh yacp.tcl -model hsl 
tclsh yacp.tcl -model rgb  # (-mode dynamic) same as Tk's color picker.
tclsh yacp.tcl -model rgb -mode static '#80a0a0'

#!/usr/bin/tclsh
#
# yet another color picker
#
# Copyright 2012-2018 Brad Lanam Walnut Creek CA USA
#
# Algorithms from:
# http://mjijackson.com/2008/02/rgb-to-hsl-and-rgb-to-hsv-color-model-conversion-algorithms-in-javascript
# http://www.easyrgb.com/index.php?X=MATH&H=02#text2
# http://www.brucelindbloom.com/
# http://en.wikipedia.org/wiki/CIELUV
#


package require Tk 8.5-
lappend ::auto_path .
package require colorutils

variable vars

# When HSL is used, val=luminosity
# When RGB is used, hue=red, sat=green, val=blue
# Variables:
#   rgbtextvar            : the hex value variable [traced]
#   base,{hue|sat|val}    : the base value for creating pure colors
#   height                : the height of the color selection canvas
#   width                 : the width of the color selection canvas.
#      This should be set to 255 or 360
#   selval,{hue|sat|val}  : the selected value from the canvas [traced]
#     This value is from 0 to <width>
#   useval,{hue|sat|val}  : the scaled value used internally
#   dispval,{hue|sat|val} : the display value for the left side boxes
#     Value is from 0 to <width>
#   olddisp,{hue|sat|val} : the old display value. Used to check for changes.
#   seltodispscale        : the value to convert a selected value to a
#      display value.  The selected value is divided by the width
#      of the canvas, then multiplied by this value.
#   cvt,{hsv,hsl,rgb}     : conversion factor
#   ctype                 : HSV or HSL or RGB
#   cvttype               : int or double
#

proc _grabScreen { image } {
  set pipe [open {|xwd -root -silent | convert xwd:- ppm:-} rb]
  $image put [read $pipe]
  close $pipe
}

proc _getPixel { } {
  set buffer [image create photo]
  _grabScreen $buffer
  set data [$buffer get {*}[winfo pointerxy .]]
  image delete $buffer
  return $data
}

proc _hexValueChange { args } {
  variable vars

  if { [regexp {^#?[[:xdigit:]]{6}$} $vars(rgbtextvar)] } {
    set vlist [colorutils::fromRgbText $vars(rgbtextvar) $vars(ctype)]
    set nvlist [_createSelValues $vlist]
    foreach {i k} {0 hue 1 sat 2 val} {
      set vars(selval,$k) [lindex $nvlist $i]
      set vars(olddisp,$k) -1
    }
    _setColors
  }
}

proc _colorChange { args } {
  _setColors
}

proc _drawMarker { cw x } {
  variable vars

  set rw [expr {round(1.0 / $vars(width.d))}]
  set hh [expr {ceil(double($vars(height))/2.0)}]
  $cw create rectangle \
      $x 0 [expr {$rw + $x}] $hh \
      -fill #ffffff -outline {}
  $cw create rectangle \
      $x $hh [expr {$rw + $x}] $vars(height) \
      -fill #000000 -outline {}
}

proc _setColors { } {
  variable vars

  set w .
  set rw [expr {round(1.0 / $vars(width.d))}]

  foreach {k} {hue sat val} {
    if { $vars(selval,$k) eq "" } {
      return
    }

    # normalize the selected value so that mouse motion outside of the
    # canvas doesn't create strange values.
    _selTraceOff $k
    if { $vars(selval,$k) < 0 } {
      set vars(selval,$k) 0
    }
    if { $vars(selval,$k) > $vars(width) } {
      set vars(selval,$k) $vars(width)
    }
    _selTraceOn $k

    set vars(dispval,$k) [expr {int(round(double($vars(selval,$k)) / \
        $vars(width.d) * $vars(cvt,$vars(ctype)) * $vars(seltodispscale)))}]
    set vars(useval,$k) [expr {double($vars(selval,$k)) /
        $vars(width.d) * $vars(cvt,$vars(ctype))}]
    if { $vars(cvttype) eq "int" } {
      set vars(useval,$k) [expr {int($vars(useval,$k))}]
    }
  }

  if { $vars(olddisp,hue) != $vars(dispval,hue) } {
    .canv_hue delete all
    for {set x 0} {$x < $vars(width)} {incr x 1} {
      if { $vars(selval,hue) == $x } {
        _drawMarker .canv_hue $x
      } else {
        set x1 [expr {double($x) / $vars(width.d) * $vars(cvt,$vars(ctype))}]
        if { $vars(cvttype) eq "int" } {
          set x1 [expr {int(round($x1))}]
        }
        set c [colorutils::toRgbText \
            [list $x1 $vars(base,sat) $vars(base,val)] $vars(ctype)]
        .canv_hue create rectangle \
            $x 0 [expr {$rw + $x}] $vars(height) \
            -fill $c -outline {}
      }
    }
  }

  if { $vars(mode) ne "dynamic" } {
    set h $vars(base,hue)
  } else {
    set h $vars(useval,hue)
  }

  .canv_sat delete all
  .canv_val delete all

  for {set x 0} {$x < $vars(width)} {incr x 1} {
    set x1 [expr {double($x) / $vars(width.d) * $vars(cvt,$vars(ctype))}]
    set v1 $vars(useval,val)
    if { $vars(mode) ne "dynamic" } {
      set v1 $vars(base,val)
    }
    if { $vars(cvttype) eq "int" } {
      set x1 [expr {int(round($x1))}]
    }
    if { $vars(selval,sat) == $x } {
      _drawMarker .canv_sat $x
    } else {
      set c [colorutils::toRgbText [list $h $x1 $v1] $vars(ctype)]
      .canv_sat create rectangle $x 0 [expr {$rw+$x}] $vars(height) \
          -fill $c -outline {}
    }

    set s1 $vars(useval,sat)
    if { $vars(mode) ne "dynamic" } {
      set s1 $vars(base,sat)
    }
    if { $vars(selval,val) == $x } {
      _drawMarker .canv_val $x
    } else {
      set c [colorutils::toRgbText [list $h $s1 $x1] $vars(ctype)]
      .canv_val create rectangle $x 0 [expr {$rw+$x}] $vars(height) \
          -fill $c -outline {}
    }
  }

  set h $vars(useval,hue)

  # main sample display
  set c [colorutils::toRgbText \
      [list $vars(useval,hue) $vars(useval,sat) $vars(useval,val)] $vars(ctype)]
  set sc $vars(sampcanv)
  $sc configure -background $c
  _hexTraceOff
  set vars(rgbtextvar) $c
  _hexTraceOn

  foreach {k} {hue sat val} {
    set vars(olddisp,$k) $vars(dispval,$k)
  }
}

proc _exit { selflag val } {
  variable vars

  if { $selflag } {
    puts [colorutils::toRgbText [list $vars(useval,hue) $vars(useval,sat) \
        $vars(useval,val)] $vars(ctype)]
  } else {
    puts $val
  }
  destroy .
  exit
}

proc _createSelValues { vlist } {
  variable vars

  set nvlist {}
  # build a new list of values for hue, sat, and val.
  for {set i 0} {$i < 3} {incr i} {
    set x1 [expr {round([lindex $vlist $i] /
        $vars(cvt,$vars(ctype)) * $vars(width.d))}]
    lappend nvlist $x1
  }
  return $nvlist
}

proc _startMotion { key v } {
  variable vars

  set vars(selval,$key) $v
  set vars(motion$key) true
}

proc _endMotion { key } {
  variable vars

  set vars(motion$key) false
}

proc _doMotion { key v } {
  variable vars

  if { $vars(motion$key) && $v >= 0 && $v <= $vars(width) } {
    set vars(selval,$key) $v
  }
}

proc _selTraceOn { key } {
  variable vars

  if { [trace info variable vars(selval,$key)] eq "" } {
    trace add variable vars(selval,$key) write _colorChange
  }
}

proc _selTraceOff { key } {
  variable vars
  trace remove variable vars(selval,$key) write _colorChange
}

proc _hexTraceOn { } {
  variable vars

  if { [trace info variable vars(rgbtextvar)] eq "" } {
    trace add variable vars(rgbtextvar) write _hexValueChange
  }
}

proc _hexTraceOff { } {
  variable vars

  trace remove variable vars(rgbtextvar) write _hexValueChange
}

proc _preselColor { hexstr } {
  variable vars

  set vars(rgbtextvar) $hexstr
}

proc chooseColor { val } {
  variable vars

  set vlist [colorutils::fromRgbText $val $vars(ctype)]
  _hexTraceOff
  set vars(rgbtextvar) $val
  _hexTraceOn
  set vars(useval,hue) [lindex $vlist 0]
  set vars(useval,sat) [lindex $vlist 1]
  set vars(useval,val) [lindex $vlist 2]
  foreach {k} {hue sat val} {
    # scale from use to selected.
    _selTraceOff $k
    set vars(selval,$k) [expr {round($vars(useval,$k) /
        $vars(cvt,$vars(ctype)) * $vars(width.d))}]
    _selTraceOn $k
    set vars(dispval,$k) [expr {int(round(double($vars(selval,$k)) / \
        $vars(width.d) / $vars(cvt,$vars(ctype)) * $vars(seltodispscale)))}]
  }

  set w .
  wm title $w {Choose Color}
  set tw {}

  foreach {k} {hue sat val} {
    canvas .canv_$k -width $vars(width) \
        -height $vars(height) -borderwidth 1 \
        -relief sunken -highlightthickness 0
    grid .canv_$k -in $w -sticky {} -padx 5p -pady 3p
  }

  set vars(sampcanv) [frame $tw.samp \
      -borderwidth 1 \
      -relief sunken \
      -highlightthickness 0]
  grid $vars(sampcanv) -in $w -column 1 -row 0 -rowspan 2 \
      -sticky news -padx 5p -pady 3p
  set vars(hexdisp) $tw.hexdisp
  ttk::entry $vars(hexdisp) -width 8 -textvariable vars(rgbtextvar) \
      -justify left \
      -font fixedentry
  grid $vars(hexdisp) -in $w -column 1 -row 2 \
      -sticky ew -padx 5p

  ttk::frame $tw.bot
  grid $tw.bot -in $w -sticky ew -columnspan 2
  ttk::frame $tw.presel
  ttk::frame $tw.bb
  grid $tw.presel $tw.bb -in $tw.bot -sticky e
  grid configure $tw.presel -sticky ew
  grid columnconfigure $tw.bot 0 -weight 1
  ttk::button $tw.close -text Close \
      -command [list _exit false $val] \
      -style Menu.TButton
  ttk::button $tw.select -text Select \
      -command [list _exit true $val] \
      -style Menu.TButton
  grid $tw.select $tw.close -in $tw.bb -padx 2p -pady 1p

  ttk::frame $tw.pref1
  # as HSV
  # magenta = fuschia
  foreach {h s v colname} [list \
      1.0 1.0 1.0 red \
      0.083333 1.0 0.5 brown \
      0.083333 1.0 1.0 orange \
      0.16666 1.0 1.0 yellow \
      0.33333 1.0 1.0 green \
      0.5 1.0 1.0 cyan \
      0.66666 1.0 1.0 blue \
      0.75 1.0 1.0 purple \
      0.83333 1.0 1.0 magenta \
      0.0 0.0 0.0 black \
      0.0 0.0 1.0 white \
      ] {
    set c [colorutils::toRgbText [list $h $s $v] HSV]
    set pw [frame $tw.pre$c \
        -background $c -relief raised \
        -borderwidth 2 \
        -width $vars(pwidth) \
        -height $vars(pwidth)]
    lappend presellist $pw
    bind $pw <ButtonRelease-1> [list _preselColor $c]
  }
  ttk::frame $tw.pref2
  grid $tw.pref1 {*}$presellist $tw.pref2 -in $tw.presel -padx 2p -pady 3p
  grid configure $tw.pref1 -sticky ew
  grid columnconfigure $tw.presel 0 -weight 1
  grid columnconfigure $tw.presel 12 -weight 1

  update
  _setColors

  foreach {key} {hue sat val} {
    bind .canv_$key <ButtonPress-1> "_startMotion $key %x"
    bind .canv_$key <ButtonRelease-1> "_endMotion $key"
    bind .canv_$key <Motion> "_doMotion $key %x"
  }

  wm protocol . WM_DELETE_WINDOW "_exit false $val"
}

proc main { } {
  variable vars
  variable opts

  set vars(rgbtextvar) ""
  set vars(ctype) HSV ;  # default
  set vars(mode) dynamic
  # preselect width/height
  set vars(pwidth) [expr {2*[font measure default 0]}]
  # width of canvas color selection bar
  set vars(width) [expr {36*[font measure default 0]}]
  set vars(width.d) [expr {double($vars(width))}]
  # height of canvas color selection bar
  set vars(height) [expr {2*[font measure default 0]}]
  foreach {k} {hue sat val} {
    set vars(motion$k) false
  }

  set aidx 0
  set didx {}
  set a0 {}
  foreach {a} $::argv {
    switch -exact -- $a {
      -model {
        set didx $a
      }
      -mode {
        set didx $a
      }
      default {
        if { $didx ne {} } {
          set vars($didx) $a
          set didx {}
        } else {
          set a0 $a
        }
      }
    }
    incr aidx
  }

  if { [info exists vars(-model)] } {
    set vars(ctype) [string toupper $vars(-model)]
    if { $vars(ctype) ne "HSV" &&
        $vars(ctype) ne "HSL" &&
        $vars(ctype) ne "RGB" } {
      set vars(ctype) HSV
    }
  }

  if { [info exists vars(-mode)] } {
    set vars(mode) $vars(-mode)
    if { $vars(mode) ne "dynamic" && $vars(mode) ne "static" } {
      set vars(mode) dynamic
    }
  }
  if { $vars(ctype) ne "RGB" } {
    set vars(mode) dynamic
  }

  set vars(cvt,$vars(ctype)) 1.0
  set vars(cvttype) double

  # base values are for creating "pure" colors:
  # fully saturated, neither light nor dark.
  set base 1.0
  if { $vars(ctype) eq "RGB" } {
    set base 0
  }
  foreach {k} {hue sat val} {
    set vars(base,$k) $base
    set vars(olddisp,$k) -1
  }
  if { $vars(ctype) eq "HSL" } {
    set vars(base,val) 0.5
  }

  set vars(seltodispscale) 360.0
  if { $vars(ctype) eq "RGB" } {
    set vars(seltodispscale) 255.0
    set vars(cvt,RGB) 255.0
    set vars(cvttype) int
  }

  if { [regexp {^#[[:xdigit:]]{6}$} $a0] } {
    chooseColor $a0
  } else {
    chooseColor {#ffffff}
  }
}
main

#!/usr/bin/tclsh
#
# Copyright 2012-2016 Brad Lanam Walnut Creek CA USA
# MIT License
#

namespace eval ::colorutils {
  variable vars

  set vars(onethird) [expr {1.0/3.0}]
  set vars(twothirds) [expr {2.0/3.0}]

  proc rgbToHexStr { rgblist } {
    foreach {i} {0 1 2} {
      set v [lindex $rgblist $i]
      if { ! [regexp {^\d{1,3}$} $v] || $v < 0 || $v > 255} {
        return ""
      }
    }
    set t [format #%02x%02x%02x {*}$rgblist]
    return $t
  }

  proc hexStrToRgb { rgbtext } {
    # rgbtext is format: #aabbcc or aabbcc

    if { [regexp {^#?[[:xdigit:]]{6}$} $rgbtext] } {
      scan $rgbtext "#%2x%2x%2x" r g b
      return [list $r $g $b]
    } else {
      return false
    }
  }

  proc toRgbText { vlist {type HSV} } {
    variable vars

    set proc ${type}toRGB
    set rgblist [$proc $vlist]
    return [rgbToHexStr $rgblist]
  }

  proc fromRgbText { rgbtext {type HSV} } {
    variable vars

    set proc RGBto${type}
    set rgblist [hexStrToRgb $rgbtext]
    if { $rgblist != false } {
      return [$proc $rgblist]
    }
    return false
  }

  # RGB

  proc RGBtoRGB { rgblist } {
    return $rgblist
  }

  # HSV

  proc RGBtoHSV { rgblist } {
    set r [expr {double([lindex $rgblist 0]) / 255.0}]
    set g [expr {double([lindex $rgblist 1]) / 255.0}]
    set b [expr {double([lindex $rgblist 2]) / 255.0}]
    set max [expr {max($r, $g, $b)}]
    set min [expr {min($r, $g, $b)}]
    set h $max
    set s $max
    set v $max
    set d [expr {$max - $min}]
    if {$max == 0} {
      set s 0
    } else {
      set s [expr {$d / $max}]
    }

    if {$max == $min} {
      set h 0
    } else {
      if { $max == $r } {
        set t 0.0
        if { $g < $b } {
          set t 6.0
        }
        set h [expr {($g - $b) / $d + $t}]
      }
      if { $max == $g } {
        set h [expr {($b - $r) / $d + 2.0}]
      }
      if { $max == $b } {
        set h [expr {($r - $g) / $d + 4.0}]
      }
      set h [expr {$h / 6.0}]
    }
    return [list $h $s $v]
  }

  proc HSVtoRGB { hsvlist } {
    set h [lindex $hsvlist 0]
    set s [lindex $hsvlist 1]
    set v [lindex $hsvlist 2]

    set i [expr {int($h * 6.0)}]
    set f [expr {$h * 6.0 - $i}]
    set p [expr {$v * (1.0 - $s)}]
    set q [expr {$v * (1.0 - $f * $s)}]
    set t [expr {$v * (1.0 - (1.0 - $f) * $s)}]

    set im6 [expr {$i % 6}]
    if { $im6 == 0 } {
      set r $v; set g $t; set b $p
    }
    if { $im6 == 1 } {
      set r $q; set g $v; set b $p
    }
    if { $im6 == 2 } {
      set r $p; set g $v; set b $t
    }
    if { $im6 == 3 } {
      set r $p; set g $q; set b $v
    }
    if { $im6 == 4 } {
      set r $t; set g $p; set b $v
    }
    if { $im6 == 5 } {
      set r $v; set g $p; set b $q
    }
    return [list [expr {int(round($r * 255.0))}] \
        [expr {int(round($g * 255.0))}] \
        [expr {int(round($b * 255.0))}]]
  }

  # HSL

  proc RGBtoHSL { rgblist } {
    set r [expr {double([lindex $rgblist 0]) / 255.0}]
    set g [expr {double([lindex $rgblist 1]) / 255.0}]
    set b [expr {double([lindex $rgblist 2]) / 255.0}]
    set max [expr {max($r, $g, $b)}]
    set min [expr {min($r, $g, $b)}]
    set l [expr {($max + $min) / 2.0}]

    if { $max == $min } {
      set h 0.0
      set s 0.0
    } else {
      set d [expr {$max - $min}]
      if { $l > 0.5 } {
        set s [expr {$d / (2.0 - $max - $min)}]
      } else {
        set s [expr {$d / ($max + $min)}]
      }
      if {$max == $r } {
        set g2 0.0
        if {$g < $b} { set g2 6.0 }
        set h [expr {($g - $b) / $d + $g2}]
      } elseif {$max == $g} {
        set h [expr {($b - $r) / $d + 2.0}]
      } elseif {$max == $b} {
        set h [expr {($r - $g) / $d + 4.0}]
      }
      set h [expr {$h / 6.0}]
    }

    return [list $h $s $l]
  }

  # used by HSLtoRGB()
  proc hue2rgb {p q t} {
    variable vars

    if {$t < 0.0} { set t [expr {$t + 1.0}] }
    if {$t > 1.0} { set t [expr {$t - 1.0}] }

    if {$t < [expr 1.0/6.0]} { return [expr {$p + ($q - $p) * 6.0 * $t}] }

    if {$t < 0.5} { return $q }

    if {$t < $vars(twothirds)} {
      return [expr {$p + ($q - $p) * ($vars(twothirds) - $t) * 6.0}]
    }
    return $p
  }

  proc HSLtoRGB { hsllist } {
    variable vars

    lassign $hsllist h s l

    if {$s == 0} {
      set r $l
      set g $l
      set b $l
    } else {
      if { $l < 0.5 } {
        set q [expr {$l * (1.0 + $s)}]
      } else {
        set q [expr {$l + $s - ($l * $s)}]
      }
      set p [expr {2.0 * $l - $q}]

      set r [hue2rgb $p $q [expr {$h + $vars(onethird)}]]
      set g [hue2rgb $p $q $h]
      set b [hue2rgb $p $q [expr {$h - $vars(onethird)}]]
    }

    return [list [expr {round($r * 255.0)}] \
        [expr {round($g * 255.0)}] \
        [expr {round($b * 255.0)}]];
  }
}

package provide colorutils 1.1

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References