# colors.pl
use Tk;
use Tk::TabFrame;
use Tk::Pane;

use strict "vars";
my ($mw, $colour_pane, $colour_button, $order_button, $wg_padx, $wg_pa
+dy, $colour_item, $colour_cou);
my ($frm1_wg, $frm2_wg, $frm3_wg, $menu1_wg, $menu2_wg, $menu3_wg, $me
+nucol_wg, $mentry_wg, $colour_use_menu);
my ($order1, $order2, $order3, $oentry1_wg, $oentry2_wg, $oentry3_wg);

my ($colour_item, @colours, %colours_rgb, $red, $green, $blue, %colour
+s_order, @colours_wi, @colours_used);
my (%lb_wg, %en_wg, %lbord_wg, %enord_wg, %scr_wg, $scr_wg_cou);

    @colours = qw(black white gray60 gray70 gray80 gray85 gray90
gray95
snow1 snow2 snow3 snow4 seashell1 seashell2 seashell3 seashell4
AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 AntiqueWhite4 bisque1
bisque2 bisque3 bisque4 PeachPuff1 PeachPuff2 PeachPuff3 PeachPuff4
NavajoWhite1 NavajoWhite2 NavajoWhite3 NavajoWhite4 LemonChiffon1
LemonChiffon2 LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2
cornsilk3 cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2
honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 LavenderBlush3
LavenderBlush4 MistyRose1 MistyRose2 MistyRose3 MistyRose4 azure1
azure2 azure3 azure4 SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4
RoyalBlue1 RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4
DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 SteelBlue2
SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 DeepSkyBlue3
DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 SkyBlue4 LightSkyBlue1
LightSkyBlue2 LightSkyBlue3 LightSkyBlue4 SlateGray1 SlateGray2
SlateGray3 SlateGray4 LightSteelBlue1 LightSteelBlue2 LightSteelBlue3
LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 LightBlue4 LightCyan1
LightCyan2 LightCyan3 LightCyan4 PaleTurquoise1 PaleTurquoise2
PaleTurquoise3 PaleTurquoise4 CadetBlue1 CadetBlue2 CadetBlue3
CadetBlue4 turquoise1 turquoise2 turquoise3 turquoise4 cyan1 cyan2
cyan3 cyan4 DarkSlateGray1 DarkSlateGray2 DarkSlateGray3
DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 aquamarine4
DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 DarkSeaGreen4 SeaGreen1
SeaGreen2 SeaGreen3 SeaGreen4 PaleGreen1 PaleGreen2 PaleGreen3
PaleGreen4 SpringGreen1 SpringGreen2 SpringGreen3 SpringGreen4 green1
green2 green3 green4 chartreuse1 chartreuse2 chartreuse3 chartreuse4
OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 DarkOliveGreen1
DarkOliveGreen2 DarkOliveGreen3 DarkOliveGreen4 khaki1 khaki2 khaki3
khaki4 LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 LightGoldenrod4
LightYellow1 LightYellow2 LightYellow3 LightYellow4 yellow1 yellow2
yellow3 yellow4 gold1 gold2 gold3 gold4 goldenrod1 goldenrod2
goldenrod3 goldenrod4 DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3
DarkGoldenrod4 RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1
IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 sienna4
burlywood1 burlywood2 burlywood3 burlywood4 wheat1 wheat2 wheat3
wheat4 tan1 tan2 tan3 tan4 chocolate1 chocolate2 chocolate3 chocolate4
firebrick1 firebrick2 firebrick3 firebrick4 brown1 brown2 brown3
brown4 salmon1 salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2
LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 DarkOrange1
DarkOrange2 DarkOrange3 DarkOrange4 coral1 coral2 coral3 coral4
tomato1 tomato2 tomato3 tomato4 OrangeRed1 OrangeRed2 OrangeRed3
OrangeRed4 red1 red2 red3 red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4
HotPink1 HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 LightPink1
LightPink2 LightPink3 LightPink4 PaleVioletRed1 PaleVioletRed2
PaleVioletRed3 PaleVioletRed4 maroon1 maroon2 maroon3 maroon4
VioletRed1 VioletRed2 VioletRed3 VioletRed4 magenta1 magenta2 magenta3
magenta4 orchid1 orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4
MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 DarkOrchid1
DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 purple2 purple3 purple4
MediumPurple1 MediumPurple2 MediumPurple3 MediumPurple4 thistle1
thistle2 thistle3 thistle4
AliceBlue     
AntiqueWhite 
Aquamarine 
Azure 
Beige 
Bisque 
Black 
BlanchedAlmond 
Blue 
BlueViolet 
Brown 
BurlyWood 
CadetBlue 
Chartreuse 
Chocolate 
Coral 
CornflowerBlue 
Cornsilk 
Cyan 
DarkBlue 
DarkCyan 
DarkGoldenrod 
DarkGray 
DarkGreen 
DarkKhaki 
DarkMagenta 
DarkOliveGreen 
DarkOrange 
DarkOrchid 
DarkRed 
DarkSalmon 
DarkSeaGreen 
DarkSlateBlue 
DarkSlateGray 
DarkTurquoise 
DarkViolet 
DeepPink 
DeepSkyBlue 
DimGray     
DodgerBlue 
FireBrick 
FloralWhite 
ForestGreen 
Gainsboro 
GhostWhite 
Gold 
Goldenrod 
Gray 
Green 
GreenYellow 
Honeydew 
HotPink 
IndianRed 
Ivory 
Khaki 
Lavender 
LavenderBlush 
LawnGreen 
LemonChiffon 
LightBlue 
LightCoral 
LightCyan 
LightGoldenrodYellow 
LightGreen 
LightGrey 
LightPink 
LightSalmon 
LightSeaGreen 
LightSkyBlue 
LightSlateGray 
LightSteelBlue 
LightYellow 
LimeGreen 
Linen 
Magenta     
Maroon 
MediumAquamarine 
MediumBlue 
MediumOrchid 
MediumPurple 
MediumSeaGreen 
MediumSlateBlue 
MediumSpringGreen 
MediumTurquoise 
MediumVioletRed        
MidnightBlue  
MistyRose 
Moccasin 
NavajoWhite 
Navy 
OldLace 
OliveDrab 
Orange 
OrangeRed 
Orchid 
PaleGoldenrod 
PaleGreen 
PaleTurquoise 
PaleVioletRed 
PapayaWhip 
PeachPuff 
Peru 
Pink 
Plum 
PowderBlue 
Purple 
Red 
RosyBrown 
RoyalBlue 
SaddleBrown 
Salmon 
SandyBrown 
SeaGreen 
Seashell 
Sienna 
SkyBlue 
SlateBlue 
SlateGray 
Snow 
SpringGreen 
SteelBlue 
Tan 
Thistle 
Tomato 
Turquoise 
Violet 
Wheat 
White 
WhiteSmoke 
Yellow 
YellowGreen

);


