Tom Wekell wrote:

walter harms wrote:

...

Hello list, i was diving into Device Color Characterization of X11, since rgb.txt is dead. good news you can easy add new color names by adding to xcms.txt: <name> rgb:R/G/B Here is an example from O'Reilly (I think):

XCMS_COLORDB_START 0.1 Berry CIEuvY:0.34568/0.45488/0.23013 Port CIEuvY:0.37875/0.45637/0.05117 Straw CIEuvY:0.19325/0.53761/0.85767 Paprika CIEuvY:0.39617/0.51446/0.20947 GrapeFruit CIEuvY:0.19261/0.52793/0.85069 Pool CIEuvY:0.15229/0.48240/0.60646 SkyBlue RGB:7f7f/bfbf/ffff XCMS_COLORDB_END

The last entry is mine, notice the rr/gg/bb format. To test from a konsole: $ export XCMSDB=/path/to/xcms.txt(or alternate file name) $ xterm -bg SkyBlue and it works for me.

<snip>

i have posted a small awk script that translates from rgb.txt into xmcs.txt :) you can save use dez numbers.

...

I tried xcmsdb -query but always got

xcmsdb -query Could not find property XDCCC_LINEAR_RGB_MATRICES Could not find property XDCCC_LINEAR_RGB_CORRECTION

Me too

...

