#!/usr/local/bin/wish -f

# xcmsetup version 1.1 by James F. Carter <jimc@math.ucla.edu>, 95.05.26
# Current master URL (through WWW): ftp://www.math.ucla.edu/~jimc/xcolor

# Compatibility warning:  This program works on tk 3.6 (patchlevel 3.6p1; 
# probably but not tested: 206).  The following problems are seen with tk4.0:

# Probs: 
# After loading a particular dcc file, part 1 scale max was 2588, s.b. about 50.
# Transition from part 3 to part 4, when trying to delete the tigers, the
#	widget commands (for what part?) were supposed to be renamed before
#	being deleted, but did not exist for the rename.  Probably deleted by 
#	reference in 4.0 when something else happens.  
#	**FIXED** (conditionalized).

# Using this program you can create the Device Color Characterization File
# for the X Window System, which is read by xcmsdb to set the color
# characterization properties of the X server as specified in ICCCM section 7.
# Please read the on-screen instructions for how to make the settings.
# You need tcl/tk to run this program (tk v3.6, may or may not work on 4.0).
# You also need:
#	Eiseman, L and L. Herbert, The Pantone Book of Color, Abrams (NY), 
#	1990, ISBN 0-8109-3711-5.  
# The book may be purchased in art stores.  Pantone is a registered trademark 
# of Pantone Inc.

# Usage: xcmsetup [filename] [standard X args]
# Normally you omit the filename.  The program will ask for one interactively;
# click on "Defaults" to get default values.  If you already have a *.dcc file
# (created by this program) and wish to read it, alter the settings and rewrite
# it, give its name on the command line or the load dialog.  This program 
# requires a particular arrangement of intensities in the intensity profile; 
# other dcc files cannot be read.

# With the "Save" button you can save at any time (the program always asks 
# for the filename).  Saving is automatic on exit, and the program will ask 
# if it doesn't have a filename yet.  The conventional extension for the
# file is ".dcc".

# This program is copyright (c) 1995 by James F. Carter.  
# Permission to use, copy, modify, distribute, and sell this
# software and its documentation for any purpose is hereby granted
# without fee, provided that the above copyright notice appear in all
# copies and that both that copyright notice and this permission notice
# appear in supporting documentation. James F. Carter makes no
# representations about the suitability of this software for any purpose.
# It is provided "as is" without express or implied warranty.


# Performance: 
#   1.	Two executions on the same machine under different lighting conditions
#	gave intensity profiles equal to +-1% (i.e. 2 out of 255), correcting
#	for the different black levels found.
#   2.  The black level was consistently higher (3 to 8 steps) when set in
#	"daylight" than at night.  It is better to do the black level at night.
#   3.	Comparison of RGBtoXYZ results was spoiled by a bug.
#   4.	A teenaged alpha tester doing a rush job was OK on the black level,
#	but was quite badly off in the intensity profile and the color matrix.
#	*Read* the instructions!  Possibly the improved scales in step 3 will
#	prevent some errors.  
#   5.  Gamma on different monitors: 1.85* 2.00* 1.70 R1.77/G2.00/B1.87 
#       1.33 (!?)  1.56*    * means black couldn't be set high enough.  
#	    RGBi = ((RGB-offset)/(max-offset))^gamma
#	A gamma exponent of 2.35 is expected for CRT beam current vs. grid
#	voltage; it would appear that either the X-server or the hardware is 
#	doing impromptu gamma correction on RGB components -- in one case, 
#	different for different colors.
#   6.	I have not yet validated whether the X-server faithfully follows the
#	data in the .dcc file.  (Maybe the RGBtoXYZ matrix is transposed, 
#	maybe this, maybe that...)

set version 1.0
set gamma 1.7			;#For default tables, rgbi = rgb^gamma.

# ===== Change tk 4.0b3 default values that mess up widget layouts.
# Sorry to mess up the nice Motif compliance, but wide white borders really
# screw up color adjustments.

option add *highlightThickness 0 widgetDefault
option add *padX 1 widgetDefault
option add *padY 1 widgetDefault

# ===== Math subroutines

# Generalized linear interpolation.  Assumes table length is $nip.  Result
# is floating point.  $x = argument (in $from); from and to are array names.
proc interpolate {x from to} {
    upvar $from X
    upvar $to Y
    global nip
		#Binary search to find table segment, j to j+1.  Note, table 
		#decreases.
    set n2 [expr $nip-2]
    set dn [expr $nip/2]
    set j $dn
    while {$dn > 1} {
	set dn [expr {($dn+1)/2}]
	if {$x > $X($j)} {
	    incr j -$dn
	    if {$j < 0} {set j 0}
	} elseif {$x < $X([expr $j+1])} {
	    incr j $dn
	    if {$j > $n2} {set j $n2}
	} else break
    }
    set j1 [expr $j+1]
    set res [expr {$Y($j)+($Y($j1)-$Y($j))*(double($x)-$X($j))/($X($j1)-$X($j))}]
    return $res
}

# Predict the RGB value of step j+k for color C (in r g b), extrapolating power 
# law from a known value at step j.  j may be 0 but not -1.
proc extrapolate {C j k} {
    global nip ipr ipg ipb gamma
    set max [set ip${C}(0)]
    set z [set ip${C}([expr $nip-1])]
    if {$j <= 0} {
	set res [expr {round(($max-$z)*pow(2.0/3.0,$k/$gamma))}]
	return $res
    } else {
	set v1 [expr [set ip${C}($j)]-$z]
	incr j -1
	set v2 [expr [set ip${C}($j)]-$z]
	set v [expr {round($v1*pow(double($v1)/$v2,$k))}]
	if {$v > $v1-$k} {set v [expr $v1-$k]}
	if {$v <= 0} {set v 1}
	set res [expr $v+$z]
	return $res
    }
}

# DEBUG print out a matrix.
proc matout {title mtxa} {
    upvar $mtxa mtx
    puts $title
    foreach i {0 1 2} {
	set line {}
	foreach j {0 1 2} {
	    append line [format "%1d%1d  %8.5f  " $i $j $mtx($i$j)]
	}
	puts $line
    }
}

# Invert a 3x3 matrix using Kramer's rule, brute force.  Finesse in this task
# is useless in tcl.  inv = inverse of mtx.
proc invert {inva mtxa} {
    upvar $inva inv
    upvar $mtxa mtx
#    matout "Original matrix" mtx
    set det [expr {$mtx(00)*$mtx(11)*$mtx(22) + $mtx(01)*$mtx(12)*$mtx(20) + 
		    $mtx(02)*$mtx(10)*$mtx(21) - $mtx(00)*$mtx(12)*$mtx(21) - 
		    $mtx(01)*$mtx(10)*$mtx(22) - $mtx(02)*$mtx(11)*$mtx(20)}]
    set inv(00) [expr {($mtx(11)*$mtx(22) - $mtx(12)*$mtx(21))/$det}]
    set inv(01) [expr {($mtx(21)*$mtx(02) - $mtx(22)*$mtx(01))/$det}]
    set inv(02) [expr {($mtx(01)*$mtx(12) - $mtx(02)*$mtx(11))/$det}]
    set inv(10) [expr {($mtx(12)*$mtx(20) - $mtx(10)*$mtx(22))/$det}]
    set inv(11) [expr {($mtx(22)*$mtx(00) - $mtx(20)*$mtx(02))/$det}]
    set inv(12) [expr {($mtx(02)*$mtx(10) - $mtx(00)*$mtx(12))/$det}]
    set inv(20) [expr {($mtx(10)*$mtx(21) - $mtx(11)*$mtx(20))/$det}]
    set inv(21) [expr {($mtx(20)*$mtx(01) - $mtx(21)*$mtx(00))/$det}]
    set inv(22) [expr {($mtx(00)*$mtx(11) - $mtx(01)*$mtx(10))/$det}]
#   matout "Its inverse" inv
}

