Artifact
5151ec9bebb7d79b0514d78e291be255bd7ad590:
Attachment "ReducedWithBug.tcl" to
ticket [1298158fff]
added by
billposer
2005-09-22 04:29:33.
#!/bin/sh
# the next line restarts using wish \
exec wish $0 -- $@
#
package require msgcat
proc _ {s} {return [::msgcat::mc $s]}; # Define shorthand for gettext
#::msgcat::mcload [file join [file dirname [info script]] msgs];
::msgcat::mcset fr "About" "À Propos"
::msgcat::mcset fr "Help" "Aide"
::msgcat::mcset fr "Dismiss" "Quitter"
::msgcat::mcset fr "Random" "Alléatoire"
::msgcat::mcset fr "Find" "Chercher"
::msgcat::mcset fr "Find Again" "Chercher Encore"
::msgcat::mcset fr "Closest" "Plus Proche"
::msgcat::mcset fr "This is what the current color looks like." "Ceci exemplifie la couleur choisie."
font create MainFont -family Courier -size 13
proc SetHold {} {
set ::HoldColor $::CurrentColor;
$::HOLDEXAMPLE configure -bg $::RGB
}
set COLOR(red) 0xFF;
set COLOR(green) 0xFF;
set COLOR(blue) 0xFF;
proc ColorPicker {} {
global COLOR
set cols {
fffafa snow
f8f8ff {ghost white}
f5f5f5 {white smoke}
dcdcdc gainsboro
fffaf0 {floral white}
fdf5e6 {old lace}
faf0e6 linen
faebd7 {antique white}
ffefd5 {papaya whip}
ffebcd {blanched almond}
ffe4c4 bisque
bebebe gray
d3d3d3 {light grey}
4169e1 {royal blue}
3cb371 {medium sea green}
20b2aa {light sea green}
98fb98 {pale green}
00ff7f {spring green}
7cfc00 {lawn green}
00ff00 green
7fff00 chartreuse
00fa9a {medium spring green}
adff2f {green yellow}
}
set CurrentColor \#FFFFFF
#Major pieces
set NOT [frame .not]
set BARS [frame $NOT.bars]
set ::NAMES [frame .c -relief ridge -bd 2]
set ::RDT [label $NOT.rdt -textvariable CurrentColor -width 9 -relief raised \
-height 1 -border 2 -font [font create -size 14 -weight bold]]
set ::ENT [entry $NOT.ent -width 9 -relief sunken -border 2 \
-font [font create -size 14 -weight bold]]
set HOLDRDT [label $NOT.rdt2 -textvariable HoldColor -width 9 -relief raised \
-height 1 -border 2 -font [font create -size 14 -weight bold]]
set ::EXAMPLE [label $NOT.ex -relief raised]
set ::HOLDEXAMPLE [label $NOT.holdex -relief raised]
bind $::HOLDEXAMPLE <ButtonPress-1> SetHold;
bind $HOLDRDT <ButtonPress-1> SetHold;
bind $::ENT <Return> DoEntry
bind $::RDT <ButtonPress-1> SwapInEntry;
#Color name list
set ItemWidth 180
set NameListHeight 200
set canvas [canvas .c.canvas -yscrollcommand ".c.sy set" \
-width $ItemWidth -height $NameListHeight -relief raised -bd 2]
scrollbar .c.sy -orient vert -command "$canvas yview" -bd 1
pack $::NAMES.sy -side right -fill y -expand 1
pack $canvas -fill both -expand 1 -side right
set mark 0
foreach {i j} $cols {
scan $i "%2x%2x%2x" r g b
if {($r+$g+$b)<350} { set col white } else { set col black }
set i \#[string toupper $i]
$canvas create rect 0 $mark $ItemWidth [incr mark 30] \
-fill $i -outline {} -tags $i
#Store the id associated with the text for use in searches.
set ::ID($j) \
[$canvas create text 10 [expr $mark-15] -text $j -fill $col -tags $i -anchor w]
$canvas bind $i <ButtonPress-1> "SetColor $i"
}
$canvas config -scrollregion "0 0 200 $mark"
#Search
frame .srch
button .srch.closest -text [_ "Closest"] -command FindClosestNamedColor;
button .srch.slab -text [_ "Find"] -command {Search 0}
button .srch.slaba -text [_ "Find Again"] -command Search
entry .srch.search -width 12
pack .srch.closest -side left -expand 1 -fill none -anchor w -padx 4
pack .srch.slab -side left -expand 1 -fill x -padx 4;
pack .srch.slaba -side left -expand 1 -fill x -padx 4;
#Comment out the following line to eliminate the bug.
pack .srch.search -side left -expand 1 -fill x -anchor e -padx 4;
#Controls
frame .cntls
button .cntls.random -text [_ "Random"] -command PickRandomColor
pack .cntls.random -side left -expand 1 -fill both -padx 10 -pady 2
pack .cntls -side top -expand 1 -fill both -padx 2 -pady 2
pack .srch -side bottom -expand 1 -fill both -padx 2 -pady 2
pack $NOT -side right -expand 1 -fill both -padx 2 -pady 2
pack $::NAMES -side left -expand 1 -fill both -padx 2 -pady 2
pack $HOLDRDT -side top -expand 0 -fill both -padx 2 -pady 2
pack $::HOLDEXAMPLE -side top -expand 1 -fill both -padx 2 -pady 1
pack $::EXAMPLE -side top -expand 1 -fill both -padx 2 -pady 1
pack $::RDT -side top -expand 0 -fill both -padx 2 -pady 2
foreach {i j} $cols {
lappend ::ColorNameList $j;
lappend ::ColorSpecList $i;
}
focus $::NAMES.sy
return
}
proc SetColor {{rgb {}}} {
global COLOR EXAMPLE RGB
if [string comp {} $rgb] {
scan $rgb "\#%2x%2x%2x" red green blue
foreach c {red green blue} { set COLOR($c) [format %d [set $c]] }
set rgbtxt [format "%02.2X %02.2X %02.2X" $COLOR(red) $COLOR(green) $COLOR(blue)]
} else {
set rgb [format "\#%02.2X%02.2X%02.2X" $COLOR(red) $COLOR(green) $COLOR(blue)]
set rgbtxt [format "%02.2X %02.2X %02.2X" $COLOR(red) $COLOR(green) $COLOR(blue)]
}
$EXAMPLE config -bg $rgb
set RGB $rgb;
set ::CurrentColor $rgbtxt
update
}
proc ShowEntry {index} {
global NAMES;
global ColorNameList;
set id $::ID([lindex $::ColorNameList $index]);
set y [lindex [$NAMES.canvas coords [expr $id -1]] 1]
set LastID $::ID([lindex $ColorNameList end])
set LastY [lindex [$NAMES.canvas coords $LastID] 1];
set fraction [expr $y/$LastY];
$NAMES.canvas yview moveto $fraction;
$NAMES.canvas focus $id;
event generate $NAMES.canvas <ButtonPress-1>
}
proc SwapInEntry {} {
pack forget $::RDT;
pack $::ENT -side top -after $::EXAMPLE -expand 0 -fill both -padx 2 -pady 2
focus $::ENT;
}
proc SwapInReadout {} {
pack forget $::ENT;
pack $::RDT -side top -after $::EXAMPLE -expand 0 -fill both -padx 2 -pady 2
}
proc DoEntry {} {
set Raw [$::ENT get]
if {[string length $Raw] < 1} {
SwapInReadout;
return ;
}
set cs [string map {\u0020 ""} $Raw]
if {![regexp {^[[:xdigit:]]{6}$} $cs]} {
$::ENT delete 0 end
return ;
}
SetColor \#$cs
$::ENT delete 0 end
SwapInReadout;
}
#Returns the square of the Euclidean distance between two colors in RGB coordinates.
#Since we're only interested in relative distance, there's no point in computing
#the square root.
proc ColorDistance {x y} {
scan $x "%2x%2x%2x" rx gx bx
scan $y "%2x%2x%2x" ry gy by
set dr [expr $rx - $ry]
set dg [expr $gx - $gy]
set db [expr $bx - $by]
return [expr ($dr*$dr) + ($dg*$dg) + ($db*$db)]
}
set MaximumColorDistance [ColorDistance 000000 FFFFFF];
proc FindClosestNamedColor {} {
global MaximumColorDistance;
set tgt [string trimleft $::CurrentColor "\#"]
set min $MaximumColorDistance;
set BestColorIndex 0;
set cnt 0;
foreach cs $::ColorSpecList {
set delta [ColorDistance $tgt $cs]
if {$delta < $min} {
set min $delta;
set BestColorIndex $cnt;
}
incr cnt;
}
SetHold;
ShowEntry $BestColorIndex;
return
}
proc PickRandomColor {} {
set red [expr int(256 * rand())]
set green [expr int(256 * rand())]
set blue [expr int(256 * rand())]
SetColor [format "\#%02x%02x%02x" $red $green $blue]
}
set SearchOffset 0;
ColorPicker