#=====================================================================
+===============

sub colors ($$$$) {

my ($ref_wg_fr, $ref_colours, $ref_colours_rgb, $ref_colours_order)= @
+_;

my ($colour_item, $row, $col, $col_max, $colour_total, $j, $des_tot, $
+des_inc);
my ($colour_tot, $order_tot,$scr_text, $list_new, $wg_cou);


# see if the gui alrready exsits

$list_new = 'yes';
$colour_total = scalar(keys %lb_wg);
if($colour_total > 10) {
    $list_new = 'no';
}


$scr_text = 'scrollwg';

if($list_new eq 'yes') {


$scr_wg{$scr_text} = $frm3_wg->Scrolled (Pane,
                -width    => 900,
                -height    => 600,
                -scrollbars => 'ose')
            ->grid(
#                -sticky => $wg_sticky,
                -padx => $wg_padx,
                -pady => $wg_pady,
                -row     => 1,
                -column     => 0,
                -columnspan => 10
                );
}

$colour_tot = scalar(@$ref_colours);
$order_tot  = scalar(keys %$ref_colours_order);

print "[colors] totals colours <$colour_tot> order <$order_tot> pane <
+$scr_wg{$scr_text}>\n"; 

$mw->update;



$colour_total = scalar(@$ref_colours);
$col_max = 6;

print "colour total <$colour_total>\n";

$row = 0;
$col = -2;
$wg_cou = 0;

# new

if($list_new eq 'yes') {

    print "\nnew colour chart\n";

    foreach $colour_item (sort {$a <=> $b} keys %$ref_colours_order) {

        $j = $ref_colours_order->{$colour_item};

#    print "item <$colour_item> j <$j>\n";

# get the rgb values $ref_colours_order

        $col += 2;
        if($col > $col_max) {

            $row +=1;
            $col = 0;
        }

# label with name

#    print "j <$j> row <$row> col <$col> colour <$colours[$j]>\n";

        $wg_cou +=1;

        $lb_wg{$wg_cou} = $scr_wg{$scr_text}->Label (-text => $j) ->gr
+id (-row => $row, -column => $col);

        $en_wg{$wg_cou} = $scr_wg{$scr_text}->Entry (-text => $j,
                                             -background => $j
                                    ) ->grid (-row => $row, -column =>
+ $col +1); 


        ($ref_colours_rgb->{$j}{red}, $ref_colours_rgb->{$j}{green}, $
+ref_colours_rgb->{$j}{blue}) = $scr_wg{$scr_text}->rgb($j);

        $en_wg{$wg_cou}->bind('<ButtonPress>', [\&rgb_data, $j, $ref_c
+olours_rgb->{$j}{red}, $ref_colours_rgb->{$j}{green}, $ref_colours_rg
+b->{$j}{blue}]);


#        print "item <$colour_item> j <$j> lb <$lb_wg{$j}> en <$en_wg{
+$j}>  rgb red <$ref_colours_rgb->{$j}{red}> green <$ref_colours_rgb->
+{$j}{green}> blue <$ref_colours_rgb->{$j}{blue}>\n";

    }

#    foreach $colour_item (sort {$a cmp $b} keys %colours_rgb) {

#        print "$colour_item  - red <$ref_colours_rgb->{$colour_item}{
+red}> green <$ref_colours_rgb->{$colour_item}{green}> blue <$ref_colo
+urs_rgb->{$colour_item}{blue}>\n";
#    }


} else {

    print "\nupdated colur chart\n\n";


    $colour_total = scalar(keys %lb_wg);

    for ($wg_cou = 1; $wg_cou <= $colour_total; $wg_cou ++) {

        $j = $ref_colours_order->{$wg_cou};


        $lb_wg{$wg_cou}->configure(-text => $j);

        $en_wg{$wg_cou}->configure(-text => $j, -background => $j);

        ($ref_colours_rgb->{$j}{red}, $ref_colours_rgb->{$j}{green}, $
+ref_colours_rgb->{$j}{blue}) = $scr_wg{$scr_text}->rgb($j);

        $en_wg{$wg_cou}->bind('<ButtonPress>', [\&rgb_data, $j, $ref_c
+olours_rgb->{$j}{red}, $ref_colours_rgb->{$j}{green}, $ref_colours_rg
+b->{$j}{blue}]);


#        print "item <$wg_cou> j <$j> \n";

    }
}