# Matrix multiplication.  p = a * b.  All the args are names, not values.
proc matmpy {pa aa ba} {
    upvar $pa p
    upvar $aa a
    upvar $ba b
    set p(00) [expr {$a(00)*$b(00)+$a(01)*$b(10)+$a(02)*$b(20)}]
    set p(01) [expr {$a(00)*$b(01)+$a(01)*$b(11)+$a(02)*$b(21)}]
    set p(02) [expr {$a(00)*$b(02)+$a(01)*$b(12)+$a(02)*$b(22)}]
    set p(10) [expr {$a(10)*$b(00)+$a(11)*$b(10)+$a(12)*$b(20)}]
    set p(11) [expr {$a(10)*$b(01)+$a(11)*$b(11)+$a(12)*$b(21)}]
    set p(12) [expr {$a(10)*$b(02)+$a(11)*$b(12)+$a(12)*$b(22)}]
    set p(20) [expr {$a(20)*$b(00)+$a(21)*$b(10)+$a(22)*$b(20)}]
    set p(21) [expr {$a(20)*$b(01)+$a(21)*$b(11)+$a(22)*$b(21)}]
    set p(22) [expr {$a(20)*$b(02)+$a(21)*$b(12)+$a(22)*$b(22)}]
}

# ===== Color space conversions

# Gamma correction, rgbi to rgb using theoretical curve with exponent of 2.35.
# rawmax = raw RGB corresponding to $inten = 1.0.  Return value is the RGB
# to give that intensity. The intensity profile of a "typical" CRT can be
# modelled as 
#   rgbi = ((rgb - origin)/rawmax)^2.35
proc gamma {rawmax origin inten} {
    global gamma
    return [expr {int(($rawmax-$origin)*exp(log($inten)/$gamma))+$origin}]
}

# rgb to rgbi by interpolation.  Input and result are 3 component lists
# in decimal.
proc rgb2rgbi {rgb} {
    global ipi ipr ipg ipb
    set j 0
    foreach C {r g b} {
	lappend rgbi [interpolate [lindex $rgb $j] ip${C} ipi]
	incr j
    }
    return $rgbi
}

# rgbi to rgb by interpolation.  Input and result are 3 component lists
# in decimal.  Output rgb is rounded to an integer.
proc rgbi2rgb {rgbi} {
    global ipi ipr ipg ipb
    set j 0
    foreach C {r g b} {
	lappend rgb [expr {round([interpolate [lindex $rgbi $j] ipi ip${C}])}]
	incr j
    }
    return $rgb
}

# ======= Default color configuration

# Set default color info.  
# A tiger widget (see below) has midcolor stripes alternating with a mixture
# of highcolor and lowcolor.  What proportions should be used?  The entries
# of the intensity profile are in a geometric progression; what should the
# ratio be?  
# Let R = ipi(j)/ipi(j-1), and ipi(0) = 1, so ipi(j) = R^j.
# Let A = fraction of lowcolor (ipr(j+1)) in the tiger, and 1-A for 
# highcolor (ipr(j-1)).  Midcolor (ipr(j)) matches their sum.  So:
#	R = AR^2 + 1 - A
#	A = (R-1)/(R^2 - 1) = 1/(R+1)   or   R = 1/A - 1
# It's necessary that R and A both be in (0..1), so A in (.5..1).  For 
# technical reasons A must be a ratio of fairly small integers (determined by
# count of dots in the bitmap).
#   A   1/2  2/3  3/4  3/5  4/7  5/7  etc.
#   R   1    1/2  1/3  2/3  3/4  2/5
# R = 1/2 or less gives jumps that are too big, since a more or less 
# exponential function is being approximated.  R = 2/3 is about right, so
# A = 3/5 -- 3 background dots for every 2 foreground dots.  
# Empirically the darkest color that can be adjusted by this procedure is 
# around 0.02.  (2/3)^10 = 0.017, so nip = 10+2 = 12.

# A recent review of monitors in PC Magazine found that for checkerboards
# of 1 pixel size at 1024x768 on 17" monitors, the (horizontal) modulation 
# transfer function ranged from 31% to 55%.  With the 2 pixel and 3 pixel
# patterns used in the bitmap for this program, and with a color difference of
# gamma(R^2) rather than 0 to max, the beam currents reaching the screen should
# be much closer to the ideal values reflected in the raw RGB numbers.

proc setdefault {} {
		#Subscripts in ipi etc. run from 0 to $nip-1, with subscript $i
		#referring to rgbi = R^$i, but $nip-1 for the zero point.
    global nip		;#Number of steps in intensity profile
    global ipi		;#rgbi values in intensity profile
    global ipr ipg ipb	;#Raw RGB values in intensity profile, per color
    global digits	;#Number of hex digits in RGB components
    global rmax		;#Upper bound on raw RGB values, should be 16^digits.
    global mtx		;#RGBi to CIEXYZ matrix.  Subscr: mtx(xyz, rgb)
    global stdnames	;#Names of the standard colors.
    global stdxyz	;#CIEXYZ coords of 3 standard colors.  Subscripts:
			;#	stdxyz(xyz, pan) where pan = which Pantone color
    global stdrgb	;#Raw RGB for these colors as set by the user.  Subscr:
			;#	stdrgb(rgb, pan)
    global stdrgbset	;#Status of stdrgb, same codes as $changed
    global changed	;#0 = dcc data unchanged.  1 = changed.  2 = default
			;#data, OK to save, but readfile overwrites it.
    global bitmap	;#Name of bitmap file for tiger stripes.

    set changed 2
    set stdrgbset 2
    set digits 2
    set rmax [expr {round(pow(16,$digits))}]
    set nip 12
    set n [expr $nip-1]
		#Set black and white levels to obvious defaults.
    set ipi(0) 1.0; set ipi($n) 0.0
    foreach c {r g b} {	
	set ip${c}(0) [expr $rmax-1]
	set ip${c}($n) 0
    }
		#Set intensity profile using power law gamma correction.
    set R [expr 2.0/3.0]
    for {set i 1} {$i < $n} {incr i} {
	set ipi($i) [expr {$ipi([expr $i-1])*$R}]
		#ipraw = rmax * ipi($i)^(1/2.35)
	set ipraw [gamma $rmax 0 $ipi($i)]	;#Power law gamma correction
	foreach c {r g b} {
	    set ip${c}($i) $ipraw
	}
    }
    

		# The default matrix values are taken from sample1.dcc 
		# distributed as a sample file with xcmsdb source.  This file
		# describes the Tektronix 4300 monitor with Sony CRT.
		
		# Comparing the rows with authentic CIEXYZ values, row 0 
		# (00 01 02) seems to be white, row 1 is green, and row 2 is 
		# blue, which is not what I would expect for CIEXYZ.  
		# Reference for CIEXYZ values:
		# Weast, Robert C. (ed.), "Handbook of Chemistry and Physics" 
		# (63rd ed), Chem. Rubber Publ. Co, 1982.  Page E-403, 
		# "Colorimetry",  which in turn is summarizing 
		# Judd, Jour. Optical Society of America, v. 23 p. 359 (1933),
		# Who apparently is summarizing the CIE 1931 standard.
    foreach kv {   {00 0.38106} {01 0.32026} {02 0.24835}
		   {10 0.20730} {11 0.68055} {12 0.11216}
		   {20 0.02134} {21 0.14297} {22 1.24173}} {
	set mtx([lindex $kv 0]) [lindex $kv 1]
    }

		#The three standard colors from the Pantone Book of Colors:
    set stdnames {{Georgia Peach 16-1641(p55)}\
		  {Grass Green 15-6437(p120)}\
		  {Bonnie Blue 16-4134(p91)}}

		# Their RGBi components as viewed on a Nokia 447X (Sony 
		# Trinitron CRT). Subscr: stdrgbi(rgbi, pan) (colors in columns)
    foreach kv {   {00 0.739} {01 0.190} {02 0.075}
		   {10 0.093} {11 0.362} {12 0.190}
		   {20 0.044} {21 0.067} {22 0.366}} {
	set stdrgbi([lindex $kv 0]) [lindex $kv 1]
    }

		# Their CIEXYZ components.
		# Here's the procedure used to obtain this data:  Calibrate
		# the intensity profile of a Nokia 447X (Sony Trinitron CRT).
		# Determine RGB for these colors.  Transform to RGBi.  Use
		# the default matrix above to map to CIEXYZ.  The "right" way
		# to do it is either to measure the Pantone swatches 
		# photometrically, or to get the Pantone people to tell us
		# what the official values are.
    matmpy stdxyz mtx stdrgbi
		# Initialize the standard colors' RGB.
    setstdrgb
		#Create the tiger stripe bitmap file.
    set bitmap /tmp/xcmsetup.bmp.[pid]
    set fd [open $bitmap w]
    puts $fd \
{#define xcolorbar_width 10
#define xcolorbar_height 10
static unsigned char xcolorbar_bits[] = {
   0x8c, 0x01, 0x31, 0x02, 0x18, 0x03, 0xc6, 0x00, 0x63, 0x00, 0x18, 0x03,
   0x31, 0x02, 0xc6, 0x00, 0x8c, 0x01, 0x63, 0x00};
}
    close $fd
}

