[bll] 2017-4-23 : I dislike the default color picker that comes with Tk, and the other implementations did not appeal to me.  I wrote a simple HSV color picker.  It's not difficult to make this work with RGB or HSL (and I believe I have code available if you want it), but I don't think I ever got CIELUV working. 2018-1-2: reordered pre-selectable colors.  2018-4-22: added HSL and RGB.

yacp.tcl accepts the initial color from the command line, and outputs the new color (or initial color if closed) to stdout.

'''Examples:'''
======
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'
======

[img-yacp]

'''yacp.tcl'''
======
#!/usr/bin/tclsh
#
# yet another color picker
#
# Copyright 2012-2018 Brad Lanam Walnut Creek CA USA
#

package require Tk 8.5-

set ap [file normalize [file join [file dirname [info script]] .. code]]
if { $ap ni $::auto_path } {
  lappend ::auto_path $ap
}
unset ap

package require bdjmsgs
package require mvars
package require colorutils
package require mutils
package require uiutils
package require options

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.
#   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
#   oldsel,{hue|sat|val}  : the old select 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
#   color.model           : 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
  variable opts

  set len [string length $vars(rgbtextvar)]
  if { [regexp {^#?[[:xdigit:]]{6,12}$} $vars(rgbtextvar)] &&
      (($len == 7 && $vars(colwidth) == 2) ||
       ($len == 10 && $vars(colwidth) == 3) ||
       ($len == 13 && $vars(colwidth) == 4)) } {
    setCurrentColor $vars(rgbtextvar)
    _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) [expr {$vars(width)-1}]
    }
    _selTraceOn $k

    set vars(useval,$k) [expr {double($vars(selval,$k)) /
        $vars(width.d) * $vars(cvt,$vars(color.model))}]
    if { $vars(cvttype) eq "int" } {
      set vars(useval,$k) [expr {int($vars(useval,$k))}]
    }
  }

  if { $vars(mode) eq "dynamic" && $vars(color.model) eq "RGB" } {
    set s $vars(useval,sat)
    set v $vars(useval,val)
  } else {
    set s $vars(base,sat)
    set v $vars(base,val)
  }

  if { $vars(oldsel,hue) != $vars(selval,hue) ||
      ($vars(mode) eq "dynamic" && $vars(color.model) eq "RGB") } {
    .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(color.model))}]
        if { $vars(cvttype) eq "int" } {
          set x1 [expr {int(round($x1))}]
        }
        set c [::colorutils::toRgbText \
            [list $x1 $s $v] $vars(color.model)]
        .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(color.model))}]
    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(color.model)]
      .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(color.model)]
      .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(color.model)]
  set sc $vars(sampcanv)
  $sc configure -background $c
  _hexTraceOff
  set ct [::colorutils::toRgbText \
      [list $vars(useval,hue) $vars(useval,sat) $vars(useval,val)] \
      $vars(color.model) $vars(colwidth)]
  set vars(rgbtextvar) $ct
  _hexTraceOn

  foreach {k} {hue sat val} {
    set vars(oldsel,$k) $vars(selval,$k)
  }
}

proc _exit { selflag val } {
  variable vars

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

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 setCurrentColor { val } {
  variable vars

  set vlist [::colorutils::fromRgbText $val $vars(color.model)]
  _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 cvt $vars(cvt,$vars(color.model))
    if { $vars(color.model) eq "RGB" } {
      set cvt [expr {int(16.0**$vars(colwidth)-1)}]
    }
    set vars(selval,$k) [expr {round(double($vars(useval,$k)) /
        double($cvt) * double($vars(width.d)))}]
    _selTraceOn $k
  }
}