print "j <$j> row <$row> col <$col> colour <$j>\n";


$mw->update;


} # end colors

#================================

sub see_ch_cb () {

my $cl_wg;

$cl_wg = $mw->chooseColor(-title => 'Colour Numbers');

}

#==================================

sub set_order1 {

$oentry1_wg->configure(-text => $order1);

}

#==================================

sub set_order2 {

$oentry2_wg->configure(-text => $order2);

}

#==================================

sub set_order3 {

$oentry3_wg->configure(-text => $order3);

}


#=======================================

sub get_col_v($$$$) {

my ($ord_col, $ord_dir, $colour_item, $ref_col_inc) = @_;

my ($j, $length_inc);

$$ref_col_inc = $colours_rgb{$colour_item}{$ord_col};

#print "[get_col_v] colour <$ord_col> dir <$ord_dir> colour <$colour_i
+tem> number <$$ref_col_inc>\n";

if($ord_dir eq 'Up') {

    $$ref_col_inc = 65535 - $$ref_col_inc;

}

$length_inc = length($$ref_col_inc);

if($length_inc < 5) {

    for ($j = 1; $j <= 5 - $length_inc; $j ++){

        $$ref_col_inc = '0' .$$ref_col_inc;
    }
    
}

}




#=======================================

sub reorder_colours_cb() {

my ($do_update, $ord1_str, $ord2_str, $ord3_str, @brgb, $j, $err_messa
+ge, %cx, $clnu);
my ($ord1_col, $ord1_dir, $ord2_col, $ord2_dir, $ord3_col, $ord3_dir, 
+@dir, $col_inc, $clnu);

@brgb = qw(Red Green Blue);
@dir  = qw(Up Down);

# this depends on the contents of the order selection boxes 

$ord1_str = $oentry1_wg->cget(-text);
#$ord2_str = $oentry2_wg->cget(-text);
#$ord3_str = $oentry3_wg->cget(-text);

$do_update  = 'no';

if($ord1_str eq 'Alphabetical') {

    $colour_cou = 0;

    print "[reorder_colours_cb] new colour order\n\n";

    for $colour_item (sort {lc($a) cmp lc($b)} @colours_used ) {

        $colour_cou += 1;
        $colours_order{$colour_cou} = $colour_item;
#        print "cou <$colour_cou> order <$colours_order{$colour_cou}>\
+n"; 
    }

    $do_update  = 'yes';

}

if($ord1_str eq 'Original') {

    $colour_cou = 0;

    for $colour_item ( @colours_used ) {

        $colour_cou += 1;
        $colours_order{$colour_cou} = $colour_item;
    #    print "cou <$colour_cou> order <$colours_order{$colour_cou}>\
+n"; 
    }

    $do_update  = 'yes';

}

# ordering based on colour value
# check that acceptable contents

if($do_update eq 'no') {

print "ord 1 <$ord1_str> 2<$ord2_str> 3<$ord3_str>\n";

$err_message = '';

for($j = 0; $j <= 2; $j ++) {

    if($ord1_str =~ m/$brgb[$j]/ && $ord2_str =~ m/$brgb[$j]/) {

        $err_message .= "Orders 1 and 2 cannot have $brgb[$j]\n";

    }

    if($ord1_str =~ m/$brgb[$j]/ && $ord3_str =~ m/$brgb[$j]/) {

        $err_message .= "Orders 1 and 3 cannot have $brgb[$j]\n";

    }

    if($ord2_str =~ m/$brgb[$j]/ && $ord3_str =~ m/$brgb[$j]/) {

        $err_message .= "Orders 2 and 3 cannot have $brgb[$j]\n";

    }

}

# check that someting is there

if(length($ord1_str) == 0) {

    $err_message .= "something must be selected for 1st order\n";
}

if(length($ord2_str) == 0) {

    $err_message .= "something must be selected for 2nd order\n";
}

if(length($ord3_str) == 0) {

    $err_message .= "something must be selected for 3rd order\n";
}

if(length($err_message) == 0) {

    $do_update  = 'yes';

# get order


    for($j = 0; $j <= 2; $j ++) {

        if($ord1_str =~ m/$brgb[$j]/) {

            $ord1_col = lc($brgb[$j]);
        }

        if($ord2_str =~ m/$brgb[$j]/) {

            $ord2_col = lc($brgb[$j]);
        }

        if($ord3_str =~ m/$brgb[$j]/) {

            $ord3_col = lc($brgb[$j]);
        }

    }

    for($j = 0; $j <= 1; $j ++) {

        if($ord1_str =~ m/$dir[$j]/) {

            $ord1_dir = $dir[$j];
        }

        if($ord2_str =~ m/$dir[$j]/) {

            $ord2_dir = $dir[$j];
        }

        if($ord3_str =~ m/$dir[$j]/) {

            $ord3_dir = $dir[$j];
        }

    }


    print " 1 <$ord1_col> <$ord1_dir> 2 <$ord2_col> <$ord2_dir> 3 <$or
+d3_col> <$ord3_dir>\n";


    undef %cx;

    for $colour_item ( @colours_used ) {

        $clnu = '';

        get_col_v($ord1_col, $ord1_dir, $colour_item, \$col_inc);

        $clnu .= $col_inc;

        get_col_v($ord2_col, $ord2_dir, $colour_item, \$col_inc);

        $clnu .= $col_inc;

        get_col_v($ord2_col, $ord2_dir, $colour_item, \$col_inc);

        $clnu .= $col_inc;

        $cx{$clnu} = $colour_item;

#        print "colour <$colour_item> colnum <$clnu>\n";

    }

    $colour_cou = 0;


    foreach $j (sort {$a <=> $b} keys %cx) {

        $colour_cou += 1;

        $colours_order{$colour_cou} = $cx{$j};
    }



}

}



if($do_update eq 'yes') {

    colors(\$colour_pane, \@colours_used, \%colours_rgb, \%colours_ord
+er);    

}else {

    print "re-order not possible <$err_message\n";

}

}