# Set the standard colors' RGB values using the current intensity profile.
proc setstdrgb {} {
    global stdrgb stdrgbset mtx stdxyz ipi ipr ipg ipb
		# Suppress this routine if user has adjusted the RGB's
    if {$stdrgbset == 1} return
		# Supposing that CIEXYZ was input data, solve for stdrgbi and
		# map this to stdrgb, as initial values for part 4.
    invert mtxv mtx
    matmpy rgbi mtxv stdxyz
    foreach j {0 1 2} {
	set k 0
	foreach C {r g b} {
	    set stdrgb($k$j) \
		[expr {round([interpolate $rgbi($k$j) ipi ip$C])}]
	    incr k
	}
    }
#   puts "setstdrgb matrices:"
#   matout "RGBtoXYZ" mtx
#   matout "XYZ of standard colors" stdxyz
#   matout "RGBi of standard colors" rgbi
#   matout "RGB of standard colors" stdrgb
}

# Convert standard colors' RGB values (in stdrgb) to RGBi by interpolation.
# Result is left in rgbia (name of array).
proc getstdrgbi {rgbia} {
    upvar $rgbia rgbi
    global stdrgb ipi ipr ipg ipb
    foreach j {0 1 2} {
	set k 0
	foreach C {r g b} {
	    set rgbi($k$j) [interpolate $stdrgb($k$j) ip$C ipi]
	    incr k
	}
    }
}

# Append widget's default arguments.  $argl is the name of a flat argument 
# list, e.g. {-width 99 -height 20}.  $dflts is the value of a list of 
# key-value pairs, e.g. {{-width 99} {-height 20}}.  If a default key is
# missing from argl, the key and value are appended to argl.
proc widefault {argl dflts} {
    upvar $argl argz
    foreach kv $dflts {
	set key [lindex $kv 0]
	if {[lsearch $argz $key] < 0} {
	    lappend argz $key [lindex $kv 1] 
	}
    }
}

# ===== Tiger widget
# The widget consists of 6 vertical stripes, alternately solid and stippled,
# and an optional scale widget below them.  The widget procedure is identical
# to "scale", i.e. get, set value, configure (args...).  The only option that
# has a default is -stipple, though omitting some of the scale options causes
# features to be omitted.  Recognized options:
#    -width		Width  of widget, as for frame.
#    -height		Height of widget.
#    -stripes		Number of stripe pairs (stippled-solid)
#    -stipple		Bitmap in stippled stripes (default gray50).
#    -midcolor		Color of solid colored stripes.
#    -highcolor		Foreground color of stippled stripes.
#    -lowcolor		Background color of stippled stripes.
#    -scale		Present if you want the scale.  Value should be 1.  
#			Must be given on the initial call, not to $wid 
#			configure.  The scale value is always shown.
#    -command		Scale command, executed when scale value changes.
#			Called with the scale value appended.  
#    -foreground	Color of scale foreground (annotation)
#    -from		Lower limit of scale.
#    -label		Label above scale.
#    -tickinterval	Interval of tick marks on scale.
#    -to		Upper limit of scale.

proc tiger {wid args} {
    global tiger$wid
    set tiger${wid}(-width)  -1		;#Parms used when they change; ensure
    set tiger${wid}(-height) -1		;#an init value that looks different.
    set tiger${wid}(-stripes) -1
    set tiger${wid}(-scale)  0		;#No lie, there is no scale now.
    frame $wid -background black
    rename $wid $wid.f			;#Preserve the frame's widget proc
    pack propagate $wid 0
    bind $wid <Destroy> "tiger_destr $wid"
    canvas $wid.c
    bind $wid.c <Configure> "tiger_stripes $wid"
    pack $wid.c -in $wid -side top -fill both -expand 1
    proc $wid {args} "return \[tiger_widget $wid \$args\]"
		#Append default values if not given explicitly.
    widefault args {{-stipple gray50} {-lowcolor black} {-highcolor white} \
			{-midcolor gray} {-stripes 3}}
    tiger_config $wid $args
    return $wid
}

proc tiger_destr {wid} {
    global tiger$wid
    unset tiger$wid
    if {[info commands $wid.f] != {}} {rename $wid.f {}}
}

# The config arguments have to be seen in a certain order so the stripes and
# scale get realized before aspects of them get set.  Lower numbers are
# seen first.
foreach kv {{-width 2} {-height 2} {-stripes 3} {-digits 0}
	    {-stipple 3} {-midcolor 3} {-highcolor 3} {-lowcolor 3} {-color 3}
	    {-scale 0} {-orient 0} {-command 1} 
	    {-foreground 1} {-from 1} {-label 1} {-tickinterval 1} {-to 1}} {
    set tiger_order([lindex $kv 0]) [lindex $kv 1]
}
proc tiger_sort {A B} {
    global tiger_order
    return [expr {$tiger_order([lindex $A 0])-$tiger_order([lindex $B 0])}]
}

# Convert linear list of arguments into list of {-key value} pairs, sorted
# into tiger_order.
proc tiger_pair {argl} {
    set imax [llength $argl]
    for {set i 0} {$i < $imax} {incr i 2} {
	lappend argp [lrange $argl $i [expr $i+1]]
    }
    return [lsort -command tiger_sort $argp]
}

# Tiger widget configurator procedure.  
proc tiger_config {wid argl} {
    global tiger$wid
		#Pack the options into {-key value} pairs sorted in tiger_order.
    set argp [tiger_pair $argl]
		#Put each option on a list for the object it affects.
		#The scale is created here if necessary.
    set conff {}		;#Config options for the frame.
    set confc {}		;#Config options for canvas
    set confs {}		;#Config options for scale
    set confB {}; set confF {}	;#Options for foreground and background stripes
    set newstripes 0		;#1 if new stripes are needed.
    foreach kv $argp {
	set option [lindex $kv 0]
	set val [lindex $kv 1]
	switch -- $option {
	    -width -
	    -height {
		lappend conff $option $val
		set tiger${wid}($option) $val
		set newstripes 1
	    }
	    -stripes {
		set tiger${wid}($option) $val
		set newstripes 1
	    }
	    -lowcolor {
		lappend confB -fill $val
		set tiger${wid}($option) $val
	    }
	    -highcolor {
		lappend confF -fill $val
		set tiger${wid}($option) $val
	    }
	    -stipple {
		lappend confF $option $val
		set tiger${wid}($option) $val
	    }
	    -midcolor {
		lappend confc -background $val
		lappend confs -background $val
		set tiger${wid}($option) $val
	    }
	    -command -
	    -foreground -
	    -from -
	    -label -
	    -tickinterval -
	    -to {
		lappend confs $option $val
	    }
	    -scale {
		set oscale [set tiger${wid}(-scale)]
		if {$val && !$oscale} {
		    scale $wid.s -showvalue 1 -orient horizontal
		    pack  $wid.s -in $wid -side bottom -fill x -expand 1 \
			-before $wid.c
		} elseif {!$val && $oscale} {
		    destroy $wid.s
		}
		set tiger${wid}(-scale) $val
	    }
	    default {
		error "Tiger: invalid option $option $val"
	    }
	}
    }
		#Apply options to the frame, the canvas and the scale.
    foreach z {f c s} {
	if {[set conf$z] != {} && ("$z" != "s" || [set tiger${wid}(-scale)])} {
	    eval [concat $wid.$z configure [set conf$z]]
	}
    }
		#If the size of the stripes has changed, remake the stripes.
		#Otherwise reconfigure existing stripes (if stripe relevant
		#parameters are specified). 
    if {$newstripes} {
	tiger_stripes $wid
    } else {
		#Apply options to the stripes.
	foreach tag {B F} {
	    if {[set conf$tag] != {}} {
		eval [concat $wid.c itemconfigure $tag [set conf$tag]]
	    }
	}
    }
    return {}
}

