# <20170103.1700.25>
# tcolor --
# This script implements a simple color editor, where you can
# create colors using either the RGB, HSB, or CYM color spaces
# and apply the color to existing applications.
#
# IputColor (start) is the color to start with and to which we return if
# exit is any but OK.
#
# ColorEditor name dothis start ?gray/grey?

# 'name' is/will be the name of space and is used in the window the title.
# 'dothis' is a script that is executed each time the color is changed. This
#          script is evaluated after replacing "%%" in the script with
#          the new color, i.e.:
#          eval [regsub -all %% $dothis <color>]
#            (unless the autoupdates option is disabled - 
#                see the menu on the color edit window).
# 'start'  is the starting color.
# 'gray/grey' is the spelling of gray that you want to use for those color
#             names that have gray or grey in them.  It is optional and
#             defaults to gray.

# The return value is the window name, i.e. '.name' where name is the
# 'name' passed in.

# The Color edit window which can be used to change the color in either of the
# three color spaces (RGB HSB & CYM) as per the menu.  The window & 
# color editor are exited by either the OK, Cancel or X buttons which
# also destroy the window and the namespace.  If, per chance, the window
# and name space exist on entry, they will be cleaned up (i.e. destroyed)
# and a new namespace/window is created.

# The window by the name of ".$name" may be distroyed to clean up and 
# destroy the namespace as well.

# In putting together the color distance list an attempt is made to find
# and list the color names closest to the selected color.  The straight 
# 3D distance is:
# sqrt(r**2 + g**2 + b**2) but due to the way the eye sees
# colors a better distance from CCIR 601 is given by: 
# sqrt(r*r*0.299 + g*g*0.587 + b*b*0.114)
# Since we are only interested in finding the relative closeness of a 
# color, we don't need to take the square root since we are just
# comparing magnitude.  We can also simplify the calculation as follows:
# r*r*(0.299/0.114) + g*g*(0.587/0.114) + b*b  or 
# r*r*2.622 + g*g*5.149 + b*b
# To see the difference we set up to do either with a menu item to change
# from one to the other.