#========================================================
#
# rgb_data
#
# this gives the rgb data for eany cell in which the mounse button is 
+pressed
#
#========================================================

sub rgb_data() {

my ($arg1, $arg2, $arg3, $arg4, $arg5, $arg6) = @_;

#print "\n[rgb_data] entered arg 1 <$arg1> 2 <$arg2> 3 <$arg3> 4 <$arg
+4> 5 <$arg5> 6 <$arg6>\n";

# create mesaage box to show resutls

my $ans = $mw->messageBox(-title => 'rgb values',
                    -message => "rgb values for $arg2 are\nred $arg3 g
+reen $arg4 blue $arg5",
                    -type => 'Ok');



}



#===========================================================

sub colour_set_choose() {   

my $colour_tot;   

$mentry_wg->configure(-text => $colour_use_menu);

undef @colours_used;

if($colour_use_menu eq 'Set 1') { 

    @colours_used =  @colours;

} elsif($colour_use_menu eq 'Set 2') { 

    @colours_used = @colours_wi;

} 

undef %colours_order;
$colour_cou = 0;

for $colour_item ( @colours_used ) {

    $colour_cou += 1;
    $colours_order{$colour_cou} = $colour_item;
#    print "cou <$colour_cou> order <$colours_order{$colour_cou}>\n"; 
}

$colour_tot = scalar(keys %colours_order);

print "\n[colour_set_choose] total colours <$colour_tot>\n";



colors(\$colour_pane, \@colours_used, \%colours_rgb, \%colours_order);



}