# Set up the tiger stripes.  Call on initial creation or resize.
proc tiger_stripes {wid} {
    global tiger$wid
    set width [winfo width $wid.c]
    if {$width <= 1} return		;#Forget it if canvas not configured yet
    set height [winfo height $wid.c]
    set confB "-fill [set tiger${wid}(-lowcolor)]"
    set confF "-fill [set tiger${wid}(-lowcolor)] \
		-stipple [set tiger${wid}(-stipple)]"
    $wid.c delete all
    set ws [expr {int(0.5*$width/[set tiger${wid}(-stripes)])}]
    for {set j 0} {$j < [set tiger${wid}(-stripes)]} {incr j} {
	set x [expr {2*$j*$ws}]
	foreach tag {B F} {
	    eval [concat $wid.c create rectangle \
		$x 0 [expr {$x+$ws}] $height -tags $tag {-outline {}} \
		[set conf$tag]]
	}
    }
}

# The tiger widget procedure.  Configure is recognized, and slider operations
# are passed through.
proc tiger_widget {wid argl} {
    set opcode [lindex $argl 0]
    switch $opcode {
	configure {
	    return [tiger_config $wid [lrange $argl 1 end]]
	}
	get {
	    return [eval [concat $wid.s $argl]]
	}
	set {
	    return [eval [concat $wid.s $argl]]
	}
	default {
	    error "Tiger: invalid operation $opcode"
	}
    }
}

# ==== Quad Tiger
# The Quad Tiger is a vertical set of four tigers which are red, green, blue, 
# gray.  The colored ones have sliders.  Widget commands:
#	$wid configure (args...) -- the usual.
#	$wid midcolor {r g b} -- Sets the red tiger's midcolor to rgb:r/0/0 and
#		analogously for the other colors, and for high and low color.
#		The numbers are in decimal.  
#	#wid set {r g b} -- Sets the respective sliders to those numbers.
#	$wid get xxx -- xxx may have the values scales, highcolor, midcolor,
#		or lowcolor (no hyphen).  The return value, as a 3 component
#		list for {r g b}, is the scale values or the most recently set 
#		colors in decimal.
# Options:
#    -width		Width  of widget (4 tigers), as for frame.
#    -height		Height of widget.
#    -orient		Vertical or horizontal layout of the 4 tigers.  Default
#			is vertical.
#    -stripes		Number of stripe pairs (stippled-solid)
#    -stipple		Bitmap in stippled stripes (default gray50).
#    -digits		Number of hex digits in each color component. 
#    -midcolor		RGB intensity of solid stripes.  The value is a {r g b}
#			list of decimal numbers.  The red tiger is set to 
#			rgb:val/0/0 and analogously for the others.
#    -highcolor		Foreground color of stippled stripes, as above.
#    -lowcolor		Background color of stippled stripes, as above.
#    -command		Scale command, executed when any of the 3 scale values 
#			changes.  To the command will be appended two arguments,
#			the scale number (0,1,2 for rgb) and the scale value.
#    -foreground	Color of scale foreground (annotation)
#    -from		Lower limit of scale, same for all.
#    -label		Label above scale.  Red, green, blue, gray is prepended.
#    -tickinterval	Interval of tick marks on scale.
#    -to		Upper limit of scale, same for all.

proc quadtiger {wid args} {
    global quadtiger$wid
    foreach cc {-highcolor -midcolor -lowcolor} {
	set quadtiger${wid}($cc) {-1 -1 -1}	;#So initial colors are a change
    }
		#Append defaults if not set explicitly
    widefault args {{-orient vertical}}
    frame $wid -background black
    rename $wid $wid.f			;#Save widget proc of the frame
    proc $wid {args} "return \[quadtiger_widget $wid \$args\]"
    quadtiger_config 1 $wid $args
    bind $wid <Destroy> "quadtiger_destr $wid"
    return $wid
}

proc quadtiger_destr {wid} {
    global quadtiger$wid
    unset quadtiger$wid
    if {[info commands $wid.f] != {}} {rename $wid.f {}}
}

# Quadtiger widget configurator
set quadtiger_swid -1		;#Requested width of a scale.
proc quadtiger_config {create wid argl} {
    global quadtiger$wid quadtiger_swid
		#Pack options into {-key value} pairs in tiger_order.
    set argp [tiger_pair $argl]
		#Separate the options into lists according to what they affect.
    set conff {}		;#Config options for the frame
    set conft {}		;#Config options for all tigers
    set confs {-scale 1}	;#Config options for tigers with scales
    set confw {}		;#Config options for tiger without scale
    set confr {}		;#For setting red-green-blue colors
    set confg {}
    set confb {}
    set repack 0		;#If the tigers need to be (re)packed
    foreach kv $argp {
	set option [lindex $kv 0]
	set val [lindex $kv 1]
	switch -- $option {
	    -width {
		lappend conff $option $val
	    }
	    -height {
		    lappend conff $option $val
	    }
	    -stipple {
		lappend conft -stipple $val
	    }
	    -orient {
		set quadtiger${wid}($option) $val
		set repack 1
	    }
	    -digits {
		set quadtiger${wid}($option) $val
	    }
	    -midcolor -
	    -highcolor -
	    -lowcolor {
		set oval [set quadtiger${wid}($option)]
		set d [set quadtiger${wid}(-digits)]
		set j -1
		foreach f {r g b w} {
		    incr j
		    if {$f == "w"} {
			set zval $val
		    } else {
			if {[lindex $val $j] == [lindex $oval $j]} {continue}
			set zval [lreplace {0 0 0} $j $j [lindex $val $j]]
		    }
		    set color {}
		    foreach v $zval {
			lappend color [format "%0${d}x" $v]
		    }
		    lappend conf$f $option rgb:[join $color /]
		}
		set quadtiger${wid}($option) $val
	    }
	    -command {
		set j 0
		foreach f {r g b} {
		    lappend conf$f -command "$val $j"
		    incr j
		}
	    }
	    -from -
	    -to {
		set j 0
		foreach f {r g b} {
		    lappend conf$f $option [lindex $val $j]
		    incr j
		}
	    }
	    -foreground -
	    -tickinterval {
		lappend confs $option $val
	    }
	    -label {
		set j 0
		foreach f {r g b} {
		    lappend conf$f -label "$val [lindex {Red Green Blue} $j]"
		    incr j
		}
	    }
	    default {
		error "Tiger: invalid option $option $val"
	    }
	}
    }
		#Apply the options to the tigers they pertain to.
		#The tigers are created here if necessary.
    if {$conff != {}} {eval [concat $wid.f configure $conff]}
    foreach f {r g b w} {
	if {$f == "w"} {
	    set options [concat $conft $confw]
	} else {
	    set options [concat $conft $confs [set conf$f]]
	}
	if {$options != {}} {
	    if $create {
		eval [concat tiger $wid.$f $options]
	    } else {
		eval [concat $wid.$f configure $options]
	    }
	}
    }
		#(Re)pack the tigers in their frame.
    if {$repack || $create} {
	pack propagate $wid 0
	set dirn [expr \
	    {([set quadtiger${wid}(-orient)] == "vertical")?"top":"left"}]
	foreach f {r g b w} {
	    pack $wid.$f -in $wid -side $dirn -fill both -expand 1
	}
    }
    return {}
}

