package Tk::ColorSelect;
use strict;
use vars qw($VERSION);
$VERSION = '3.032'; # $Id: //depot/Tk8/Tk/ColorEditor.pm#32 $
use Tk qw(Ev);
require Tk::Frame;
use base  qw(Tk::Frame);
Construct Tk::Widget 'ColorSelect';
sub Populate{my($middle,$args)=@_;
my($i,@a);
require Tk::Config;
my(@xlibpath)=map{s/^-L//;"$_/X11/rgb.txt"}split/\s+/,$Tk::Config::xlib;
foreach$i(@xlibpath,'/usr/local/lib/X11/rgb.txt','/usr/lib/X11/rgb.txt','/usr/X11R6/lib/X11/rgb.txt','/usr/local/X11R5/lib/X11/rgb.txt','/X11/R5/lib/X11/rgb.txt','/X11/R4/lib/rgb/rgb.txt','/usr/openwin/lib/X11/rgb.txt'){local*FOO;
next if!open FOO,$i;
my$middle_left=$middle->Frame;
$middle_left->pack(-side=>'left',-padx=>'0.25c',-pady=>'0.25c',);
my$names=$middle->Listbox(-width=>20,-height=>12,-relief=>'sunken',-borderwidth=>2,-exportselection=>0,);
$names->bind('<Double-1>'=>[$middle,'color',Ev(['getSelected'])]);
my$scroll=$middle->Scrollbar(-orient=>'vertical',-command=>['yview',$names],-relief=>'sunken',-borderwidth=>2,);
$names->configure(-yscrollcommand=>['set',$scroll]);
$names->pack(-in=>$middle_left,-side=>'left');
$scroll->pack(-in=>$middle_left,-side=>'right',-fill=>'y');
while(<FOO>){chomp;
next if/^!/;
my@a=split;
my$color=join(' ',@a[3..$#a]);
my$hex;
eval{$hex=$middle->Hex($color);};
if($@){if($@=~/unknown color name "/){next;}else{chomp$@;
die$@;}}if(!exists($Tk::ColorEditor::names{$hex})||length($Tk::ColorEditor::names{$hex})>length($color)){$Tk::ColorEditor::names{$hex}=$color;
$names->insert('end',$color);}}close FOO;
last;}my$middle_middle=$middle->Frame;
$middle_middle->pack(-side=>'left',-expand=>1,-fill=>'y');
my$mcm1=$middle_middle->Optionmenu(-variable=>\$middle->{'color_space'},-command=>[$middle,'color_space'],-relief=>'raised',-options=>[['HSB color space'=>'hsb'],['RGB color space'=>'rgb'],['CMY color space'=>'cmy']]);
$mcm1->pack(-side=>'top',-fill=>'x');
my(@middle_middle,@label,@scale);
$middle_middle[0]=$middle_middle->Frame;
$middle_middle[1]=$middle_middle->Frame;
$middle_middle[2]=$middle_middle->Frame;
$middle_middle[3]=$middle_middle->Frame;
$middle_middle[0]->pack(-side=>'top',-expand=>1);
$middle_middle[1]->pack(-side=>'top',-expand=>1);
$middle_middle[2]->pack(-side=>'top',-expand=>1);
$middle_middle[3]->pack(-side=>'top',-expand=>1,-fill=>'x');
$middle->{'Labels'}=['zero','one','two'];
foreach$i(0..2){$label[$i]=$middle->Label(-textvariable=>\$middle->{'Labels'}[$i]);
$scale[$i]=$middle->Scale(-from=>0,-to=>1000,'-length'=>'6c',-orient=>'horizontal',-command=>[\&scale_changed,$middle],);
$scale[$i]->pack(-in=>$middle_middle[$i],-side=>'top',-anchor=>'w',);
$label[$i]->pack(-in=>$middle_middle[$i],-side=>'top',-anchor=>'w',);}my$nameLabel=$middle->Label(-text=>'Name:');
$middle->{'Entry'}='';
my$name=$middle->Entry(-relief=>'sunken',-borderwidth=>2,-textvariable=>\$middle->{'Entry'},-width=>10,);
$nameLabel->pack(-in=>$middle_middle[3],-side=>'left');
$name->pack(-in=>$middle_middle[3],-side=>'right',-expand=>1,-fill=>'x',);
$name->bind('<Return>'=>[$middle,'color',Ev(['get'])]);
my$middle_right=$middle->Frame;
$middle_right->pack(-side=>'left',-pady=>'.25c',-padx=>'.25c',-anchor=>'s',);
my$swatch=$middle->Canvas(-width=>'2.5c',-height=>'5c',);
my$swatch_item=$swatch->create('oval','.5c','.3c','2.26c','4.76c');
my$value=$middle->Label(-textvariable=>\$middle->{'color'},-width=>13,-font=>'-*-Courier-Medium-R-Normal--*-120-*-*-*-*-*-*');
$swatch->pack(-in=>$middle_right,-side=>'top',-expand=>1,-fill=>'both',);
$value->pack(-in=>$middle_right,-side=>'bottom',-pady=>'.25c');
$middle->ConfigSpecs('-color_space'=>['METHOD',undef,undef,'hsb'],'-initialcolor'=>'-color','-color'=>['METHOD','background','Background',$middle->cget('-background')]);
$middle->{'swatch'}=$swatch;
$middle->{'swatch_item'}=$swatch_item;
$middle->{'scale'}=[@scale];
$middle->{'red'}=0;
$middle->{'blue'}=0;
$middle->{'green'}=0;}sub Hex{my$w=shift;
my@rgb=(@_==3)?@_:$w->rgb(@_);
sprintf('#%04x%04x%04x',@rgb)}sub color_space{my($objref,$space)=@_;
if(@_>1){my%Labels=('rgb'=>[qw(Red Green Blue)],'cmy'=>[qw(Cyan Magenta Yellow)],'hsb'=>[qw(Hue Saturation Brightness)]);
$space='hsb' unless(exists$Labels{$space});
my$i;
for$i(0..2){$objref->{'Labels'}[$i]=$Labels{$space}->[$i];}$objref->{'color_space'}=$space;
$objref->afterIdle(['set_scales',$objref])unless($objref->{'pending'}++);}return$objref->{'color_space'};}sub hsvToRgb{my($hue,$sat,$value)=@_;
my($v,$i,$f,$p,$q,$t);
$v=int(65535*$value);
return($v,$v,$v)if$sat==0;
$hue*=6;
$hue=0 if$hue>=6;
$i=int($hue);
$f=$hue-$i;
$p=int(65535*$value*(1-$sat));
$q=int(65535*$value*(1-($sat*$f)));
$t=int(65535*$value*(1-($sat*(1-$f))));
return($v,$t,$p)if$i==0;
return($q,$v,$p)if$i==1;
return($p,$v,$t)if$i==2;
return($p,$q,$v)if$i==3;
return($t,$p,$v)if$i==4;
return($v,$p,$q)if$i==5;}sub color{my($objref,$name)=@_;
if(@_>1&&defined($name)&&length($name)){if($name eq 'cancel'){$objref->{color}=undef;
return;}my($format,$shift);
my($red,$green,$blue);
if($name!~/^#/){($red,$green,$blue)=$objref->{'swatch'}->rgb($name);}else{my$len=length$name;
if($len==4){$format='#(.)(.)(.)';$shift=12;}elsif($len==7){$format='#(..)(..)(..)';$shift=8;}elsif($len==10){$format='#(...)(...)(...)';$shift=4;}elsif($len==13){$format='#(....)(....)(....)';$shift=0;}else{$objref->BackTrace("ColorEditor error:  syntax error in color name \"$name\"");
return;}($red,$green,$blue)=$name=~/$format/;
eval"\$red = 0x$red; \$green = 0x$green; \$blue = 0x$blue;";
$red=$red   <<$shift;
$green=$green <<$shift;
$blue=$blue  <<$shift;}$objref->{'red'}=$red;
$objref->{'blue'}=$blue;
$objref->{'green'}=$green;
my$hex=sprintf('#%04x%04x%04x',$red,$green,$blue);
$objref->{'color'}=$hex;
$objref->{'Entry'}=$name;
$objref->afterIdle(['set_scales',$objref])unless($objref->{'pending'}++);
$objref->{'swatch'}->itemconfigure($objref->{'swatch_item'},-fill=>$objref->{'color'});}return$objref->{'color'};}sub rgbToHsv{my($red,$green,$blue)=@_;
my($max,$min,$sat,$range,$hue,$rc,$gc,$bc);
$max=($red>$green)?(($blue>$red)?$blue:$red):(($blue>$green)?$blue:$green);
$min=($red<$green)?(($blue<$red)?$blue:$red):(($blue<$green)?$blue:$green);
$range=$max-$min;
if($max==0){$sat=0;}else{$sat=$range/$max;}if($sat==0){$hue=0;}else{$rc=($max-$red)/$range;
$gc=($max-$green)/$range;
$bc=($max-$blue)/$range;
$hue=($max==$red)?(0.166667*($bc-$gc)):(($max==$green)?(0.166667*(2+$rc-$bc)):(0.166667*(4+$gc-$rc)));}return($hue,$sat,$max/65535);}sub scale_changed{my($objref)=@_;
return if$objref->{'updating'};
my($red,$green,$blue);
if($objref->{'color_space'}eq 'rgb'){$red=int($objref->{'scale'}->[0]->get*65.535+0.5);
$green=int($objref->{'scale'}->[1]->get*65.535+0.5);
$blue=int($objref->{'scale'}->[2]->get*65.535+0.5);}elsif($objref->{'color_space'}eq 'cmy'){$red=int(65535-$objref->{'scale'}->[0]->get*65.535+0.5);
$green=int(65535-$objref->{'scale'}->[1]->get*65.535+0.5);
$blue=int(65535-$objref->{'scale'}->[2]->get*65.535+0.5);}else{($red,$green,$blue)=hsvToRgb($objref->{'scale'}->[0]->get/1000.0,$objref->{'scale'}->[1]->get/1000.0,$objref->{'scale'}->[2]->get/1000.0);}$objref->{'red'}=$red;
$objref->{'blue'}=$blue;
$objref->{'green'}=$green;
$objref->color(sprintf('#%04x%04x%04x',$red,$green,$blue));
$objref->idletasks;}sub set_scales{my($objref)=@_;
$objref->{'pending'}=0;
$objref->{'updating'}=1;
my($red,$blue,$green)=($objref->{'red'},$objref->{'blue'},$objref->{'green'});
if($objref->{'color_space'}eq 'rgb'){$objref->{'scale'}->[0]->set(int($red/65.535+0.5));
$objref->{'scale'}->[1]->set(int($green/65.535+0.5));
$objref->{'scale'}->[2]->set(int($blue/65.535+0.5));}elsif($objref->{'color_space'}eq 'cmy'){$objref->{'scale'}->[0]->set(int((65535-$red)/65.535+0.5));
$objref->{'scale'}->[1]->set(int((65535-$green)/65.535+0.5));
$objref->{'scale'}->[2]->set(int((65535-$blue)/65.535+0.5));}else{my($s1,$s2,$s3)=rgbToHsv($red,$green,$blue);
$objref->{'scale'}->[0]->set(int($s1*1000.0+0.5));
$objref->{'scale'}->[1]->set(int($s2*1000.0+0.5));
$objref->{'scale'}->[2]->set(int($s3*1000.0+0.5));}$objref->{'updating'}=0;}package Tk::ColorDialog;
require Tk::Toplevel;
use base  qw(Tk::Toplevel);
Construct Tk::Widget 'ColorDialog';
sub Accept{my$cw=shift;
$cw->withdraw;
$cw->{'done'}=1;}sub Cancel{my$cw=shift;
$cw->configure(-color=>'cancel');
$cw->Accept;}sub Populate{my($cw,$args)=@_;
$cw->SUPER::Populate($args);
$cw->protocol('WM_DELETE_WINDOW'=>['Cancel'=>$cw]);
$cw->transient($cw->Parent->toplevel);
$cw->withdraw;
my$sel=$cw->ColorSelect;
my$accept=$cw->Button(-text=>'Accept',-command=>['Accept',$cw]);
my$cancel=$cw->Button(-text=>'Cancel',-command=>['Cancel',$cw]);
Tk::grid($sel);
Tk::grid($accept,$cancel);
$cw->ConfigSpecs(DEFAULT=>[$sel]);}sub Show{my$cw=shift;
$cw->configure(@_)if@_;
$cw->Popup();
$cw->waitVariable(\$cw->{'done'});
$cw->withdraw;
return$cw->cget('-color');}package Tk::ColorEditor;
use vars qw($VERSION $SET_PALETTE);
$VERSION='3.032';
use Tk qw(lsearch Ev);
use Tk::Toplevel;
use base  qw(Tk::Toplevel);
use Tk::widgets qw(Pixmap);
Construct Tk::Widget 'ColorEditor';
%Tk::ColorEditor::names=();
use Tk::Dialog;
use Tk::Pretty;
BEGIN{$SET_PALETTE='Set Palette'};
use subs qw(color_space hsvToRgb rgbToHsv);
sub add_menu_item{my$objref=shift;
my$value;
foreach$value(@_){if($value eq 'SEP'){$objref->{'mcm2'}->separator;}else{$objref->{'mcm2'}->command(-label=>$value,-command=>['configure',$objref,'-highlight'=>$value]);
push@{$objref->{'highlight_list'}},$value;}}}sub set_title{my($w)=@_;
my$t=$w->{Configure}{'-title'}||'';
my$h=$w->{Configure}{'-highlight'}||'';
$w->SUPER::title("$t $h Color Editor");}sub highlight{my($w,$h)=@_;
if(@_>1){$w->{'update'}->configure(-text=>"Apply $h Color");
my$state=($h eq 'background')?'normal':'disabled';
$w->{'palette'}->entryconfigure($SET_PALETTE,-state=>$state);
$w->{'highlight'}=$h;
$w->configure(-color=>$w->Palette->{$h});
$w->set_title;}return$w->{'highlight'};}sub title{my($w,$val)=@_;
$w->set_title if(@_>1);
return$w->{Configure}{'-title'};}sub delete_menu_item{my$objref=shift;
my$value;
foreach$value(@_){$objref->{'mcm2'}->delete($value);
my$list_ord=$value=~/\d+/?$value:lsearch($objref->{'highlight_list'},$value);
splice(@{$objref->{'highlight_list'}},$list_ord,1)if$list_ord!=-1;}}sub delete_widgets{my($objref,$widgets_ref)=@_;
my($i,$found,$r1,$r2,@wl)=(0,0,0,0,@{$objref->cget(-widgets)});
foreach$r1(@{$widgets_ref}){$i=-1;
$found=0;
foreach$r2(@wl){$i++;
next if$r1!=$r2;
$found=1;
last;}splice(@wl,$i,1)if$found;}$objref->configure(-widgets=>[@wl]);}sub ApplyDefault{my($objref)=@_;
my$cb=$objref->cget('-command');
my$h;
foreach$h(@{$objref->{'highlight_list'}}){next if$h=~/TEAR_SEP|SEP/;
$cb->Call($h);
die unless(defined$cb);}}sub Populate{my($cw,$args)=@_;
$cw->SUPER::Populate($args);
$cw->withdraw;
my$color_space='hsb';
my(@highlight_list)=qw(
  TEAR_SEP
  foreground background SEP
  activeForeground activeBackground SEP
  highlightColor highlightBackground SEP
  selectForeground selectBackground SEP
  disabledForeground insertBackground selectColor troughColor
);
my$usage=$cw->Dialog('-title'=>'ColorEditor Usage',-justify=>'left',-wraplength=>'6i',-text=>"The Colors menu allows you to:\n\nSelect a color attribute such as \"background\" that you wish to colorize.  Click on \"Apply\" to update that single color attribute.\n\nSelect one of three color spaces.  All color spaces display a color value as a hexadecimal number under the oval color swatch that can be directly supplied on widget commands.\n\nApply Tk's default color scheme to the application.  Useful if you've made a mess of things and want to start over!\n\nChange the application's color palette.  Make sure \"background\" is selected as the color attribute, find a pleasing background color to apply to all current and future application widgets, then select \"Set Palette\".",);
my$m0=$cw->Frame(-relief=>'raised',-borderwidth=>2);
$m0->pack(-side=>'top',-fill=>'x');
my$mf=$m0->Menubutton(-text=>'File',-underline=>0,-bd=>1,-relief=>'raised',);
$mf->pack(-side=>'left');
my$close_command=[sub{shift->withdraw},$cw];
$mf->command(-label=>'Close',-underline=>0,-command=>$close_command,-accelerator=>'Ctrl-w',);
$cw->bind('<Control-Key-w>'=>$close_command);
$cw->protocol(WM_DELETE_WINDOW=>$close_command);
my$mc=$m0->Menubutton(-text=>'Colors',-underline=>0,-bd=>1,-relief=>'raised',);
$mc->pack(-side=>'left');
my$color_attributes='Color Attributes';
$mc->cascade(-label=>$color_attributes,-underline=>6);
$mc->separator;
$mc->command(-label=>'Apply Default Colors',-underline=>6,-command=>['ApplyDefault',$cw]);
$mc->separator;
$mc->command(-label=>$SET_PALETTE,-underline=>0,-command=>sub{$cw->setPalette($cw->cget('-color'))});
my$m1=$mc->cget(-menu);
my$mcm2=$m1->Menu;
$m1->entryconfigure($color_attributes,-menu=>$mcm2);
my$mh=$m0->Menubutton(-text=>'Help',-underline=>0,-bd=>1,-relief=>'raised',);
$mh->pack(-side=>'right');
$mh->command(-label=>'Usage',-underline=>0,-command=>[sub{shift->Show},$usage],);
my$bot=$cw->Frame(-relief=>'raised',-bd=>2);
$bot->pack(-side=>'bottom',-fill=>'x');
my$update=$bot->Button(-command=>[sub{my($objref)=@_;
$objref->Callback(-command=>($objref->{'highlight'},$objref->cget('-color')));},$cw,],);
$update->pack(-pady=>1,-padx=>'0.25c');
my$middle=$cw->ColorSelect(-relief=>'raised',-borderwidth=>2);
$middle->pack(-side=>'top',-fill=>'both');
my$status=$cw->Toplevel;
$status->withdraw;
$status->geometry('+0+0');
my$status_l=$status->Label(-width=>50,-anchor=>'w');
$status_l->pack(-side=>'top');
$cw->{'highlight_list'}=[@highlight_list];
$cw->{'mcm2'}=$mcm2;
foreach(@highlight_list){next if/^TEAR_SEP$/;
$cw->add_menu_item($_);}$cw->{'updating'}=0;
$cw->{'pending'}=0;
$cw->{'Status'}=$status;
$cw->{'Status_l'}=$status_l;
$cw->{'update'}=$update;
$cw->{'gwt_depth'}=0;
$cw->{'palette'}=$mc;
my$pixmap=$cw->Pixmap('-file'=>Tk->findINC('ColorEdit.xpm'));
$cw->Icon(-image=>$pixmap);
$cw->ConfigSpecs(DEFAULT=>[$middle],-widgets=>['PASSIVE',undef,undef,[$cw->parent->Descendants]],-display_status=>['PASSIVE',undef,undef,0],'-title'=>['METHOD',undef,undef,''],-command=>['CALLBACK',undef,undef,['set_colors',$cw]],'-highlight'=>['METHOD',undef,undef,'background'],-cursor=>['DESCENDANTS','cursor','Cursor','left_ptr'],);}sub Show{my($objref)=@_;
$objref->deiconify;}sub set_colors{my($objref,$type,$color)=@_;
my$display=$objref->cget('-display_status');
$objref->{'Status'}->title("Configure $type");
$objref->{'Status'}->deiconify if$display;
my$widget;
my$reset=!defined($color);
foreach$widget(@{$objref->cget('-widgets')}){if($display){$objref->{'Status_l'}->configure(-text=>'WIDGET:  '.$widget->PathName);
$objref->update;}eval{local$SIG{'__DIE__'};$color=($widget->configure("-\L${type}"))[3]}if$reset;
eval{local$SIG{'__DIE__'};$widget->configure("-\L${type}"=>$color)};}$objref->{'Status'}->withdraw if$display;}1;
__END__

=cut