i tried the xcms.txt from Jim Carter (http://www.math.ucla.edu/~jime/xcolor/color.txt) but it did not work, because for the xcmsdb failure his tcl-script xcolor breaks also.

Here I get '404'

Tom wekell

It seems they have removed the page. I have a copy attached. if the (c) ok should that be added to the bug report ? I have also a copy of xcolor attached just in case. re, wh #!/usr/bin/wish -f # xcolor, Copyright (c) 1994, 1995 by James F. Carter (940727, 950521) # Probs: # CIEuvY, CIELab, CIELuv, CIELSH suffer from various overflow problems. # Likely a 0-1 vs 0-100 prob. # Purpose: to view a bitmap with easily adjusted foreground and background # colors, the colors being set and converted in any Xcms colorsystem (and a # few unofficial ones besides). # Requires that your TK be built with X11R5 or X11R6 libraries. (Does not # require cooperation from the server.) Kind of useless on a monochrome # display. # 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. # How to operate it: # Change a color component scale widget or type a value in its entry (and press # return), and the color in the panel will be updated immediately. If the # color is out of range or otherwise rejected, the error indicator will light # up red. # Type a color name from rgb.txt in the Name entry (and press return), and # that color will be displayed. Conversely, left click on the Name button and # the nearest named color to the one currently displayed will be written in # the entry. (Be patient, the search algorithm is slow.) # To change colorsystems, left click on the Colorsystem button for a menu. # Select a colorsystem, and choose whether the translation to RGB will be done # by Xlib or locally by the subroutines in this file. # Exit by pressing the quit button. # Widget Layout: # panel to show bitmap in color. # 2 groups for background and foreground. In each: # Title, error indicator, and colorsystem selector/readout; # 3 units consisting of label (R,G,B), scale widget, entry for value; # Entry for a color name, with a button to find the closest color to # the current numbers, a readout for the ICCCM color code, and a quit # button. # Summary of "features" whereby Xlib's alleged CIE color systems deviate from # the official CIE specs; reference: # Rea, Mark S (ed.), "Lighting Handbook, Reference & Application", # Illuminating Society of North America (N.Y.), 1993, ISBN 0-87995-102-8 # CIEXYZ, each component runs from 0..100 (official) vs. 0..1 (Xlib). # Color conversion check notes. Column headings are: # Sys Color system; # X/L Comparison of Xlib treatment vs. conversion by this program # Next "Next" color system; # Linv Correctness of local sys<->next conversion and its inverse; # Xnext Comparison of xlib treatment of "sys" vs. "next". # Note that conversions will generally be bogus if the coordinates are out of # gamut; Xlib may silently accept coordinates that it cannot convert # successfully. "LSB" = a few errors in the least significant bit. # Sys. X/L Next Linv Xnext # rgb Perfect rgbi LSB 2-3 off at low numbers # rgbi X>L at low nbrs CIEXYZ LSB 2*LSB # CIEXYZ X<L everywhere CIExyY LSB Perfect # CIExyY X>L everywhere -- # CIEuvY Bug 1 CIEXYZ # CIELab # CIELuv # CIELSH # P-n-o-e # Bug 1: For L=25 and L=50 both, when v changes from 28 to 29, Xlib makes a # big jump from green (28) to blue (29) tones. In the range u = 15..18 # (and likely beyond), with v = 28, it jumps alternately from green # to red/magenta. # ===== Revision history (most recent first): # Version 1.2 (951226). Updated for tk 4.0p2. May or may not still work with # tk 3.x. Added fast rgb->name converter. Added simultaneous view of # all color systems. # Version 1.1 (950529). WARNING, not all of the colorsystems could be tested # due to BUGS discovered in Xlib Xcms routines! # Written for tcl/tk 7.3/3.6pl1. Should work with most (?) 3.x but not # 4.0. # ===== Math subroutines # Generalized linear interpolation. Arguments: # x Value in "from" table # from Name of "from" table, of form ${from}($j) with j in 0 .. $N-1 # Can handle increasing or decreasing table. # to Name of "to" table, similar form # N Number of elements in tables. # Return value Corresponding value in "to" table by linear interpolation. # Result is floating point. proc interpolate {x from to N} { upvar $from X upvar $to Y #Binary search to find table segment, j to j+1. set n2 [expr $N-2] ;#Must not let j = $N-1 so j+1 is in the table. set dn [expr $N/2] set j $dn set sign [expr {$X($n2) > $X(0)}] ;#Reverse comparison if table decreases while {$dn > 1} { set dn [expr {($dn+1)/2}] ;#Cannot go below 1 if {($x == $X($j))} { ;#If exactly on boundary break } elseif {($x > $X($j))^$sign} { ;#Target below table(j) so reduce j incr j -$dn if {$j < 0} {set j 0} } elseif {($x < $X([expr $j+1]))^$sign} { ;#Target above table(j+1) incr j $dn if {$j > $n2} {set j $n2} } else break ;#Target in interval (j, j+1) } set j1 [expr $j+1] #Linear interpolation set denom [expr {$X($j1)-$X($j)}] if {$denom == 0} {set denom 1} set res \ [expr {$Y($j)+($Y($j1)-$Y($j))*(double($x)-$X($j))/$denom}] 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. inva is set to the inverse of mtxa (both are names). 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)}] } # Vector multiplication. p = mtx * vec. Return value is the product. # ma is the name of the matrix. va is a 3-component list, the vector. proc matvec {ma va} { upvar $ma mat set v0 [lindex $va 0] set v1 [lindex $va 1] set v2 [lindex $va 2] return "[expr {$mat(00)*$v0+$mat(01)*$v1+$mat(02)*$v2}]\ [expr {$mat(10)*$v0+$mat(11)*$v1+$mat(12)*$v2}]\ [expr {$mat(20)*$v0+$mat(21)*$v1+$mat(22)*$v2}]" } # ===== Color space conversions. # The function to convert from color space A to B is called A2B. A mapping # function can compose these functions to transform from any space to any # other; it relies on the A2B format to know what each function does. # Gamma correction, rgbi to rgb using theoretical curve with exponent of 2.35. # rawmax = raw RGB corresponding to $inten = 1.0. # origin = raw RGB corresponding to $inten = 0.0. # inten = the intensity (in 0..1) to be converted. # 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 nip foreach c {0 1 2} { global ipi$c ipr$c lappend rgbi [interpolate [expr {[lindex $rgb $c]*256}] \ ipr$c ipi$c $nip($c)] } 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 nip foreach c {0 1 2} { global ipi$c ipr$c lappend rgb [expr {round([interpolate [lindex $rgbi $c] \ ipi$c ipr$c $nip($c)]/256.0)}] } return $rgb } # rgbi to and from X-style CIEXYZ by a linear transformation, which is obtained # if possible from the X-server; if not a good guess is used. # NOTE that CIEXYZ on the X server runs from # 0 to 1 while the numbers in the CIE spec appear to go from 0 to 100. The # integral of the standard observer in each channel is approx. 21 (per the # spec's scaling). proc rgbi2CIEXYZ {rgbi} { global RGBtoXYZ return [matvec RGBtoXYZ $rgbi] } proc CIEXYZ2rgbi {xyz} { global XYZtoRGB return [matvec XYZtoRGB $xyz] } # The formulae in the following transformations are from: # Rea, Mark S (ed.), "Lighting Handbook, Reference & Application", # Illuminating Society of North America (N.Y.), 1993, ISBN 0-87995-102-8 # (Adapted for this purpose by Jim Carter.) # CIEXYZ to and from CIExyY. x = X/(X+Y+Z) y = Y/(X+Y+Z) Y from XYZ. proc CIEXYZ2CIExyY {XYZ} { set X [lindex $XYZ 0] set Y [lindex $XYZ 1] set Z [lindex $XYZ 2] set sum [expr {$X+$Y+$Z}] if {$sum <= 0} {set sum 1.0} return "[expr {$X/$sum}] [expr {$Y/$sum}] $Y" } proc CIExyY2CIEXYZ {xyy} { set x [lindex $xyy 0] set y [lindex $xyy 1] set Y [lindex $xyy 2] set sum [expr {$Y/(($y>0)?$y:1.0)}] set X [expr {$x*$sum}] set Z [expr {$sum-$Y-$X}] return "$X $Y $Z" } # CIEuvY to and from CIEXYZ. This is presumed to be the uv from the CIEUVW # definition, with Y from XYZ. proc CIEXYZ2CIEuvY {XYZ} { set X [lindex $XYZ 0] set Y [lindex $XYZ 1] set Z [lindex $XYZ 2] set denom [expr {$X+15*$Y+3*$Z}] if {$denom <= 0} {set denom 1.0} return "[expr {4.0*$X/$denom}] [expr {6.0*$Y/$denom}] $Y" } proc CIEuvY2CIEXYZ {uvy} { set u [lindex $uvy 0] set v [lindex $uvy 1] set Y [lindex $uvy 2] if {$v > 0} {set denom [expr {6.0*$Y/double($v)}]} else {set denom 0} set X [expr {0.25*$denom*$u}] set Z [expr {($denom-$X-15*$Y)/3.0}] return "$X $Y $Z" } # CIELuv to and from CIEuvY. White point is assumed to be rgbi:1/1/1. proc CIEuvY2CIELuv {uvy} { global uvY_white set u [expr {[lindex $uvy 0]-[lindex $uvY_white 0]}] set v [expr {[lindex $uvy 1]-[lindex $uvY_white 1]}] set Y [expr {[lindex $uvy 2]/double([lindex $uvY_white 2])}] set L [expr {($Y>0.008856)?(116*pow($Y,1/3.0)-16):(903.29*$Y)}] return "$L [expr {13*$L*$u}] [expr {13*$L*$v}]" } proc CIELuv2CIEuvY {luv} { global uvY_white set L [lindex $luv 0] set us [lindex $luv 1] set vs [lindex $luv 2] set Y [expr \ {(($L>8)?(pow($L+16,3)/116.0):($L/903.29))*[lindex $uvY_white 2]}] if {$L <= 0} {set L 1.0} set u [expr {$us/(13.0*$L)+[lindex $uvY_white 0]}] set v [expr {$vs/(13.0*$L)+[lindex $uvY_white 1]}] return "$u $v $Y" } # CIEXYZ to and from CIELab. The white point is taken as rgbi:1/1/1. proc CIEXYZ2CIELab {XYZ} { set x [labfcn $XYZ 0] set y [labfcn $XYZ 1] set z [labfcn $XYZ 2] return "[expr {116*$y-16}] [expr {500*($x-$y)}] [expr {200*($y-$z)}]" } # The official CIE gamma correction function for CIELab proc labfcn {XYZ j} { global XYZ_white set q [expr {[lindex $XYZ $j]/double([lindex $XYZ_white $j])}] return [expr {($q>0.008856)?(pow($q,1.0/3.0)):(7.787*$q+0.13793)}] } proc CIELab2CIEXYZ {Lab} { set yst [expr {([lindex $Lab 0]+16)/116.0}] set xst [expr {0.002*([lindex $Lab 1]+$yst)}] set zst [expr {-0.005*([lindex $Lab 2]-$yst)}] return "[labinv $xst 0] [labinv $yst 1] [labinv $zst 2]" } proc labinv {qst j} { global XYZ_white return [expr {(($qst>8)?pow($qst,3):(($qst-0.13793)/7.787))*[lindex $XYZ_white $j]}] } # CIELSH to and from CIELuv. This is as described by Poynton. The X-server # doesn't know anything about CIELSH. (Lightness, Saturation, Hue.) proc CIELuv2CIELSH {lab} { set L [lindex $lab 0] set u [lindex $lab 1] set v [lindex $lab 2] set s [expr {sqrt($u*$u+$v*$v)/($L>0?$L:1)}] ;#Saturation 0-1? set h [expr {atan2(-$v,-$u)/(8*atan(1.0))+0.5}] ;#Hue: angle 0-1 circle return "$L $s $h" ;#Lightness 0-100 } proc CIELSH2CIELuv {lsh} { set L [lindex $lsh 0] set s [lindex $lsh 1] set h [lindex $lsh 2] set c [expr {$L*$s}] set th [expr {$h*8*atan(1.0)}] return "$L [expr {$c*cos($th)}] [expr {$c*sin($th)}]" } # The functions and menus use the label "P-n-o-e" because it's a proprietary # standard. The conversions below are estimated from the published materials. # If I could negotiate a deal with them I could use the 7-letter name and could # have the "real" conversions. Probably hell will freeze over first. # P-n-o-e to/from CIELSH hue conversion table set hls_pne_n 0 foreach kv {{.00 36} {.16 16} {.25 13} {.33 7} {.40 0} {.50 -10} {.66 -19} {.83 -25} {1.00 -28}} { set hls_pne_h($hls_pne_n) [lindex $kv 0] set hls_pne_p($hls_pne_n) [lindex $kv 1] incr hls_pne_n } # Unofficial conversion from CIELSH to P-n-o-e. proc CIELSH2P-n-o-e {lsh} { global hls_pne_h hls_pne_p hls_pne_n set l [lindex $lsh 0] set s [lindex $lsh 1] set h [lindex $lsh 2] set L [expr {round(19.5-$l*0.085)}] ;#(0,100) -> (19.5,11.0) set H [expr {round([interpolate $h hls_pne_h hls_pne_p $hls_pne_n])}] if {$H < 0} {set H [expr $H+64]} set S [expr {round($s*64)}] ;#(0,1) -> (0,64) return "$L $H $S" } proc P-n-o-e2CIELSH {LHS} { global hls_pne_h hls_pne_p hls_pne_n set L [lindex $LHS 0] set H [lindex $LHS 1] set S [lindex $LHS 2] set l [expr {(19.5-$L)/0.085}] ;#(19.5,11.0) -> (0,100) if {$H > $hls_pne_p(0)} {set H [expr $H-64]} set h [interpolate $H hls_pne_p hls_pne_h $hls_pne_n] set s [expr {$S/64.0}] return "$l $s $h" } # Given a color name, return the RGB numbers as a list. The names and rgb's # come out of /usr/lib/X11/rgb.txt. There is also a file /usr/lib/X11/Xcms.txt # which has CIEXYZ colors (not very many). This program doesn't use it. # NOTE: there is some question whether the rgb.txt numbers are supposed to # be rgb, scaled rgbi, ciexyz, or what. proc name2rgb {name} { global color regsub -all { } [string tolower $name] {} name if {[info exists color($name)]} { set col $color($name) } else { set col {00 00 00} } return $col } # colorsyn(R) = list of {{R G B name} {...}} of all colors having that exact # red value, no particular order. # Given a color list {r g b}, return the name that matches most closely. proc rgb2name {col} { #Check for being out of RGB gamut. foreach c {0 1 2} { set r [lindex $col $c] if {0 > $r || $r >= 255.5} { return [concat $col Error] } } set dist 500 ;#abs($col - best color), upper bound is 442.6 set bestname none #Start with exact red and green values specified. set r [expr {round([lindex $col 0])}] set g [expr {round([lindex $col 1])}] set dr 0 ;#Will look at colors with red = $r +- $dr #If a close match has been found in the g-b direction (i.e. #with almost equal r), stop looking when delta r would make #any match worse even if g-b match exactly. Guaranteed to exit #after max of 500 steps even on total garbage input. while {$dr <= $dist} { foreach sr {1 -1} { set R [expr {$r+$sr*$dr}] global colorsyn.${R} if {[info exists colorsyn.${R}]} { foreach G [array names colorsyn.${R}] { set dg [expr {abs($G-$g)}] if {$dg <= $dist} { foreach bcol [set colorsyn.${R}($G)] { #Get abs(this color - target color). set db [expr {[lindex $col 2]-[lindex $bcol 2]}] set d [expr {sqrt($dr*$dr+$dg*$dg+$db*$db)}] if {$dist > $d} { set dist $d set bestname [lindex $bcol 3] } } } } } if {$dr == 0} break } incr dr } return $bestname } # ======= Color conversion management # Set color system info. # CIEuvY is omitted because I can't find a good definition of it. # Column headings: System, Slider labels, From, To, Multiplier, Official, Format # Multiplier: multiply floating point by this to give scrollbar values. foreach kv { {rgb {Red Green Blue} {0 0 0} {255 255 255} {1 1 1} 1 %4.0f} {rgbi {Red Green Blue} {0 0 0} {99 99 99} {100 100 100} 1 %4.2f} {CIEXYZ {Red Light Blue} {0 0 0} {99 99 99} {100 100 100} 1 %4.2f} {CIExyY {Red Green Light} {0 0 0} {99 99 99} {100 100 100} 1 %4.2f} {CIEuvY {Red Green Light} {0 0 0} {99 99 99} {100 100 100} 1 %4.2f} {CIELab {Light Red Green} {0 -500 -200} {100 500 200} {1 1 1} 1 %4.0f} {CIELuv {Light Red Green} {0 0 0} {99 99 99} {1 1 1} 1 %4.0f} {CIELSH {Light Sat Hue} {0 0 0} {99 130 99} {100 10 100} 0 %4.2f} {P-n-o-e {Light Hue Sat} {10 0 0} {20 63 63} {1 1 1} 0 %3.0f} } { set sys [lindex $kv 0] lappend colorsys $sys set colornames($sys) [lindex $kv 1] set colorfrom($sys) [lindex $kv 2] set colorto($sys) [lindex $kv 3] set colorscale($sys) [lindex $kv 4] set official($sys) [lindex $kv 5] set colorfmt($sys) [lindex $kv 6] } set official(name) 0 # Generalized color system conversion. $path is a starting color system (or # a partial path when this is called recursively) and # $goal is the ending one. $path is extended (reverse order) so that # path(j+1) can be converted to path(j) by an existing subroutine, ending # (path(0)) at $goal. This is the return value. {} is returned if the # conversion cannot be done. $goal == {} means any "official" color system. # mazecache caches already computed paths. proc colormaze {path goal {recurse 0}} { global official mazecache #Check for transformation already computed and cached. set start [lindex $path end] set key [list $start $goal] if {[info exists mazecache($key)]} { return $mazecache($key) } #Check for identity transformation. set from [lindex $path 0] if {$from == $goal || ($goal == {} && $official($from))} { colormaze_set $path $goal ;#Cache the identity transformation return $path } #Have to do some work -- Scan all functions that can transform #the input to any color system. foreach conv [info procs ${from}2*] { regexp {2(.*)$} $conv junk to ;#System the proc converts to if {[lsearch $path $to] >= 0} continue ;#Reject if it makes a loop. #While it may not lead to the goal, it leads _somewhere_. #Cache the transformation found so far. For each start-end #pair, get the shortest transformation. set res [concat $to $path] ;#This is a feasible xform. colormaze_set $res $to if {$to == $goal} break ;#Can't improve on this result if {$goal == {} && $official($to)} { colormaze_set $res $goal break } #Recursively extend the transformation to the goal if possible. #The result is saved in mazecache. colormaze $res $goal 1 } #Again extract the transformation from the cache. If no path #was found, return a null result, but no negative caching, #because there's always some route to the goal. set res [expr {[info exists mazecache($key)]?$mazecache($key):{}}] if {$res == {} && !$recurse} { puts "colormaze: could not map $goal from $path" set res $from ;#Fake the identity transformation } return $res } # A good path to $goal has been found. Store it in mazecache. OK for goal=={}. proc colormaze_set {path goal} { global mazecache set j 0 foreach intr $path { set key [list $intr $goal] if {![info exists mazecache($key)] || \ [llength $mazecache($key)] > $j+1} { set mazecache($key) [lrange $path 0 $j] } incr j } } # Convert a color ({r g b}, {X Y Z}, etc.) from one color system to another. # Color system names are from the list above ($colorsys). The path is what # colormaze returns. proc convert {path color} { for {set j [expr [llength $path]-2]} {$j >= 0} {incr j -1} { set conv [lindex $path [expr $j+1]]2[lindex $path $j] set color [$conv $color] } return $color } # Convert a color ({r g b}, {X Y Z}, etc.) into a ICCCM color designation. # $path = path from given color system to the desired one; could be just one # component if color is already in the desired system. proc icccm {path color} { global colorfmt if {[llength $path] > 1} {set color [convert $path $color]} set sys [lindex $path 0] set fmt $colorfmt($sys) # For RGB, give hex values, and special idiotproof clipping. if {$sys == "rgb"} { foreach val $color { if {$val < 0} {set val 0} if {$val > 255} {set val 255} set val [format "%02x" [expr {int($val)}]] lappend colory $val } } else { foreach val $color { regsub {^ *(-?)0*} [format $fmt $val] {\1} val regsub {\.$} $val {} val if {$val == {}} {set val 0} lappend colory $val } } return ${sys}:[join $colory /] } # Adapter function to call changesys when a change to a color system control # variable triggers a trace. proc colorsys_trace {gd array elt oper} { after 1 "changesys $gd" } # Changing the color system (when newsys.$gd is changed by the menu). This # is invoked through a trace on newsys.$gd. ($gd = fg or bg) # set system.fg rgbi; set system.bg rgbi ;# (set in widget setup) set path.fg rgbi; set path.bg rgbi # set mode.fg Xlib; set mode.bg Xlib ;# (set in widget setup) proc changesys {gd} { global system.$gd ;#Color system to be used global newsys.$gd ;#Colorsystem requested through the menu global path.$gd ;#Path from current colorsystem to whatever ;#should be used to set the panel colors. global epath.$gd ;#Path from colorsys to rgbi (for error check) global mode.$gd ;#Where RGB conversion is done: Local or Xlib global colornames colorfrom colorto set sys [set system.$gd] set nsys [set newsys.$gd] #Convert color to new system. set path [colormaze $sys $nsys] set col [getcolor $gd] set col [convert $path $col] set system.$gd $nsys #Cache the conversion path in the new system. if {[set mode.$gd] == "Xlib"} { set path.$gd [colormaze $nsys {}] ;#Convert to any official system } else { set path.$gd [colormaze $nsys rgb] ;#We convert to RGB ourself. } set epath.$gd [colormaze $nsys rgbi] ;#Conversion for error check #Update the labels on the scrollbars. foreach c {0 1 2} { .$gd.bar$c.lbl configure -text [lindex $colornames($nsys) $c] .$gd.bar$c.scl configure -from [lindex $colorfrom($nsys) $c] \ -to [lindex $colorto($nsys) $c] } setgang -1 setcolor $gd $col ;#Set color when all is ready setgang 1 } # ===== Database reading and default initialization # Load the RGB database. Executed only once, at end. # The color database rgb.txt consists of lines, whitespace separated, # containing R G B name (comments begin with !). color(name*) is set to # {R G B}, where name* = name with all blanks removed and converted to lower # case. colorsyn.$R($G) = list of {{R G B name*}} for all colors with # that R and G. proc rgb_load {} { global color colorsyn set rgbfd [open /usr/lib/X11/rgb.txt r] while 1 { set row [gets $rgbfd] if {[eof $rgbfd]} break regsub -all {[ ]+} [string trim $row] " " row ;#Change whitesp to 1 blank if {[string index $row 0] == "!" || [llength $row] < 4} continue set rgb [lrange $row 0 2] set col2 [lrange $row 3 end] ;#2 word color names like peach puff #Canonicalize name: remove blanks, convert to lower case. #Add to inverse list, only if not done yet under different #case/spacing. set col $col2 regsub -all { } [string tolower $col] {} col if {![info exists color($col)]} { set color($col) $rgb set R [lindex $rgb 0] if {![info exists colorsyn.${R}]} {global colorsyn.${R}} lappend colorsyn.${R}([lindex $rgb 1]) [concat $rgb $col] } set color($col2) $rgb ;#Also save using original case/spacing. } close $rgbfd } # Get the color transformation data from the server (if present). If no data, # calls default_matrix or default_inten. Global variables: # RGBtoXYZ Matrix, R($x$r) multiplies RGBi $r giving XYZ $x. # XYZtoRGB Its inverse, X($r$x) multiplies XYZ $x giving RGBi $r. # nip($r) Number of steps in interpolation table for RGB $r. # ipi${r}($j) RGBi for color $r, step $j, with 0 being brightest. # ipr${r}($j) Raw RGB corresponding. proc readxform {} { global nip XYZ_white uvY_white set fd [open {|xprop -notype -root \ 32i XDCCC_LINEAR_RGB_MATRICES 32c XDCCC_LINEAR_RGB_CORRECTION} r] #Format of the properties: NAME(INTEGER) = {comma sep. list}. #Intensity profile: 32 bit integers. Number of visuals -1; # {visual; number of profiles (colors, 1 or 3); # {number of pairs in profile -1; {rgb, rgbi}}} # rgbi values in 0..1 are multiplied by 2^32 = 4294967296. #Matrices: 32 bit signed integers scaled by 2^27 = 134217728. #9 components for XYZtoRGB: rx ry rz gx gy gz bx by bz; then #9 components for RGBtoXYZ: xr xg xb yr yg yb zr zg zb. #If the property is missing, you get NAME: error-message. set props {XDCCC_LINEAR_RGB_MATRICES XDCCC_LINEAR_RGB_CORRECTION} while {[gets $fd data] > 0} { if {![regexp {^[0-9A-Z_a_z]*} $data prop]} continue set jprop [lsearch $props $prop] if {$jprop < 0} { puts "xprop gives bogus property: $data" } elseif {! [regexp {= *(.*$)} $data junk value]} { #Error message (normally missing property) puts "xcolor: $data" default_[lindex {matrix inten} $jprop] $prop } else { regsub -all , $value {} value if {! [read_[lindex {matrix inten} $jprop] $prop $value]} { default_[lindex {matrix inten} $jprop] $prop } } } close $fd set XYZ_white [convert [colormaze rgbi CIEXYZ] {1 1 1}] set uvY_white [convert [colormaze rgbi CIEuvY] {1 1 1}] return 1 } #Extract transformation matrices. Argument is a list of 18 values for #two matrices, which are signed integers scaled by 2^27. XYZtoRGB is #first, then RGBtoXYZ. proc read_matrix {prop value} { global XYZtoRGB RGBtoXYZ set len [llength $value] if {$len != 18} { puts "$prop should have 18 values, does have $len." return 0 } set k 0 ;#Subscript in matrix value list foreach key {XYZtoRGB RGBtoXYZ} { foreach i {0 1 2} { foreach j {0 1 2} { set ${key}($i$j) [expr {[lindex $value $k]/134217728.0}] incr k } } } return 1 } # Extract the RGB intensity profiles. $value is a list of 32 bit unsigned # integers. List format: # Number-1 of visuals (separate unit for each one; pgm only handles the first) # Visual number; number of colors (1 for RGB, 3 for separate) # Number-1 of pairs in profile # rgb in 0..255 unscaled (likely can have any maximum) # rgbi in 0..1 multiplied by 2^32 = 4294967296. proc read_inten {prop value} { global nip set len [llength $value] if {$len < 8} { puts "xcolor: $prop value totally bogus." } set nviz [lindex $value 0] ;#Number of visuals with translations. set visual [lindex $value 1] ;#Which visual the first one is for. if {$nviz != 0} { set nviz [expr {$nviz+1}] puts \ "xcolor: $prop specified for $nviz visuals. The program will use only the first, for visual $visual." } if {$visual != 0} { puts \ "xcolor: local transformations will use $prop for visual $visual, which is not the default visual (0)." } set ntab [lindex $value 2] ;#Number-1 of profiles set i 2 ;#Subscript in $value foreach r {0 1 2} { ;#r = color number set j [lindex $value [incr i]] ;#Number-1 of pairs in table set nip($r) [expr $j+1] if {$i+2*$nip($r)+(($r>=$ntab-1)?0:1) >= $len} { puts "xcolor: $prop length is $len, should be longer." return 0 } global ipr$r ipi$r for {set m $j} {$m >= 0} {incr m -1} { set ipr${r}($m) [lindex $value [incr i]] set ipi${r}($m) [expr [lindex $value [incr i]].0/4294967296.0] } } return 1 } # When there is no color characterization data on the server, fake it. proc default_inten {prop} { global nip puts "Using default $prop. Set the property with xcmsdb." set rmax 65536 ;#Maximum RGB value +1 set R [expr 2.0/3.0] ;#Ratio in power law intensity profile set gamma 1.666 ;#Exponent in power law gamma correction foreach r {0 1 2} { set nip($r) 12 set n 11 #Set black and white levels to obvious defaults. global ipr$r ipi$r set ipi${r}(0) 1.0 set ipi${r}($n) 0.0 set ipr${r}(0) [expr $rmax-1] set ipr${r}($n) 0 #Set intensity profile using power law gamma correction. for {set i 1} {$i < $n} {incr i} { set ipi${r}($i) [expr {[set ipi${r}([expr $i-1])]*$R}] #ipraw = rmax * ipi${r}($i)^(1/2.35) set ipr${r}($i) \ [expr {round($rmax*exp(log([set ipi${r}($i)])/$gamma))}] } } } proc default_matrix {prop} { global XYZtoRGB RGBtoXYZ puts "Using default $prop. Set the property with xcmsdb." # 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 RGBtoXYZ([lindex $kv 0]) [lindex $kv 1] } foreach kv { {00 3.48340} {01 -1.52176} {02 -0.55923} {10 -1.07152} {11 1.96593} {12 0.03673} {20 0.06351} {21 -0.20020} {22 0.81070} } { set XYZtoRGB([lindex $kv 0]) [lindex $kv 1] } } # ====== Widget Operation # Get the numbers currently in the entries. Scale as needed, and clip to # legal range. Result is a list, {r g b} or whatever the current color system # involves. Argument is the "ground" (fg/bg). proc getcolor {gd} { global system.$gd colorfrom colorto colorscale set sys [set system.$gd] set from $colorfrom($sys) set to $colorto($sys) set scale $colorscale($sys) foreach c {0 1 2} { global col.$gd$c set val [set col.$gd$c] ;#Color component from entry set t [lindex $from $c] ;#Clip it (may be user entered) if {$val < $t} {set val $t} set t [lindex $to $c] if {$val > $t} {set val $t} set val [expr {$val/double([lindex $scale $c])}] ;#Scale to color range lappend color $val } return $color } # Given one scaled color (i.e. from a scrollbar or entry widget), clip and # scale to a floating point color, and then set everything. $gd = bg/fg; # $c = 0/1/2 for which color; $val = scaled color. proc scaledcolor {gd c val} { global col.$gd$c set col.$gd$c $val update_color $gd } # Set everything from a {r g b} list of floating point color components. proc setcolor {gd color} { global system.$gd colorscale set sys [set system.$gd] set scale $colorscale($sys) foreach c {0 1 2} { global col.$gd$c set col.$gd$c [expr {round([lindex $color $c]*[lindex $scale $c])}] } update_color $gd } # Initialize global color entry variables foreach gd {bg fg} { foreach c {0 1 2} { set col.$gd$c 0 set oldcol.$gd$c -1 } } # Update everything from the current value of col.$gd$c. The scaled colors # in the entry widgets are clipped and unscaled. proc update_color {gd} { global system.$gd colorrgb.$gd path.$gd epath.$gd global colorfrom colorto colorscale panelr set sys [set system.$gd] set from $colorfrom($sys) set to $colorto($sys) set scale $colorscale($sys) set j 0 foreach c {0 1 2} { global col.$gd$c oldcol.$gd$c set val [set col.$gd$c] if {$val != [set oldcol.$gd$c]} { set fr [lindex $from $c] ;#Clip it if {$val < $fr} {set val $fr} set t [lindex $to $c] if {$val > $t} {set val $t} set col.$gd$c $val ;#Sets the entry widget set range [expr $t-$fr] ;#Set the scrollbar set ssiz [expr {int(0.08*$range)}] # .$gd.bar$c.scl set \ #obsolete? [expr $range+$ssiz] $ssiz $val [expr $val+$ssiz-1] .$gd.bar$c.scl set $val set oldcol.$gd$c $val } lappend colorx [expr {$val/double([lindex $scale $c])}] ;#Unscale it } #Display the ICCCM format of the color set colora [icccm $sys $colorx] set colorrgb.$gd $colora #Produce the ICCCM format and system that the server will #actually get. set path [set path.$gd] if {$path != $sys} { ;#If local conv or unofficial color set colora [icccm $path $colorx] } if {$gd == "bg"} { set err [catch ".panel configure -background $colora"] } else { set err [catch ".panel itemconfigure $panelr -fill $colora"] } if {! $err} { if {$sys == "rgbi"} { set colore $colorx } else { set colore [convert [set epath.$gd] $colorx] } foreach c $colore { if {0 > $c || $c > 1} {set err 1} } } .$gd.head.err configure -text [expr {$err?"Error":""}] showall $gd $sys $colorx } # Update from a specified color name. proc update_name {gd} { global colorname.$gd system.$gd set sys [set system.$gd] set path [colormaze name $sys] set col [convert $path [set colorname.$gd]] setcolor $gd $col if {$col == {00 00 00}} { .$gd.head.err configure -text Error } } # Optional features: all system viewer and foreground-background gang # operation. proc showall {gd sys col} { global colorfmt colorsys gangmode.$gd gangmode gangground #Fill in the "show all" output area, if turned on. set alv .$gd.all.[string tolower [lindex $colorsys 0]].val if {[winfo exists $alv]} { foreach c $colorsys { set alv .$gd.all.[string tolower $c].val set path [colormaze $sys $c] set vcol [convert $path $col] set fcol {} foreach v $vcol { append fcol " [format $colorfmt($c) $v]" } $alv configure -text $fcol } } #Set the other ground if gang mode is turned on. if {$gangmode && $gangground != $gd} { array set fgbg {fg bg bg fg} set gangground $fgbg($gd) setcolor $fgbg($gd) [convert [set gangmode.$gd] $col] update idletasks set gangground {} } } # Turn gang mode on or off. ktl: # 0 = toggle on or off, whichever it wasn't. # -1 = turn it off but leave activation state in gangmode.bg # 1 = Restore activation state and recompute transformation if active. set gangmode.bg {} ;#Path for gang mode conversion set gangmode.fg {} ;#Path for gang mode conversion set gangmode 0 ;#Activation mode set gangground {} ;#Which system initiated a change proc setgang {ktl} { global gangmode gangmode.fg gangmode.bg system.fg system.bg set wid .bg.name.quit switch -- $ktl { -1 { set gangmode 0 return } 1 { set gangmode [expr {[set gangmode.fg] != {}}] } 0 { set gangmode [expr {!$gangmode}] } } if {$gangmode} { set gangmode.bg [colormaze [set system.bg] [set system.fg]] set gangmode.fg [colormaze [set system.fg] [set system.bg]] $wid configure -foreground rgbi:1/0/0 -activeforeground rgbi:1/0/0 } else { set gangmode.fg {} set gangmode.bg {} $wid configure -foreground rgbi:0/0/0 -activeforeground rgbi:0/0/0 } } # Find the name corresponding to the current colors. proc set_name {gd} { global colorname.$gd system.$gd set col [getcolor $gd] set colorname.$gd [convert [colormaze [set system.$gd] name] $col] } # Post the color system menu from other than its menubutton. proc syspost {gd} { set mb .$gd.head.mb tkMbPost $mb } # ====== Widget layout # Engage or remove the showall display on both grounds. proc showall_setup {} { global colorsys if {[winfo exists .fg.all]} { foreach gd {fg bg} { destroy .$gd.all } } else { foreach gd {fg bg} { set all .$gd.all frame $all pack $all -before [lindex [winfo children .$gd] 0] -side right foreach c $colorsys { set alf $all.[string tolower $c] frame $alf pack $alf -in $all -side top -fill x -expand 1 label $alf.lbl -text $c pack $alf.lbl -in $alf -side left label $alf.val -width 18 pack $alf.val -in $alf -side right -anchor e } update_color $gd } } } proc showall_setup_OBSOLETE {} { global colorsys if {[llength [winfo children .fg.all]] > 0} { foreach gd {fg bg} { set all .$gd.all foreach w [winfo children $all] { destroy $w } frame $all.junk pack $all.junk -in $all destroy $all.junk } return } foreach gd {fg bg} { set all .$gd.all foreach c $colorsys { set alf $all.[string tolower $c] frame $alf pack $alf -in $all -side top -fill x -expand 1 label $alf.lbl -text $c pack $alf.lbl -in $alf -side left label $alf.val -width 18 pack $alf.val -in $alf -side right -anchor e } update_color $gd } } # Set up the main widget and canvas (panel). option add *background rgbi:.5/.5/.5 . configure -background rgbi:.5/.5/.5 ;#It already has its default background set sizx 400; set sizy 300 canvas .panel -width $sizx -height $sizy pack .panel -side top -fill x -expand 1 # Decide which bitmap file to use. set bitmap /usr/include/X11/bitmaps/xlogo64 ;#Hardwired default set j [option get .panel bitmap Bitmap] if {$j != {}} {set bitmap $j} ;#From Xresources set j [lsearch $argv -bitmap] if {$j >= 0} {set bitmap [lindex $argv [expr $j+1]]} ;#From commmand line # Tile the bitmap over the panel. set panelr [.panel create rectangle 0 0 [expr {$sizx*1.6}] $sizy -outline {} \ -stipple @$bitmap] # Create the background and foreground controllers. set g 0 foreach gd {bg fg} { ;#Which "ground", background/foreground #Ground frame and heading frame frame .$gd pack .$gd -in . -side top -fill x -expand 1 -anchor w #When "showall" is turned on, the first child will be a #frame containing the showall data, packed at the right. #Top line of "ground" area. frame .$gd.head pack .$gd.head -in .$gd -side top -anchor n -fill x -expand 1 #Title (Background or Foreground) label .$gd.head.title -text [lindex {Background Foreground} $g] pack .$gd.head.title -in .$gd.head -side left #Error indicator, says "error" if color is out of gamut. label .$gd.head.err -width 5 -foreground rgbi:1/0/0 pack .$gd.head.err -in .$gd.head -side left -padx 12 #Mode variable and indicator (Local or Xlib) set mv mode.$gd set $mv Xlib label .$gd.head.mode -textvariable $mv -width 6 -relief sunken #Variable and indicator for name of color system set sv newsys.$gd ;#Variable to hold name of color system set $sv rgbi set system.$gd rgbi label .$gd.head.cs -textvariable system.$gd -width 7 -relief sunken #Menu and button to select color system and mode set mb .$gd.head.mb menubutton $mb -text "Color System:" -menu $mb.menu bind .$gd.head.cs <ButtonRelease-1> "tkMbPost $mb" bind .$gd.head.mode <ButtonRelease-1> "tkMbPost $mb" pack .$gd.head.mode .$gd.head.cs $mb -in .$gd.head -side right menu $mb.menu foreach c $colorsys { $mb.menu add radiobutton -label $c -value $c -variable $sv } $mb.menu add separator $mb.menu add radiobutton -label "Local Conv" -value Local -variable $mv $mb.menu add radiobutton -label "Xlib Conv" -value Xlib -variable $mv #Trace the mode and system variables so that when the menu #button changes it, everything gets updated. foreach var "$sv $mv" { trace variable $var w "colorsys_trace $gd" } #Command to display simultaneous translations. $mb.menu add separator $mb.menu add command -label "Show All" -command "showall_setup" #Scrollbars for 3 color components, each in its own frame foreach c {0 1 2} { frame .$gd.bar$c -bd 2 #Label for name of color component label .$gd.bar$c.lbl -relief sunken -width 5 pack .$gd.bar$c.lbl -in .$gd.bar$c -side left #Variable to hold color component, and entry to set it directly set col.$gd$c 0 entry .$gd.bar$c.ent -textvariable col.$gd$c -relief sunken -width 5 bind .$gd.bar$c.ent <Return> "update_color $gd" pack .$gd.bar$c.ent -in .$gd.bar$c -side right #The scrollbar itself # scrollbar .$gd.bar$c.scl -command "scaledcolor $gd $c" \ #obsolete? -orient horizontal -relief sunken scale .$gd.bar$c.scl -command "scaledcolor $gd $c" \ -orient horizontal -showvalue 0 pack .$gd.bar$c.scl -in .$gd.bar$c -side right -expand yes -fill both pack .$gd.bar$c -side top -anchor n -expand yes -fill x } #Bottom section in its own frame: frame .$gd.name -bd 4 #Button causes color components to be translated to a name. button .$gd.name.lbl -text "Name:" -command "set_name $gd" #Entry and variable so a name can be entered. The button's #output name also goes here. The initial names are used #eventually to initialize the panel colors. set colorname.$gd [lindex {white black} $g] entry .$gd.name.ent -textvariable colorname.$gd -relief sunken -bd 2 bind .$gd.name.ent <Return> "update_name $gd" #The current color in proper ICCCM format, and variable for it set colorrgb.$gd {} entry .$gd.name.rgb -textvariable colorrgb.$gd -state disabled\ -relief sunken -width 21 #Quit or Gang button. (Crock: shouldn't be two of them!) if {$g} { button .$gd.name.quit -text Quit -command {exit} } else { button .$gd.name.quit -text {Gang} -command "setgang 0" } pack .$gd.name.lbl -in .$gd.name -side left pack .$gd.name.ent -in .$gd.name -side left -fill x -expand 1 pack .$gd.name.quit .$gd.name.rgb -in .$gd.name -side right pack .$gd.name -side top -anchor n -fill x incr g } wm deiconify . puts "Loading color characterization data from server" readxform ;#Load color characterization data from server puts "Loading color name database" rgb_load ;#Load RGB name database foreach gd {bg fg} { update_name $gd ;#Initialize colors from initial names changesys $gd ;#Set up all transformation data. }