#=============================in-line==============================

$mw = MainWindow->new;

$wg_padx = 3;
$wg_pady = 3;


# create a scrolling frame - pane

$frm2_wg = $mw->Frame(-borderwidth => 3, -relief => 'raised') ->grid(
                -padx => $wg_padx,
                -pady => $wg_pady,
                -row     => 1,
                -column     => 0);;

# menu for order

$frm3_wg = $mw->Frame(-borderwidth => 3, -relief => 'raised') ->grid(
                -padx => $wg_padx,
                -pady => $wg_pady,
                -row     => 2,
                -column     => 0);

#to give the chocie of the colour set


# mensu to set the colur order dispaly


$menu1_wg = $frm2_wg->Menubutton(-text => '1st Order',
                -borderwidth => 2,
                -relief => 'raised'

                ) ->grid(
#                -sticky => $wg_sticky,
                -padx => $wg_padx,
                -pady => $wg_pady,
                -row     => 0,
                -column     => 2,
#                -columnspan => $pane_columnspan
                );

#foreach('Red Up', 'Red Down', 'Green Up', 'Green Down', 'Blue Up', 'B
+lue Down', 'Original', 'Alphabetical') {
foreach('Original', 'Alphabetical') {

    $menu1_wg->radiobutton(-label => $_,
                        -command =>  \&set_order1,
                        -variable => \$order1,
                        -value => $_);
}

$oentry1_wg = $frm2_wg->Entry(-width =>15)->grid(
#                -sticky => $wg_sticky,
                -padx => $wg_padx,
                -pady => $wg_pady,
                -row     => 0,
                -column     => 3,
#                -columnspan => $pane_columnspan
                );

# button to re-order the colours

$order_button = $frm2_wg->Button(-text => 'Re-order colours',
                        -command => \&reorder_colours_cb
                ) ->grid(
                -padx => $wg_padx,
                -pady => $wg_pady,
                -row     => 0,
                -column     => 8);


# initialsie scroll cou

$scr_wg_cou = 0;

# set first order to be as in the defntion array
$colour_cou = 0;

# set intial colours to set 1

@colours_used =  @colours;
#print "[main] oroginal colour order\n\n";

for $colour_item ( @colours_used ) {

    $colour_cou += 1;
    $colours_order{$colour_cou} = $colour_item;
#    print "cou <$colour_cou> order <$colours_order{$colour_cou}>\n"; 
}

#print "\n\n";


colors(\$colour_pane, \@colours_used, \%colours_rgb, \%colours_order);
+    

print "\n[main] colour pane <$colour_pane>\n\n";


Tk::MainLoop;
[download]