# The quadtiger widget procedure.  Configure is recognized, and slider 
# operations are passed through.
proc quadtiger_widget {wid argl} {
    global quadtiger$wid
    set opcode [lindex $argl 0]
    set val [lindex $argl 1]
    switch $opcode {
	configure {
	    return [quadtiger_config 0 $wid [lrange $argl 1 end]]
	}
	get {
	    switch $val {
		scales {
		    return [list [$wid.r get] [$wid.g get] [$wid.b get]]
		}
		lowcolor -
		midcolor -
		highcolor {
		    return [set quadtiger${wid}(-$val)]
		}
	    }
	}
	set {
		#This will cause the -command to be executed.
	    $wid.r set [lindex $val 0]
	    $wid.g set [lindex $val 1]
	    $wid.b set [lindex $val 2]
	    return {}
	}
	default {
	    error "Tiger: invalid operation $opcode"
	}
    }
}

# ===== splotch widget
# The widget consists of a frame to show the color and three scales for RGB.
# Recognized options:
#    -width		Width  of widget, as for frame.
#    -height		Height of widget.
#    -color		Initial color (RGB) of the widget, default gray50.
#    -digits		Number of hex digits in a color component.  Default 2.
#    -label		Name of color.  Default: blank space.
#    -command		Scale command, executed when scale value changes.
#			Called as [$command $c $value] where c = color (0 1 2)
#			and $value = the new scale value.  There's a default.
#    -from		Lower bound of scale values (default 0).
#    -to		Upper bound of scale values (default 16^digits).
#    -foreground	Color of scale foreground (annotation).  Default white.
#    -tickinterval	Interval of tick marks on scale (if any).

proc splotch {wid args} {
    global splotch$wid
    frame $wid -background black
    bind $wid <Destroy> "splotch_destr $wid"
    pack propagate $wid 0
    frame $wid.c
    pack $wid.c -in $wid -side top -fill both -expand 1 -padx 8
    foreach c {2 1 0} {
	scale $wid.$c -orient horizontal \
	    -background [lindex {rgbi:.15/0/0 rgbi:0/.15/0 rgbi:0/0/.15} $c]
	pack  $wid.$c -in $wid -side bottom -fill x
    }
    label $wid.l -background black -relief raised
    pack  $wid.l -in $wid -side bottom -fill x
    rename $wid $wid.f			;#Preserve widget proc of outer frame
    proc $wid {args} "return \[splotch_widget $wid \$args\]"
		#Append default values if not given explicitly.
    widefault args [list {-digits 2} {-color gray50} {-foreground white} \
					"-command \{splotch_cmd $wid\}"]
    splotch_config $wid $args
    return $wid
}

proc splotch_destr {wid} {
    global splotch$wid
    unset splotch$wid
    rename $wid.f {}
}

# Splotch widget configurator procedure.  
proc splotch_config {wid argl} {
    global splotch$wid
		#Pack the options into {-key value} pairs sorted in tiger_order.
    set argp [tiger_pair $argl]
		#Put each option on a list for the object it affects.
		#The scale is created here if necessary.
    set conff {}		;#Config options for outer frame
    set confc {}		;#Config options for color frame
    set confs {}		;#Config options for scales
    set confl {}		;#Config options for label
    set confr {}; set confg {}; set confb {}
    set update 0		;#1 if immediate update is needed (if color set)
    foreach kv $argp {
	set option [lindex $kv 0]
	set val [lindex $kv 1]
	switch -- $option {
	    -width {
		lappend conff $option $val
		set splotch${wid}($option) $val
	    }
	    -height {
		lappend conff $option $val
		set splotch${wid}($option) $val
	    }
	    -color {
		lappend confc -background $val
		set splotch${wid}($option) $val
	    }
	    -label {
		lappend confl -text $val
	    }
	    -command {
		foreach c {0 1 2} {
		    $wid.$c configure -command "$val $c"
		}
	    }
	    -digits {
		set splotch${wid}($option) $val
		lappend confs -to [expr {round(pow(16,$val)-1)}]
	    }
	    -foreground {
		lappend confs $option $val
		lappend confl $option $val
	    }
	    -from -
	    -to {
		set j 0
		foreach C {r g b} {
		    lappend conf${C} $option [lindex $val $j]
		    incr j
		}
	    }
	    -tickinterval {
		lappend confs $option $val
	    }
	    default {
		error "Splotch: invalid option $option $val"
	    }
	}
    }
		#Apply options to the canvas and the scale.
    foreach c {f c l} {
	if {[set conf$c] != {}} {
	    eval [concat $wid.$c configure [set conf$c]]
	}
    }
    if {$confc != {}} {
	eval [concat $wid.c configure $confc]
    }
    set c 0
    foreach C {r g b} {
	if {$confs != {} || [set conf${C}] != {}} {
	    eval [concat $wid.$c configure $confs [set conf${C}]]
	}
	incr c
    }
    return {}
}

# Splotch slider command (default).
proc splotch_cmd {wid c val} {
    global splotch_$wid rmax
    set dig [set splotch${wid}(-digits)]
    foreach c {0 1 2} {
	set t [expr {int($rmax*0.01*[$wid.$c get])}]
	if {$t >= $rmax} {set t [expr $rmax-1]}
	lappend color [format "%0${dig}x" $t]
    }
    $wid.c configure -background rgb:[join $color /]
}

# The splotch widget procedure.  Configure is recognized, and slider operations
# are passed through.
proc splotch_widget {wid argl} {
    set opcode [lindex $argl 0]
    switch $opcode {
	configure {
	    return [splotch_config $wid [lrange $argl 1 end]]
	}
	get {
	    foreach c {0 1 2} {
		lappend res [$wid.$c get]
	    }
	    return $res
	}
	set {
	    set val [lindex $argl 1]
	    foreach c {0 1 2} {
		$wid.$c set [lindex $val $c]
	    }
	}
	default {
	    error "Splotch: invalid operation $opcode"
	}
    }
}

# ===== Steps in calibration process
set gheight 250		;#Global height and width of tigers in part layouts.
set gwidth  500
# The toplevel widget has the following content available to the "parts":
#	$wid.lbl	Label or title for the part.
#	$wid.text	Display the instructions here.
#	$wid.sbar	Scrollbar for sub-parts
#	$wid.tgr	The main widget.  It's a quadtiger in part 1, 2, 3,
#			and something else in part 4.

set gstate {}		;#Class name (e.g. quadtiger) in $wid.tgr
set destructor {}	;#Call this to dispose of a previous part.  Arguments:
			;#{wid lvl}, $wid is toplevel name; $lvl = 1 to destroy
			;#everything, or 0 to just reconfigure.
# Set up the object in the display.  Arguments:
#	part	1,2,3,4 to construct name of destructor.
#	object	Type of object, e.g. quadtiger.
#	parent	Parent widget instance name.
#	wid	Its widget instance name, not including parent part.
#	stdarg	List of arguments to be used when it is created.
#	optarg	List of arguments to be used in creation and reconfiguration.
proc makeobject {part object parent wid stdarg optarg} {
    global gstate destructor
    set wid $parent.$wid
    set wipe [expr {"$object" != "$gstate"}]
    if {$destructor != {}} {eval $destructor $wipe}
    if $wipe {
	eval [concat $object $wid $stdarg $optarg]
	pack $wid -in $parent -side bottom -fill x
	set gstate $object
    } else {
	eval [concat $wid configure $optarg]
    }
    set destructor "part${part}_destr $parent"
}

# Part 0: Introduction
proc part0_cons {wid} {
    $wid.lbl configure -text "Introduction"
    .w.mbar.part0 configure -background white -foreground black
    $wid.text delete 1.0 end
    $wid.text insert insert \
{Using this program you create or alter the Device Color Characterization File\
for the X Window System, to be read by xcmsdb.  Specify the filename,\
conventionally with the extension .dcc, on the command line or enter it\
interactively upon startup.  With this data set up you can specify colors\
in the form rgbi:r/g/b, CIELuv:L/u/v, etc. according to the ICCCM section 7. \
(The coordinates are decimal numbers such as 0.532)

Adjust colors under the lighting conditions in which the monitor will\
actually be used, since your eyes adapt to the ambient lighting. \
If your lighting changes during the day or night you may want to make\
two or three files.

Go through the four\
parts in order, namely setting the black level, the white level, the\
intensity profile, and the color transformation. \
Then save the color file, and exit.

Parts 1 and 4 refer to standard colors from:
Eiseman, L and L. Herbert, The Pantone Book of Color, Abrams (NY), 1990, ISBN\
0-8109-3711-5.  The book may be purchased in art stores. \
Pantone is a registered trademark of Pantone Inc.

This program copyright (c) 1995 by James F. Carter.  }
    global gwidth gheight rmax
    makeobject 0 frame $wid tgr \
	[list -height $gheight ] {-background black}
}