proc chooseColor { val } {
  variable vars

  setCurrentColor $val

  set w .
  wm title $w [_GT {} {Choose Color}]
  if { 1 } {
    $w configure -background [$::bdjopt get UIBGCOLOR]
  }
  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 [expr {$vars(colwidth)*3+2}] \
      -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 [_GT {} Close] \
      -command [list _exit false $val] \
      -style Menu.TButton
  ttk::button $tw.select -text [_GT {} 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.0833333333 1.0 0.5 brown \
      0.0833333333 1.0 1.0 orange \
      0.1666666666 1.0 1.0 yellow \
      0.3333333333 1.0 1.0 green \
      0.5 1.0 1.0 cyan \
      0.6666666666 1.0 1.0 blue \
      0.75 1.0 1.0 purple \
      0.75 1.0 0.5 dark-purple \
      0.8333333333 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
    set c [::colorutils::toRgbText [list $h $s $v] HSV $vars(colwidth)]
    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 $tw.pref1 -weight 1
  grid columnconfigure $tw.presel $tw.pref2 -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(color.model) HSV ;  # default
  set vars(mode) dynamic
  set vars(colwidth) 2
  # preselect width/height
  set vars(pwidth) [expr {2*[font measure default 0]}]
  # width of canvas color selection bar
  set vars(width) [expr {40*[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
  }

##stand-alone
  if { 1 } {
    set aidx 0
    set didx {}
    set a0 {}
    foreach {a} $::argv {
      switch -exact -- $a {
        -model {
          set didx $a
        }
        -mode {
          set didx $a
        }
        -colwidth {
          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(color.model) [string toupper $vars(-model)]
    }
    if { [info exists vars(-mode)] } {
      set vars(mode) $vars(-mode)
    }
    if { [info exists vars(-colwidth)] } {
      set vars(colwidth) $vars(-colwidth)
    }

    proc _GT {a b} {
      return $b
    }
    font create fixedentry
    font configure fixedentry {*}[font actual TkFixedFont]
    font configure fixedentry -size 11
  }
#end stand-alone

  if { $vars(color.model) ne "HSV" &&
      $vars(color.model) ne "HSL" &&
      $vars(color.model) ne "RGB" } {
    set vars(color.model) HSV
  }
  if { $vars(mode) ne "dynamic" && $vars(mode) ne "static" } {
    set vars(mode) dynamic
  }
  if { $vars(color.model) ne "RGB" } {
    set vars(mode) dynamic
  }
  if { $vars(colwidth) < 2 || $vars(colwidth) > 4 } {
    set vars(colwidth) 2
  }

  set vars(cvt,$vars(color.model)) 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(color.model) eq "RGB" } {
    set base 0
  }
  foreach {k} {hue sat val} {
    set vars(base,$k) $base
    set vars(oldsel,$k) -1
  }
  if { $vars(color.model) eq "HSL" } {
    set vars(base,val) 0.5
  }

  set vars(seltodispscale) 360.0
  if { $vars(color.model) eq "RGB" } {
    set vars(seltodispscale) 360.0
    set vars(cvt,RGB) 65535
    set vars(cvttype) int
  }

  set len [string length $a0]
  if { [regexp {^#[[:xdigit:]]{6,12}$} $a0] &&
      ($len == 7 || $len == 10 || $len == 13) } {
    chooseColor $a0
  } else {
    chooseColor {#ffffff}
  }
}
main
======

'''colorutils.tcl'''
======
#!/usr/bin/tclsh
#
# 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
# https://stackoverflow.com/questions/726549/algorithm-for-additive-color-mixing-for-rgb-values#727339

# don't force Tk to be required
#package require Tk

namespace eval ::colorutils {
  variable vars

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

  # this routine assumes the colors in the range 0-255
  proc perceivedLuminosity { clist } {
    if { [regexp {^#} $clist] } {
      lassign [hexStrToRgb $clist] r g b sz
      set div 65535.0
      if { $sz != 4 } {
        set div [expr {65536.0/(16.0**$sz)-1.0}]
      }
    } else {
      lassign $clist r g b
      set div 255.0
    }
    set r [expr {double($r)/$div}]
    set g [expr {double($g)/$div}]
    set b [expr {double($b)/$div}]
    # http://stackoverflow.com/questions/596216/formula-to-determine-brightness-of-rgb-color
    set l [expr {0.299*$r+0.587*$g+0.114*$b}]
    return $l
  }

  # this routine assumes the colors in the range 0-255
  proc luminosity { clist } {
    if { [regexp {^#} $clist] } {
      lassign [hexStrToRgb $clist] r g b sz
      set div 65535.0
      if { $sz != 4 } {
        set div [expr {65536.0/(16.0**$sz)-1.0}]
      }
    } else {
      lassign $clist r g b
      set div 255.0
    }
    set r [expr {double($r)/$div}]
    set g [expr {double($g)/$div}]
    set b [expr {double($b)/$div}]
    # http://stackoverflow.com/questions/596216/formula-to-determine-brightness-of-rgb-color
    set l [expr {0.2126*$r+0.7152*$g+0.0722*$b}]
    return $l
  }

  # adjust the color 'col'
  # based on the difference between 'oldcol' and 'newcol'
  proc adjustColor { col oldcol newcol } {
    lassign [winfo rgb . $col] rc gc bc
    lassign [winfo rgb . $oldcol] ro go bo
    lassign [winfo rgb . $newcol] rn gn bn

    # handle white and black.
    if { ($rc == 0 && $gc == 0 && $bc == 0) ||
        ($rc == 65535 && $gc == 65535 && $bc == 65535) } {
      return [rgbToHexStr [list $rc $gc $bc]]
    }

    # 0.3 * 65535 = 19661
    # 0.2 * 65535 = 13107
    # 0.1 * 65535 = 6553
    set fga 19661
    set bga [expr {65535-$fga}]

    # assuming an 70% foreground, 30% background blend, do
    # a reverse transform to get a color based on the old background.
    set rorig [expr {((65535 * $rc) - $ro * $bga) / $fga}]
    set gorig [expr {((65535 * $gc) - $go * $bga) / $fga}]
    set borig [expr {((65535 * $bc) - $bo * $bga) / $fga}]
    # this seems to work, don't know if it is right.
    if { $rorig < 0 } { set rorig [expr {-$rorig}] }
    if { $gorig < 0 } { set gorig [expr {-$gorig}] }
    if { $borig < 0 } { set borig [expr {-$borig}] }

    # and then blend it back together with the new background.
    set rnew [expr {($rn * $bga + $rorig * $fga) / 65535}]
    set gnew [expr {($gn * $bga + $gorig * $fga) / 65535}]
    set bnew [expr {($bn * $bga + $borig * $fga) / 65535}]
    return [rgbToHexStr [list $rnew $gnew $bnew]]
  }

  proc opaqueblend { fg bg fga } {
    variable vars

    # caching winfo rgb does not help
    lassign [winfo rgb . $fg] rf gf bf
    lassign [winfo rgb . $bg] rb gb bb

    # fga is 0.9, we want 0.9 of fg, 0.1 of bg
    set bga [expr {65535-$fga}]
    set rn [expr {($rb * $bga + $rf * $fga) / 65535}]
    set gn [expr {($gb * $bga + $gf * $fga) / 65535}]
    set bn [expr {($bb * $bga + $bf * $fga) / 65535}]
    return [rgbToHexStr [list $rn $gn $bn]]
  }

  proc lightenColor { col } {
    # 0.8 * 65535 = 52428
    return [opaqueblend $col #ffffff 52428]
  }

  proc darkenColor { col } {
    # 0.9 * 65535 = 58982
    return [opaqueblend $col #000000 58982]
  }

  # blend with the background
  proc disabledColor { col bg } {
    # 0.6 * 65535 = 39321
    return [opaqueblend $col $bg 39321]
  }

  proc getLightDarkColors { c } {
    set dcolor [::colorutils::darkenColor $c]
    set ddcolor [::colorutils::darkenColor $dcolor]
    set dddcolor [::colorutils::darkenColor $ddcolor]
    set lcolor [::colorutils::lightenColor $c]
    set llcolor [::colorutils::lightenColor $lcolor]
    if { $llcolor eq "#ffffffffffff" } {
      set llcolor [::colorutils::darkenColor #ffffffffffff]
      set lcolor [::colorutils::darkenColor $lcolor]
      set llcolor [::colorutils::darkenColor $llcolor]
    }
    return [list $dcolor $dddcolor $lcolor $llcolor]
  }


  proc rgbToHexStr { rgblist {sz 4} } {
    set nrgblist [list]
    foreach {i} {0 1 2} {
      set v [lindex $rgblist $i]
      if { ! [regexp {^\d{1,5}$} $v] || $v < 0 || $v > 65535} {
        return ""
      }
      if { $sz != 4 } {
        set div [expr {65536.0/(16.0**$sz)}]
        set v [expr {int(double($v)/$div)}]
      }
      lappend nrgblist $v
    }
    set fmt #%04x%04x%04x
    switch -exact -- $sz {
      4 { set fmt #%04x%04x%04x }
      3 { set fmt #%03x%03x%03x }
      2 { set fmt #%02x%02x%02x }
    }
    set t [format $fmt {*}$nrgblist]
    return $t
  }

  # also returns the colorwidth (2,3,4)
  proc hexStrToRgb { rgbtext } {
    # rgbtext is format: #aabbcc or #aaabbbccc or #aaaabbbbcccc

    set len [string length $rgbtext]
    if { [regexp {^#[[:xdigit:]]{6,12}$} $rgbtext] &&
        ($len == 7 || $len == 10 || $len == 13) } {
      set sfmt #%4x%4x%4x
      set cwidth 4
      switch -exact -- $len {
        7 { set sfmt #%2x%2x%2x; set cwidth 2 }
        10 { set sfmt #%3x%3x%3x; set cwidth 3 }
        14 { set sfmt #%4x%4x%4x; set cwidth 4 }
      }
      scan $rgbtext $sfmt r g b
      return [list $r $g $b $cwidth]
    } else {
      return false
    }
  }

  proc colorToRgbText { col {sz 4} } {
    variable vars

    set clist [winfo rgb . $col]
    return [rgbToHexStr $clist $sz]
  }

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

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

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

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

  proc RGBtoDouble { rgblist } {
    set csz [expr {double([lindex $rgblist 3])}]
    set div [expr {(16.0**$csz)-1.0}]
    set r [expr {double([lindex $rgblist 0])/$div}]
    set g [expr {double([lindex $rgblist 1])/$div}]
    set b [expr {double([lindex $rgblist 2])/$div}]
    return [list $r $g $b]
  }

  # RGB

  proc RGBtoRGB { rgblist } {
    return [lrange $rgblist 0 2]
  }

  # HSV

  proc RGBtoHSV { rgblist } {
    lassign [RGBtoDouble $rgblist] r g b
    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 } {
    lassign $hsvlist h s v

    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 * 65535.0))}] \
        [expr {int(round($g * 65535.0))}] \
        [expr {int(round($b * 65535.0))}]]
  }

  # HSL

  proc RGBtoHSL { rgblist } {
    lassign [RGBtoDouble $rgblist] r g b
    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 * 65535.0)}] \
        [expr {round($g * 65535.0)}] \
        [expr {round($b * 65535.0)}]];
  }
}

package provide colorutils 4.3
======

<<categories>>Category GUI