#!/usr/bin/tclsh
#
# yet another color picker
#
# Copyright 2012-2017 Brad Lanam Walnut Creek CA USA
# MIT License
#
# 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-
source ./colorutils.tcl

variable vars

# 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.
#   seltousescale : the value to convert a selected value to a
#      internal use value.  The selected value is divided by the width
#      of the canvas, then multipled by this value.
#

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)]
    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 / double($vars(width)))}]
  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 / double($vars(width)))}]

  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)) / \
        double($vars(width)) * $vars(seltodispscale)))}]
    set vars(useval,$k) [expr {$vars(selval,$k) / \
        double($vars(width)) * $vars(seltousescale)}]
  }

  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) / double($vars(width)) * \
            $vars(seltousescale)}]
        set c [colorutils::toRgbText \
            [list $x1 $vars(base,sat) $vars(base,val)]]
        .canv_hue create rectangle \
            $x 0 [expr {$rw + $x}] $vars(height) \
            -fill $c -outline {}
      }
    }
  }

  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) / double($vars(width)) * \
        $vars(seltousescale)}]
    if { $vars(selval,sat) == $x } {
      _drawMarker .canv_sat $x
    } else {
      set c [colorutils::toRgbText [list $h $x1 $vars(useval,val)]]
      .canv_sat create rectangle $x 0 [expr {$rw+$x}] $vars(height) \
          -fill $c -outline {}
    }
    if { $vars(selval,val) == $x } {
      _drawMarker .canv_val $x
    } else {
      set c [colorutils::toRgbText [list $h $vars(useval,sat) $x1]]
      .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)]]
  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)]]
  } else {
    puts $val
  }
  destroy .
  exit
}

proc _createSelValues { vlist } {
  variable vars

  set nvlist {}
  # build a new list of values for huerv, satrv, and valrv.
  for {set i 0} {$i < 3} {incr i} {
    set rv [expr {round([lindex $vlist $i] * $vars(width))}]
    lappend nvlist $rv
  }
  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]
  _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(seltousescale) * \
        double($vars(width)))}]
    _selTraceOn $k
    set vars(dispval,$k) [expr {int(round(double($vars(selval,$k)) / \
        double($vars(width)) * $vars(seltodispscale)))}]
    set vars(olddisp,$k) -1
  }

  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
  # white, brown, orange, yellow, green,
  # cyan, blue, purple, magenta, red, black
  foreach {h s v} [list \
      0.0 0.0 1.0 \
      0.083333 1.0 0.5 \
      0.083333 1.0 1.0 \
      0.16666 1.0 1.0 \
      0.33333 1.0 1.0 \
      0.5 1.0 1.0 \
      0.66666 1.0 1.0 \
      0.75 1.0 1.0 \
      0.83333 1.0 1.0 \
      1.0 1.0 1.0 \
      0.0 0.0 0.0 \
      ] {
    set c [colorutils::toRgbText [list $h $s $v]]
    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) ""
  # preselect width/height
  set vars(pwidth) [expr {2*[font measure default 0]}]
  # height of canvas color selection bar
  set vars(height) [expr {2*[font measure default 0]}]
  # width of canvas color selection bar
  set vars(width) [expr {36*[font measure default 0]}]
  foreach {k} {hue sat val} {
    set vars(motion$k) false
  }

  set a0 {}
  if { $::argc > 0 } {
    set a0 [lindex $::argv 0]
  }

  # base values are for creating "pure" colors:
  # fully saturated, neither light nor dark.
  foreach {k} {hue sat val} {
    set vars(base,$k) 1.0
  }
  set vars(seltodispscale) 360.0
  set vars(seltousescale) 1.0

  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 {
  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] } {
      set t [string trimleft $rgbtext #]
      scan $t "%2x%2x%2x" r g b
      return [list $r $g $b]
    } else {
      return false
    }
  }

  proc toRgbText { vlist } {
    variable vars

    set rgblist [HSVtoRGB $vlist]
    return [rgbToHexStr $rgblist]
  }

  proc fromRgbText { rgbtext } {
    variable vars

    set rgblist [hexStrToRgb $rgbtext]
    if { $rgblist != false } {
      return [RGBtoHSV $rgblist]
    }
    return false
  }

  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))}]]
  }
}

package provide colorutils 1.0