proc part0_destr {wid kill} {
    .w.mbar.part0 configure -background black -foreground white
    if $kill {destroy $wid.tgr}
}

# Part 1: set the black levels.
proc part1_cons {wid} {
    $wid.lbl configure -text "Black Level Adjustment"
    .w.mbar.part1 configure -background white -foreground black
    $wid.text delete 1.0 end
    $wid.text insert insert \
{Set the scales to about 20 and adjust the "brightness" control so you start\
to see light in the rectangles.  Turn the scales down until the light just\
disappears.  Raise brightness and turn the scales down more. \
Make the brightness as high as possible, consistent with all\
three colors being truly black for some scale setting. \
It will help to make the room dark, and to look at the border\
between two rectangles; both should be black, and a visible edge means that\
one (or both) is not black.

If with brightness at max and scales at max you still don't see light,\
go back to the intro and start part 1 over again; it will give you more range. \
Better, have your monitor adjusted by a technician.

Record the digital setting, or mark the knob, or even put tape over it. \
Having the black level match what's in the file is the key to correct\
dark colors.}
    global gwidth gheight rmax nip ipr ipg ipb changed bitmap
    set och $changed
		#Compute upper bound on black level.  Some monitors have an
		#excessive black level; raise limit to compensate.
    set n1 [expr $nip-1]
    set r0 [expr {int(0.2*$rmax)}]
    foreach C {r g b} {
	set t [expr {int(1.5*[set ip${C}($n1)])}]
	if {$r0 < $t} {set r0 $t}
    }
    makeobject 1 quadtiger $wid tgr \
	[list -width $gwidth -height $gheight -orient horizontal -digits 2 \
	    -stipple @$bitmap ] \
	[list -command "part1_cmd $wid.tgr" \
	-from {0 0 0} -to "$r0 $r0 $r0" -foreground white ]
    $wid.tgr set {1 1 1}	;#As it reacts to change, move off dflt values
    set n [expr $nip-1]
    $wid.tgr set "$ipr($n) $ipg($n) $ipb($n)"
    update
    set changed $och
}

proc part1_destr {wid kill} {
    .w.mbar.part1 configure -background black -foreground white
    if $kill {destroy $wid.tgr}
}

# Slider action command for part 1: Black tiger
# wid = tiger widget name, c = color (0 1 2), val = new slider value.
proc part1_cmd {wid c val} {
    global ipi ipr ipg ipb rmax nip changed
    set j [expr $nip-1]
    set C [lindex {r g b} $c]
    set ip${C}($j) $val
    set vval [$wid get scales]
    $wid configure -highcolor $vval -midcolor $vval -lowcolor $vval
    set changed 1
}

# Part 2: Set the maximum light levels.
proc part2_cons {wid} {
    $wid.lbl configure -text "White Level Adjustment"
    .w.mbar.part2 configure -background white -foreground black
    $wid.text delete 1.0 end
    $wid.text insert insert \
{Set the sliders to max and adjust the contrast control so the pattern\
is at a good brightness for your illumination, but not so bright that small
patterns smear out.  The color adjustment (step 4) assumes that the\
gray rectangle matches "Turtledove", Pantone 12-5202 (p158).  Hold the\
book sideways, and about 30 degrees out from the screen, to compare colors.

Then set the sliders so the gray rectangle is truly gray, not tinted. \
Humans can usually make this judgement accurately.  One slider should be\
at max and the others should be slightly reduced.  Values of 220 to 255\
are reasonable.  If they are very unequal, a technician can adjust the\
monitor's color balance.}
    global gwidth gheight rmax ipr ipg ipb changed bitmap
    set och $changed
    set r0 [expr {int(0.75*$rmax)}]
    set r1 [expr $rmax-1]
    makeobject 2 quadtiger $wid tgr \
	[list -width $gwidth -height $gheight -orient horizontal -digits 2 \
	    -stipple @$bitmap ] \
	[list -command "part2_cmd $wid.tgr" \
	-from "$r0 $r0 $r0" -to "$r1 $r1 $r1" -foreground black ]
    $wid.tgr set "$ipr(0) $ipg(0) $ipb(0)"
    update
    set changed $och
}

proc part2_destr {wid kill} {
    .w.mbar.part2 configure -background black -foreground white
    if $kill {destroy $wid.tgr}
}

# Slider action command for part 2: White tiger.
# wid = tiger widget name, c = color (0 1 2), val = new slider value.
# high, mid, low colors are set to the scale value and 2 steps below,
# theoretical gamma correction applied.
proc part2_cmd {wid c val} {
    global ipi ipr ipg ipb rmax nip changed
    set C [lindex {r g b} $c]
    set ip${C}(0) $val
    set vval [$wid get scales]
    set mpy 1.0
    set n [expr $nip-1]
    foreach cl {mc lc} {
	set mpy [expr {$mpy*2.0/3.0}]
	set wval {}
	foreach i {0 1 2} {
	    set C [lindex {r g b} $i]
	    lappend wval [gamma [lindex $vval $i] [set ip${C}($n)] $mpy]
	}
	set $cl $wval
    }
    $wid configure -highcolor $vval -midcolor $mc -lowcolor $lc
    set changed 1
}


# Part 3: Set the intensity profile.
proc part3_cons {wid} {
    .w.mbar.part3 configure -background white -foreground black
    $wid.text delete 1.0 end
    $wid.text insert insert \
{Use the scroll bar above to select the intensity steps. \
Starting with step 1, the brightest, adjust the sliders so the solid and\
textured tiger stripes are equally bright.  If there is a range that seems\
similarly equal, stop at the center of the range.  Ranges are apparent on\
8-bit pseudocolor (IBM PC SVGA) displays.  Make final small\
adjustments so that the gray rectangle is not tinted; you may have to\
compromise between making the rectangle gray and making the stripes equal.

It may help to sit back from the monitor so the texture is less visible.}
    global gwidth gheight rmax part3_step bitmap
    set part3_step 0		;#Adjusting ip${c}(step+1)
    $wid.sbar configure -command "part3_scroll $wid"
    makeobject 3 quadtiger $wid tgr \
	[list -width $gwidth -height $gheight -orient horizontal -digits 2 \
	    -stipple @$bitmap ] \
	[list -command "part3_cmd $wid" -foreground white ]
    part3_scroll $wid 0
}

proc part3_destr {wid kill} {
    $wid.sbar configure -command {}
    $wid.sbar set 1 0 0 0
    .w.mbar.part3 configure -background black -foreground white
    if $kill {destroy $wid.tgr}
}

proc part3_scroll {wid step} {
    global part3_step ipr ipg ipb ipi nip rmax changed
    set och $changed
    set n2 [expr $nip-2]
    if {$step >= $n2} {set step [expr $nip-3]}
    if {$step < 0} {set step 0}
    set part3_step $step
    set j [expr $step+1]; set j2 [expr $step+2]
    set n [expr $nip-1]
    $wid.sbar set $n2 $step $step $step
    $wid.lbl configure -text [format "Intensity Step %2d: %6.4f" $j $ipi($j)]
    foreach C {r g b} {
	set v [set ip${C}($j)]			;#Current profile choice
	set t [set ip${C}($step)]		;#Next higher profile entry
	set z [set ip${C}($n)]			;#Origin
	set u [extrapolate $C $step 2]		;#Next lower, using power law
	set vpr [expr {int($z+0.9*($t-$z)+1)}]	;#Reasonable upper bound
	if {$vpr >= $t} {set vpr [expr $t-1]}	;#Prevent non-monotonic profile
	if {$u > $v || $v > $vpr} {set v [extrapolate $C $step 1]}
	lappend smax $vpr
	lappend sset $v
	lappend smin $u
    }
    $wid.tgr configure -from $smin -to $smax
    $wid.tgr set $sset
		#Bug alert: we delay here until after all scales have been set
		#because that causes part3_cmd to run, setting $changed.  Then
		#afterward, we put $changed back as it was on entry.  But...
		#"update" causes scrollbar to jump twice when you hit
		#the end triangles.  "update idletasks" doesn't mess up the
		#scrollbar and usually gets enough delay, but occasionally
		#$changed is set spuriously afterward.  So let's put in an
		#arbitrary delay and hope...
    update idletasks
    after 200 "set changed $och"
}

# Slider command for intensity profile.  wid = toplevel name; c = which color
# (0 1 2); val = new slider value.  Highcolor is fixed at the previous
# ip${c} value, midcolor is the new slider value, and lowcolor is in
# geometric progression.
proc part3_cmd {wid c val} {
    global part3_step ipr ipg ipb ipi nip rmax changed
    set j0 $part3_step; set j [expr $j0+1]; set j2 [expr $j0+2]
    set n [expr $nip-1]
    set C [lindex {r g b} $c]
    set ip${C}($j) $val
    foreach C {r g b} {
	set h [set ip${C}($j0)]
	lappend hc $h
	set m [set ip${C}($j)]
	lappend mc $m
	set z [set ip${C}($n)]
	if {$h <= $z} {set h [expr $z+1]}
	set l [expr {round(($m-$z)*($m-$z)/double($h-$z))+$z}]
	if {$l >= $h} {set l [expr $h-1]}
	lappend lc $l
    }
    $wid.tgr configure -highcolor $hc -midcolor $mc -lowcolor $lc
    set changed 1
}


# Part 4: Match the standard colors.
proc part4_cons {wid} {
    $wid.lbl configure -text "Color Standards"
    .w.mbar.part4 configure -background white -foreground black
    $wid.text delete 1.0 end
    $wid.text insert insert \
{Hold the Pantone book sideways about 30 degrees out from the screen to
compare colors.  For each of the three colors indicated in the labels,\
adjust the sliders so the screen matches the colors in the book.

Since Pantone is not an open standard, the CIEXYZ coordinates of these\
colors were estimated using the RGBi to XYZ matrix for the Tektronix monitor\
with Sony Trinitron CRT included with the xcmsdb sources, but viewing on a\
Nokia 477X monitor with Sony Trinitron CRT.  They're not photometric quality,\
but a whole lot better than nothing.

When this step is finished, press save, and exit.  Then "xcmsdb filename.dcc"\
to load the color characterization file.

Undocumented feature: If you click mouse button 2 on the Part 4 button,\
the RGBi of the standard colors will be written to standard output. }
    global gwidth gheight digits rmax ipr ipg ipb nip stdrgb stdnames changed
    set och $changed
    makeobject 4 frame $wid tgr \
	[list -height $gheight] {-background black}
    set swid [expr {$gwidth/3}]
    set n1 [expr $nip-1]
    foreach j {0 1 2} {
	set C [lindex {r g b} $j]
	set spl $wid.tgr.$j
	splotch $spl -width $swid -height $gheight -digits $digits \
	    -foreground white -command "part4_cmd $spl $j" \
	    -from "$ipr($n1) $ipg($n1) $ipb($n1)" \
	    -to   "$ipr(0) $ipg(0) $ipb(0)"   \
	    -label [lindex $stdnames $j]
	set color {}
	foreach k {0 1 2} {lappend color $stdrgb($k$j)}
	$spl set $color
	pack $spl -in $wid.tgr -side left -fill x -expand 1
    }
    update
    set changed $och
}

proc part4_destr {wid kill} {
    .w.mbar.part4 configure -background black -foreground white
    if $kill {
	destroy $wid.tgr
    } else {
	foreach j {0 1 2} {destroy $wid.tgr.$j}
    }
}

proc part4_cmd {wid j c val} {
    global nip ipi ipr ipg ipb digits stdrgb changed stdrgbset
    set n  [expr $nip-1]
    set n2 [expr $nip-2]
    set stdrgb($c$j) $val
    set k 0
    foreach C {r g b} {
	set val [$wid.$k get]
	lappend clist [format "%0${digits}x" $val]
	incr k
    }
    set color rgb:[join $clist /]
    $wid.c configure -background $color
    set changed 1
    set stdrgbset 1
}

# Special procedure, click middle mouse on Part4 button.  Show rgbi for
# standard colors (on stdout).  Also gives gamma exponent.  
proc part4_special {} {
    global stdnames nip ipi ipr ipg ipb
    puts "Standard Colors\t\t\tRed\tGreen\tBlue intensity"
    getstdrgbi rgbi
    set j 0
    foreach name $stdnames {	
	set line $name
	foreach k {0 1 2} {
	    append line [format "\t%6.4f" $rgbi($k$j)]
	}
	puts $line
	incr j
    }
		#Fit power law: ((r-z)/(m-z))^gamma = rgbi where z = origin,
		#m = maximum, r = RGB component.
    puts "Channel\tGamma\tOffset"
    set c 0
    foreach C {r g b} {
	set N [expr $nip-1]
	set sx 0; set sy 0; set sxx 0; set sxy 0
	for {set j 0} {$j < $N} {incr j} {
	   set z [set ip${C}($N)]
	   set x [expr {log(double([set ip${C}($j)]-$z)/([set ip${C}(0)]-$z))}]
	   set y [expr {log($ipi($j))}]
	   set sx  [expr {$sx+$x}]
	   set sy  [expr {$sy+$y}]
	   set sxx [expr {$sxx+$x*$x}]
	   set sxy [expr {$sxy+$x*$y}]
	}
	set gamma  [expr {($sx*$sy-$N*$sxy)/($sx*$sx-$N*$sxx)}]
	set offset [expr {($sx*$sxy-$sxx*$sy)/($sx*$sx-$N*$sxx)}]
	puts [format "%s\t%6.4f\t%6.4f" \
	   [lindex {Red Green Blue} $c] $gamma $offset]
	incr c
    }
    incr k
}

# ===== Reading and writing the DCC file

# Get a filename.  It's saved in the global variable $filename.  $labels is
# a list of button names (left to right).  Return value is the index (right
# to left) of which button is pressed.
proc getfilename {title labels} {
    global filename gfn_var
    set gfn_var 0
    frame .gfn
    label .gfn.lbl -text $title
    pack  .gfn.lbl -in .gfn -side top -fill x -expand 1
    entry .gfn.ent -textvariable filename -relief sunken
    pack  .gfn.ent -in .gfn -side top -fill x -expand 1
    bind  .gfn.ent <Return> "set gfn_var 1"
    set j 0
    foreach label $labels {
	set btn .gfn.$j
	button $btn -text $label -command "set gfn_var $j" -relief raised
	pack $btn -in .gfn -side right -expand 1
	incr j
    }
    place .gfn -in .w -x 0 -y 0
    focus .gfn.ent
    tkwait variable gfn_var
    destroy .gfn
    return $gfn_var
}

set filename {}
set headers \
{SCREENDATA_BEGIN	1.1
    NAME		Fill in identifying data
    MODEL		Fill in identifying data
    PART_NUMBER		Fill in manufacturer's part number
    SCREEN_CLASS	VIDEO_RGB
    REVISION		1.0
}

# Write the file.  Arguments: $
#	as	0 -> write silently if the filename is known.  1 -> always ask
#		for a filename.
#	lbl2	Label for the cancel button: Cancel or Lose.
proc writefile {as lbl2} {
    global filename headers nip mtx ipi ipr ipg ipb stdrgb stdxyz \
	changed version digits
		#Are we supposed to be here at all?  If so, get filename
		#and open the file.
    if {! $changed && ! $as} {return 1}
    if {$filename == {} || $as} {
	if {! [getfilename "Save As" "$lbl2 Save"]} {return 1}
    }
    if {[catch "open $filename w" fd]} {
	puts $fd
	return 0
    }
		#Write preliminary info and headers.
    puts $fd "# Device Color Characterization File generated by xcmsetup v$version"
    puts $fd "# Apply by: xcmsdb $filename"
    puts $fd "# This version uses estimated CIEXYZ coordinates for the standard colors."
    puts $fd $headers
		#Given RGB values for the standard colors, and their CIEXYZ
		#values, map to RGBi and compute the transformation matrix
		#from RGBi to CIEXYZ.  Also we need its inverse.
		# stdxyz = mtx * stdrgbi  stdxyz(x,c) = mtx(x,r)*stdrgbi(r,c)
		# mtx = stdxyz * (stdrgbi^-1)
    getstdrgbi stdrgbi		;#Converts global stdrgb, result in stdrgbi.
    invert rgbiv stdrgbi
    matmpy mtx stdxyz rgbiv
    invert XYZtoRGB mtx
		#Write out the colorimetric data (the two matrices).
    puts $fd "COLORIMETRIC_BEGIN"
    upvar #0 mtx RGBtoXYZ
    foreach m {XYZtoRGB RGBtoXYZ} {
	puts $fd "    ${m}_MATRIX_BEGIN"
	foreach i {0 1 2} {
	    set line "\t"
	    foreach j {0 1 2} {
		append line [format " %8.5f" [set ${m}($i$j)]]
	    }
	    puts $fd $line
	}
	puts $fd "    ${m}_MATRIX_END"
    }
    puts $fd "COLORIMETRIC_END\n"
		#Write out the intensity profiles.  RGB is stored internally
		#with an upper bound of 16^$digits; Xlib expects an upper 
		#bound of 2^16 = 16^4.  So RGB has to be rescaled.
    set rawscale [expr {round(pow(16,4-$digits))}]
    puts $fd "INTENSITY_PROFILE_BEGIN    0    3"
    set c 0
    foreach C {r g b} {
	puts $fd "    INTENSITY_TBL_BEGIN\t[lindex {RED GREEN BLUE} $c]\t$nip"
	set j $nip
	while {$j > 0} {
	    incr j -1
	    set raw [expr {$rawscale*[set ip${C}($j)]}]
	    puts $fd "\t$raw\t$ipi($j)"
	}
	puts $fd "    INTENSITY_TBL_END"
	incr c
    }
    puts $fd "INTENSITY_PROFILE_END\nSCREENDATA_END"
    close $fd
    set changed 0
    return 1
}

# Extract and return a section of the data file, between $from and $to (not 
# including them).  Search is case insensitive; I don't know if this is legal.
# If markers are not found, subroutine writes an error message and makes an 
# error return.  
proc extract {dataa from to} {
    global filename
    upvar $dataa data
    if {! [regexp -nocase "${from}(.*)" $data junk section]} {
	error "Can't find $from in $filename"
    }
    if {! [regexp -nocase -indices $to $section ix]} {
	error "Can't find $to in $filename"
    }
    return [string range $section 0 [expr [lindex $ix 0]-1]]
}

# Read a device color characterization file (as written out by this program).
# There are variations in the file which are legal but not readable, and
# files which are readable but not legal.  Too bad.  Example: Can only do
# separate red-green-blue intensity profiles; all must be the same length;
# must have the same rgbi values; and must pertain to the default visual.
proc readfile {} {
    global filename headers nip mtx ipi ipr ipg ipb changed stdrgbset
    if {$changed == 1} {writefile 0 Lose}
    if {$filename == {}} {
	if {! [getfilename "Load File" {Defaults Load}]} return
    }
    set fd [open $filename r]
    set data {}
    while {[gets $fd line] >= 0} {
	if {[regexp "^\[ \t#\]*\$" $line]} continue
	append data $line "\n"
    }
		#Save the headers.
    set headers "SCREENDATA_BEGIN [extract data SCREENDATA_BEGIN COLORIMETRIC_BEGIN]"
    if {! [regexp -nocase SCREEN_CLASS $headers]} {
	append headers "\tSCREEN_CLASS\tVIDEO_RGB\n"
	puts "Warning, $filename lacks SCREEN_CLASS, VIDEO_RGB supplied."
    }
		#Extract transformation matrix
    set mtxa [extract data RGBtoXYZ_MATRIX_BEGIN RGBtoXYZ_MATRIX_END]
    set k 0
    foreach i {0 1 2} {
	foreach j {0 1 2} {
	    set mtx($i$j) [lindex $mtxa $k]
	    incr k
	}
    }
		#Extract the RGB tables.
    set nip 0
    set ic 0
    foreach c {r g b} {
	set color [lindex {RED GREEN BLUE} $ic]
	set tab "INTENSITY_TBL_BEGIN\[ \t\]+$color"
	set table [extract data $tab INTENSITY_TBL_END]
	set j [lindex $table 0]
	set siz [expr {2*$j+1}]		;#Expected number of items in table
	set k [llength $table]
	if {$k != $siz} {
	    error "Intensity profile size for $color is $j but got 2N+1 = $k numbers"
	}
	set m 0
	if {$c == "r"} {		;#Set size and rgbi intensities.
	    set nip $j
	    for {set i [expr $siz-1]} {$i >= 1} {incr i -2} {
		set ipi($m) [lindex $table $i]
		incr m
	    }
	} else {			;#Check size and rgbi intensities.
	    if {$j != $nip} {
		error "Intensity profile size for RED was $nip, $color was $j.  Must be equal."
	    }
	    for {set i [expr $siz-1]} {$i >= 1} {incr i -2} {
		if {$ipi($m) != [lindex $table $i]} {
		    error "Color $color: rgbi intensities must be the same for all colors."
		}
		incr m
	    }
	}
		# Finally save the raw RGB values.
	set m 0
	for {set i [expr $siz-2]} {$i >= 1} {incr i -2} {
	    set ip${c}($m) [lindex $table $i]
	    incr m
	}
	incr ic
    }
    close $fd
    set changed 0
    set stdrgbset 0		;#User provided matrix, recompute standard rgb
    setstdrgb
    return 1
}

proc changebtn {wid args} {
    global changed
    $wid configure -state [expr {$changed?"normal":"disabled"}]
}

proc xc_exit {} {
    global bitmap
    if {[writefile 0 Lose]} {
	exec rm -f $bitmap
	exit
    }
}

proc main {} {
    global changed tk_version
    setdefault
    frame .w -background black
    pack .w -in .
		#Menubar with buttons for each part, save, exit, and label.
    frame .w.mbar
    pack  .w.mbar -in .w -side top -fill x -expand 1
    foreach f {0 1 2 3 4} {
	set btn .w.mbar.part$f
	button $btn \
	    -text [lindex {Intro "Part 1" "Part 2" "Part 3" "Part 4"} $f] \
	    -command "part${f}_cons .w" -background black -foreground white \
	    -state disabled
	pack $btn -in .w.mbar -side left
	lappend btns $btn
    }
    bind .w.mbar.part4 <Button-2> "part4_special"
    button .w.mbar.save -text Save -command "writefile 1 Cancel" \
	-background black -foreground white -state disabled
    trace variable changed w "changebtn .w.mbar.save"
    button .w.mbar.exit -text Exit -command xc_exit \
	-background black -foreground white
    pack .w.mbar.save .w.mbar.exit -in .w.mbar -side left
    label .w.lbl -background black -foreground white
    pack  .w.lbl -in .w.mbar -side right -fill x -expand 1
		#Text area for instructions
    set fg [expr {("$tk_version">="4.0")?"troughcolor":"foreground"}]
    scrollbar .w.sbar -orient horizontal -background black -$fg white
    pack  .w.sbar -in .w -side top -fill x -expand 1
    frame .w.tf
    scrollbar .w.tbar -orient vertical -command ".w.text yview" \
	-background black -$fg white
    pack .w.tbar -in .w.tf -side left -fill y -expand 1
    text  .w.text -height 12 -background black -foreground white \
	-wrap word -yscrollcommand ".w.tbar set"
    pack  .w.text -in .w.tf -side top -fill x -expand 1
    pack  .w.tf -in .w -side top -fill x -expand 1
		#Start by showing the intro.
    part0_cons .w
    update
		#Load the file on the command line (if any).
    global argv filename
    if {$argv != {}} {
	set filename [lindex $argv 0]
    }
    readfile
    foreach btn $btns {
	$btn configure -state normal
    }
}

main