#!/usr/bin/wish # $Id: MfsColor.tcl,v 5.0 2003/06/05 14:49:36 uwe Exp uwe $ # what: color numbers for plotting
package provide MfsColor 1.0
set RGB(fname) "/usr/X11R6/lib/X11/rgb.txt" set RGB(file) open $RGB(fname) r
set filecont split [ read $RGB(file) [ file size $RGB(fname) ] "\n" ] foreach str $filecont {
if { "[ string index $str 0 ]" == "!" } {
continue
}
if { [ scan $str " %d %d %d %n " R G B pos ] < 3 } {
continue
}
set dark 0.7
set LR [ expr int( $R * $dark ) ]
set LG [ expr int( $G * $dark ) ]
set LB [ expr int( $B * $dark ) ]
set cval [ format "#%02x%02x%02x" $R $G $B ]
set dval [ format "#%02x%02x%02x" $LR $LG $LB ]
set cname [ string trim [ string range $str $pos end ] ]
#D0# puts "$R $G $B $pos $cval \"$cname\""
eval "set RGB(\$cname) {$R $G $B}"
# set RGB($cval) "$cname"
# .l1 configure -bg $cval
# .l2 configure -bg $dval
# update
# update} close $RGB(file)
proc 2color { val } {
global RGB
set val [ string trim $val ]
if { [ string index $val 0 ] != "#" } {
if { [ array names RGB $val ] != {} } {
#D0# puts " color name $val"
set rgb $RGB($val)
#D0# puts rgb:$rgb
foreach {R G B} $rgb {
#D0# puts " color R:$R "
#D0# puts " color G:$G "
#D0# puts " color B:$B "
}
} else {
foreach {R G B} {99 99 99} {
}
}
} else {
#D0# puts " color number $val"
switch [ string length $val ] {
4 {
scan $val "#%01x%01x%01x" R G B
set R [ expr $R * 0x11 ]
set G [ expr $G * 0x11 ]
set B [ expr $B * 0x11 ]
} 7 {
scan $val "#%02x%02x%02x" R G B
} 10 {
scan $val "#%03x%03x%03x" R G B
set R [ expr $R / 0x11 ]
set G [ expr $G / 0x11 ]
set B [ expr $B / 0x11 ]
} default {
#D0# puts length:[ string length $val ]
scan $val "#%02x%02x%02x" R G B
}
}
}
set dark 0.7
set LR [ expr round( $R * $dark ) ]
set LG [ expr round( $G * $dark ) ]
set LB [ expr round( $B * $dark ) ]
set cval [ format "#%02x%02x%02x" $R $G $B ]
set dval [ format "#%02x%02x%02x" $LR $LG $LB ]
#D0# puts "$cval $dval"
return "$cval $dval"}
proc col_h { val } {
set ret [ 2color "$val" ]
set ret [ split $ret ]
return [ lindex $ret 0 ]}
proc col_l { val } {
set ret [ 2color "$val" ]
set ret [ split $ret ]
return [ lindex $ret 1 ]}
# END