proc ColorEditor { name dothis start {gray "gray"}} {
  #  puts "dothis is $dothis"
  #Clean up any old calls...
  catch {destroy .$name}

  namespace eval $name {
    variable label1
    variable label1
    variable label2
    variable label3
    variable command
    variable width 20   ;# Width of the color names list box
    variable Tab   5    ;# Width of the color next to the name in 'near' list
    variable w
    variable gray
    variable red
    variable green
    variable blue
    variable color
    variable colorSpace
    variable updating
    variable autoUpdate
    variable colorWeights {2.622 5.149}
    variable colorOnInput
    variable whichColor [namespace tail [namespace current]]
    variable w .$whichColor

    proc DoColorEditor {dothis entrycolor} {
      variable label1
      variable label1
      variable label2
      variable label3
      variable command "$dothis"
      variable width 20
      variable Tab
      variable red
      variable green
      variable blue
      variable colorSpace
      variable updating
      variable autoUpdate
      variable colorOnInput
      variable whichColor
      variable w
      variable colorFileList

 #     puts "do this is $command"


      set colorOnInput $entrycolor
      set color $colorOnInput
      toplevel $w
      wm geo $w 746x290
      wm title $w "Color Editor $whichColor"
      wm protocol $w WM_DELETE_WINDOW [namespace code {ExitColor 1}]
      #  puts "$color is"
      # variables that control the program:
      #
      # colorSpace -		Color space currently being used for
      #				editing.  Must be "rgb", "cmy", or "hsb".

      # label1, label2, label3 - Labels for the scales.

      # red, green, blue -	Current color intensities in decimal
      #				on a scale of 0-65535.

      # color -			A string giving the current color value
      #				in the proper form for x:
      #				#RRRRGGGGBBBB

      # updating -		Non-zero means that we're in the middle of
      #				updating the scales to load a new color,so
      #				information shouldn't be propagating back
      #				from the scales to other elements of the
      #				program:  this would make an infinite loop.

      # command -		Holds the command that has been typed
      #				into the "Command" entry.

      # autoUpdate -		1 means execute the update command
      #				automatically whenever the color changes.

      # name -			Name for new color, typed into entry.

      set colorSpace hsb
      set red 65535
      set green 0
      set blue 0
      set updating 0
      set autoUpdate 2
      set name ""

      # Create the menu bar at the top of the window.

      frame $w.menu -relief raised -borderwidth 2 
      frame $w.middle -relief raised -borderwidth 2
      frame $w.bot -relief raised -borderwidth 2
      grid $w.menu -row 1 -stick new
      grid $w.middle -row 3 -sticky ewns
      grid $w.bot -row 5 -sticky wes
      grid columnconfigure $w all -weight 1
      grid rowconfigure $w 3 -weight 1
      
      menubutton $w.menu.file -text ColorSpace \
	  -menu $w.menu.file.m -underline 0
      menu $w.menu.file.m -tearoff false
      $w.menu.file.m add radio\
	  -label "Automatic updates"\
	  -variable [namespace current]::autoUpdate \
	  -command [namespace code {manUpdate;grid remove $w.update}] \
	  -value 1 \
	  -underline 0
      $w.menu.file.m add radio \
	  -label "Update on mouse release" \
	  -variable [namespace current]::autoUpdate \
	  -command [namespace code {manUpdate;grid  remove $w.update}] \
	  -value 2 \
	  -underline 0
      $w.menu.file.m add radio \
	  -label "Manual updates" \
	  -variable [namespace current]::autoUpdate \
	  -command [namespace code {manUpdate;grid $w.update -in $w.bot}] \
	  -value 0 \
	  -underline 0
      $w.menu.file.m add separator
      $w.menu.file.m add radio \
	  -label "I spell gray this way" \
	  -value {grey} \
	  -command [namespace code fillColorNameList] \
          -variable  [namespace current]::gray
     $w.menu.file.m add radio \
	  -label "I spell grey this way" \
	  -command [namespace code fillColorNameList] \
	  -value {gray} \
          -variable  [namespace current]::gray
      $w.menu.file.m add separator
      $w.menu.file.m add radio \
	  -label "Use weighted color distance" \
	  -command [namespace code setNearColors] \
	  -value {2.622 5.149} \
	  -variable [namespace current]::colorWeights
     $w.menu.file.m add radio \
	  -label "Use un-weighted color distance" \
	  -command [namespace code setNearColors] \
	  -value {1 1} \
	  -variable [namespace current]::colorWeights 
         
      label $w.ivaluen -text {Starting color:}
      label $w.ivalue -textvariable [namespace current]::colorOnInput\
	  -width $width \
	  -text "start value" \
	  -background $colorOnInput \
	  -foreground [textColorFor $colorOnInput] \
	  -font -Adobe-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*
      grid $w.menu.file -row 0 -column 0 -in $w.menu -sticky w
      grid $w.ivaluen -row 0 -column 1  -in $w.menu -sticky e
      grid $w.ivalue -row 0 -column 3  -in $w.menu -sticky ew

      bind $w.ivalue <1> [namespace code [list tc_loadNamedColor $colorOnInput]]

      grid columnconfigure $w.menu all -weight 1
      grid columnconfigure $w.menu 3 -weight 0
      # Create the command entry window at the bottom of the window, along
      # with the update button.

      button $w.update -text Update -command [namespace code {manUpdate}]
      button $w.ok -text OK -command [namespace code {ExitColor 0}]
      button $w.cancel -text Cancel -command [namespace code {ExitColor 1}]

      grid $w.update -in $w.bot -row 0 -column 2 -pady .1c -padx .25c -sticky ew
      grid $w.ok -in $w.bot -row 0 -column 3 -pady .1c -padx .25c -sticky ew
      grid $w.cancel -in $w.bot -row 0 -column 4 -pady .1c -padx .25c -sticky e
      grid columnconfigure $w.bot 0 -weight 1
      if {$autoUpdate != 0} {
	grid remove $w.update
      }

      # Create the listbox that holds all of the color names in rgb.txt,
      # if an rgb.txt file can be found.
      frame $w.middle.left
      frame $w.middle.middle
      frame $w.middle.right
      frame $w.middle.midleft
      grid $w.middle.left    -column 1 -row 1 -padx .25c -pady .25c -sticky ensw
      grid $w.middle.midleft -column 2 -row 1 -padx .25c -pady .25c -sticky ensw
      grid $w.middle.middle  -column 3 -row 1 -padx .25c -pady .25c -sticky ensw
      grid $w.middle.right   -column 5 -row 1 -padx .25c -pady .25c -sticky ensw
      grid columnconfigure $w.middle 3 -weight 1
      grid rowconfigure $w.middle all -weight 1

	
      listbox $w.names -width 20 -yscrollcommand "$w.scroll set" \
	  -relief sunken -borderwidth 2 -exportselection false\
	  -background white -foreground black -height 13
      # The following regsub dance extracts the window name (which is also
      # the space name) from %W. 
      bind $w.names <1> [namespace code {tc_loadNamedColor \
					     [%W get [%W nearest %y]]}]

      scrollbar $w.scroll -orient vertical -command "$w.names yview" \
	  -relief sunken -borderwidth 2
      grid $w.names -in $w.middle.left -column 2 -row 1 -sticky nsew
      grid $w.scroll -in $w.middle.left  -column 3 -row 1 -sticky nsew
      grid rowconfigure $w.middle.left 1 -weight 1

      # create a text box to display the 'close' color names
      text $w.text -width $width  -relief sunken -wrap none\
	  -background white -cursor arrow -height 13\
	  -relief sunken -borderwidth 2
      grid $w.text -in $w.middle.midleft -sticky nsew
      grid columnconfigure $w.middle.midleft all -weight 1
      grid rowconfigure $w.middle.midleft all -weight 1

      # Create the three scales for editing the color, and the entry for
      # typing in a color value.
      foreach i {rgb cmy hsb} col {1 2 3} {
	radiobutton $w.colSpace$i \
	    -command [namespace code "changeColorSpace $i"]\
	    -variable [namespace current]::colorSpace \
	    -text  [string toupper $i] \
	    -value $i\
	    -offrelief flat\
	    -indicatoron false\
	    -overrelief raised\
	    -underline 0
	grid $w.colSpace$i -in $w.middle.middle -row 0 -column $col -sticky ews
      }
      label $w.colSpace -text {Color space}
      grid  $w.colSpace -columnspan 3 -row 1 -column 1\
	    -in $w.middle.middle -sticky ewn

      foreach i {1 2 3} j {2 4 6} k {3 5 7} {
	label $w.label$i -textvariable [namespace current]::label$i
	scale $w.scale$i -from 0 -to 1000 -length 6c -orient horizontal \
	    -command [namespace code {tc_scaleChanged}]
	grid $w.scale$i -columnspan 3 -row $j -column 1\
	    -in $w.middle.middle -sticky ews
	grid $w.label$i -columnspan 3 -row $k -column 1 \
	    -in $w.middle.middle -sticky new
	grid rowconfigure $w.middle.middle all -weight 1
	grid columnconfigure $w.middle.middle all -weight 1
	bind $w.scale$i <ButtonRelease> [namespace code manUpdate]
      }
      fillColorNameList

      # Create the color display swatch on the right side of the window.

      frame $w.swatch -background $color 
      label $w.value -textvariable [namespace current]::color -width $width\
	  -background $colorOnInput -foreground [textColorFor $colorOnInput]

      #grid $w.ivalue -in $w.middle.right -row 0 -stick sew       
      grid $w.swatch -in $w.middle.right -row 1 -stick news
      grid $w.value -in $w.middle.right -row 2 -stick new
      grid rowconfigure $w.middle.right all -weight 0
      grid rowconfigure $w.middle.right 1 -weight 1
      grid columnconfigure $w.middle.right all -weight 1

      tc_loadNamedColor $colorOnInput

      changeColorSpace hsb
    }

    # This procedure gets the current list of color names and puts
    # them in the color name list. It also sets up the 'nearest' color
    # panel.

    # getting the color list info takes a bit of time
    # so put in a global space so we only need to do it once.

    proc fillColorNameList {} {
      variable gray
      variable w
      variable width 20
      variable Tab
      global colorList-1-1-$gray
      if {![info exists colorList-1-1-$gray] ||\
	      [set colorList-1-1-$gray] == {}} {
	set colorList-1-1-$gray [getColors 1 1 "*${gray}*"]
      }
      $w.names delete 0 end
      set font [$w.text cget -font]
      foreach ent [set colorList-1-1-$gray] {
	$w.names insert end [lindex $ent 0]
      }
      $w.text config -tabs [expr {($Tab -2) * [font measure $font "0"]}]
      $w.text config -width [expr $width + $Tab]
    }

    # The procedure below is invoked when one of the scales is adjusted.
    # It propagates color information from the current scale readings
    # to everywhere else that it is used.

    proc tc_scaleChanged { args} {
      variable red
      variable green
      variable blue
      variable color
      variable colorSpace
      variable updating
      variable autoUpdate
      variable whichColor
      variable w
      if $updating {
	return
      }
      if {$colorSpace == "rgb"} {
	set red   [format %.0f [expr [$w.scale1 get]*65.535]]
	set green [format %.0f [expr [$w.scale2 get]*65.535]]
	set blue  [format %.0f [expr [$w.scale3 get]*65.535]]
      } else {
	if {$colorSpace == "cmy"} {
	  set red   [format %.0f [expr {65535 - [$w.scale1 get]*65.535}]]
	  set green [format %.0f [expr {65535 - [$w.scale2 get]*65.535}]]
	  set blue  [format %.0f [expr {65535 - [$w.scale3 get]*65.535}]]
	} else {
	  set list [hsbToRgb [expr {[$w.scale1 get]/1000.0}] \
			[expr {[$w.scale2 get]/1000.0}] \
			[expr {[$w.scale3 get]/1000.0}]]
	  set red [lindex $list 0]
	  set green [lindex $list 1]
	  set blue [lindex $list 2]
	}
      }
      doUpdate
    }

    # The procedure below is invoked to update the scales from the
    # current red, green, and blue intensities.  It's invoked after
    # a change in the color space and after a named color value has
    # been loaded.

    proc tc_setScales {} {
      variable red
      variable green
      variable blue
      variable colorSpace
      variable updating
      variable w
      #     puts "setting scales $colorSpace for $w"
      set updating 1
      if {$colorSpace == "rgb"} {
	$w.scale1 set [format %.0f [expr $red/65.535]]
	$w.scale2 set [format %.0f [expr $green/65.535]]
	$w.scale3 set [format %.0f [expr $blue/65.535]]
      } else {
	if {$colorSpace == "cmy"} {
	  $w.scale1 set [format %.0f [expr (65535-$red)/65.535]]
	  $w.scale2 set [format %.0f [expr (65535-$green)/65.535]]
	  $w.scale3 set [format %.0f [expr (65535-$blue)/65.535]]
	} else {
	  set list [rgbToHsv $red $green $blue]
	  $w.scale1 set [format %.0f [expr {[lindex $list 0] * 1000.0}]]
	  $w.scale2 set [format %.0f [expr {[lindex $list 1] * 1000.0}]]
	  $w.scale3 set [format %.0f [expr {[lindex $list 2] * 1000.0}]]
	}
      }
      # Flush the last scale change action
      update
      set updating 0
    }

    # The procedure below is invoked when a named color has been
    # selected from the listbox or typed into the entry.  It loads
    # the color into the editor.

    proc tc_loadNamedColor {name } {    

      variable red
      variable green
      variable blue
      variable color
      variable autoUpdate
      variable w

      lassign [winfo rgb $w.swatch $name] red green blue
      tc_setScales
      #      puts "2red $red green $green blue $blue"
      doUpdate $name
      if {$autoUpdate == 2} {
	manUpdate
      }
    }

    # The procedure below is invoked when a new color space is selected.
    # It changes the labels on the scales and re-loads the scales with
    # the appropriate values for the current color in the new color space

    proc changeColorSpace space {
      variable label1
      variable label2
      variable label3
      variable w
      #      puts "setting space lables $space"
      if {$space == "rgb"} {
	set label1 Red
	set label2 Green
	set label3 Blue
	tc_setScales
	return
      }
      if {$space == "cmy"} {
	set label1 Cyan
	set label2 Magenta
	set label3 Yellow
	tc_setScales
	return
      }
      if {$space == "hsb"} {
	set label1 Hue
	set label2 Saturation
	set label3 Brightness
	tc_setScales
	return
      }
    }
    # Text color.  Returns either white or black depending on
    # perceived luminescence.
    proc textColorFor { color } {
      lassign [winfo rgb . $color] r g b
      return [expr {(0.299 * $r + \
			 0.587 * $g + \
			 0.114 * $b) > 32768 ? "black" : "white"}]
    }

    # The procedure below converts an RGB value to HSB.  It takes red, green,
    # and blue components (0-65535) as arguments, and returns a list containing
    # HSB components (floating-point, 0-1) as result.  The code here is a copy
    # of the code on page 615 of "Fundamentals of Interactive Computer Graphics"
    # by Foley and Van Dam.

    proc rgbToHsv {red green blue} {
 	# Unix doesn't need the '.0' but Windows does...
      set max [expr {max($red,$green,$blue)}].0
      set min [expr {min($red,$green,$blue)}].0
      
      set range [expr $max-$min]
      if {$max == 0} {
	set sat 0
      } else {
	set sat [expr {($max-$min)/$max}]
      }
      if {$sat == 0} {
	set hue 0
      } else {
	set rc [expr {($max - $red)/$range}]
	set gc [expr {($max - $green)/$range}]
	set bc [expr {($max - $blue)/$range}]
	if {$red == $max} {
	  set hue [expr {.166667*($bc - $gc)}]
	} else {
	  if {$green == $max} {
	    set hue [expr {.166667*(2 + $rc - $bc)}]
	  } else {
	    set hue [expr {.166667*(4 + $gc - $rc)}]
	  }
	}
	if {$hue < 0.0} {
	  set hue [expr $hue + 1.0]
	}
      }
      return [list $hue $sat [expr {$max/65535}]]
    }

    # The procedure below converts an HSB value to RGB. It takes hue, saturation,
    # and value components (floating-point, 0-1.0) as arguments, and returns a
    # list containing RGB components (integers, 0-65535) as result.  The code
    # here is a copy of the code on page 616 of "Fundamentals of Interactive
    # Computer Graphics" by Foley and Van Dam.

    proc hsbToRgb {hue sat value} {
      set v [format %.0f [expr 65535.0*$value]]
      if {$sat == 0} {
	return "$v $v $v"
      } else {
	set hue [expr $hue*6.0]
	if {$hue >= 6.0} {
	  set hue 0.0
	}
	scan $hue. %d i
	set f [expr $hue-$i]
	set p [format %.0f [expr {65535.0*$value*(1 - $sat)}]]
	set q [format %.0f [expr {65535.0*$value*(1 - ($sat*$f))}]]
	set t [format %.0f [expr {65535.0*$value*(1 - ($sat*(1 - $f)))}]]
	case $i \
	    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"}
	error "i value $i is out of range"
      }
    }

    # The procedure below is invoked when the "Update" button is pressed,
    # and whenever the color changes if update mode is enabled.  It
    # propagates color information as determined by the command in the
    # Command entry.

    proc doUpdate {{cname {}}} {
      variable color
      variable autoUpdate
      variable red
      variable green
      variable blue
      variable w
      variable nearColorTimer
      # on slower machines the setNearColors code is very slow so...
      # since it only sets up a listbox we will only do it after
      # a second or so has passed so draging the sliders will not
      # get bogged down...
      if {[info exists [namespace current]::nearColorTimer]} {
	after cancel $nearColorTimer
      }
      if {$cname != {} } {
	set color $cname
      } else {
	set color [format "#%04x%04x%04x" $red $green $blue]
      }
      set nearColorTimer [after 500 [namespace code {setNearColors 1}]]
      $w.swatch config -bg $color
      $w.value config  -background $color\
	  -foreground [textColorFor $color]
      if {$autoUpdate == 1 } {
	manUpdate
      }
      update idletasks
     }

    proc manUpdate {} {
      variable color
      variable command
      variable colorOnInput
      variable w
      set newCmd $command
      regsub -all %% $command $color newCmd
      eval $newCmd
      # recover from possible changes by the update code
      foreach window {$w.names $w.text} {
	catch "$window config -background white -foreground black"
      }
      $w.ivalue config -background $colorOnInput \
	  -foreground [textColorFor $colorOnInput]
    }
    # Updates 'color' name if exact, else number
    proc setNearColors {{late 0}} {
      variable red
      variable green
      variable blue
      variable w
      variable gray
      variable colorWeights
      global colorList-1-1-$gray
      variable color
      variable autoUpdate

      set N 50
      lassign $colorWeights redWeight greenWeight
      if {![info exists colorList-1-1-$gray]} {return}
      foreach colorName [set colorList-1-1-$gray] {
	lassign [lindex $colorName 1] cred cgreen cblue
	lappend clist [expr { pow($cred - $red,2) * $redWeight + 
			      pow($cgreen - $green,2) *$greenWeight + 
			      pow($cblue - $blue,2)}]
      }
      $w.text delete 0.0 end
      set indx [lsort -indices -real $clist]
      for {set i 0} {$i < $N} {incr i} {
	set colorname [lindex [set colorList-1-1-$gray] [lindex $indx $i] 0]
	$w.text insert end \t $colorname "$colorname\n" a$colorname
	$w.text tag bind $colorname <1> \
	    [namespace code [list tc_loadNamedColor $colorname]]
	$w.text tag bind a$colorname <1> \
	    [namespace code [list tc_loadNamedColor $colorname]]
	$w.text tag configure $colorname -background $colorname
      }
      if {!$late} {
	set color [format "#%04x%04x%04x" $red $green $blue]
      }	
      #puts "[lindex $clist [lindex $indx 0]] >$color<"
      if {[lindex $clist [lindex $indx 0]] == 0.0 && \
	      [string range $color 0 0] == "#"} {
	#puts "setting color"
	set color [lindex [set colorList-1-1-$gray] [lindex $indx 0] 0]
	$w.value config  -background $color\
	    -foreground [textColorFor $color]
	if {$autoUpdate != 0 } {
	  manUpdate
	}
	update idletasks
      }
      
    }
    proc ExitColor { zip} {
      variable color
      variable w
      variable whichColor
      variable colorOnInput

      if { $zip == 1 } {
	set color $colorOnInput
      }
      manUpdate
	catch "destroy  $w"
	# don't auto load it just to cancel it.
	if {[info procs balloon_help::balloonhelp_cancel] != {}} {
	    ::balloon_help::balloonhelp_cancel
	}
      catch "namespace delete ::$whichColor"
      #      puts "exiting ce $whichColor"
    }
  }
  # Internally we want gray to be the string we want to reject so here
  # we flip gray to grey. This also insures we get only one or the other
  set ${name}::gray [expr {$gray == "grey" ? "gray" : "grey"}]
  namespace eval $name "DoColorEditor {$dothis} $start"
  return .$name
}

