#!/usr/bin/perl
use warnings;
use strict;
use Tk;

my @colors;

# generate colors from BrowserUk's subs in  
# http://perlmonks.org?node_id=724491
sub rgb2n{ unpack 'N', pack 'CCCC', 0, @_ }

my( $r, $g, $b ) = (0) x 3;
for my $step ( 0 .. 1784 ) {
    if(    $step <  255 ) { ++$b; }
    elsif( $step <  510 ) { ++$g; }
    elsif( $step <  765 ) { --$b; }
    elsif( $step < 1020 ) { ++$r; }
    elsif( $step < 1275 ) { --$g; }
    elsif( $step < 1530 ) { ++$b; }
    else                  { ++$g; }

#print "$r $g $b\t";
 my $hexcurrent = '#'.sprintf('%.2x', $r).sprintf('%.2x', $g).sprintf(
+'%.2x', $b); 
# print "$hexcurrent\n";
push @colors,$hexcurrent;
 
}

my %map = (
     255 => sub{         0,             0,   $_[0] * 255 },
     510 => sub{         0,     $_[0]*255,           255 },
     765 => sub{         0,           255, (1-$_[0])*255 },
    1020 => sub{ $_[0]*255,           255,             0 },
    1275 => sub{       255, (1-$_[0])*255,             0 },
    1530 => sub{       255,             0,     $_[0]*255 },
    1785 => sub{       255,     $_[0]*255,           255 },
);

my @map = sort{ $a <=> $::b } keys %map;

sub colorRamp1785 {
    my( $v, $vmin, $vmax ) = @_;
    $v = $vmax if $v > $vmax;
    $v = $vmin if $v < $vmin;
    $v = ( $v - $vmin ) / ( $vmax - $vmin );
    $v *= 1785;

    $v < $_ and return rgb2n( $map{ $_ }->( $v ) ) for @map;
}
######################################3
#print "\n",join "\n", @colors,"\n";
#print scalar @colors,"\n";

my $mw=tkinit;

$mw->fontCreate('big',
   -family=>'arial',
   -weight=>'bold',
   -size=> 38
   );

my $bfr = $mw->Frame()->pack(-fill=>'x');
my $cur_color = '#      ';
my $lab = $bfr->Label(-textvariable => \$cur_color,
             -font => 'big',
           )->pack();

my $sc = $mw->Scrolled('Canvas',
            -bg=>'white',
            -scrollbars=>'s',
            )->pack(-expand=>1,-fill=>'x',-padx=>10);
my $realcanvas = $sc->Subwidget('scrolled');

my $x = 0; 
foreach my $color(@colors) {
    my $line = $realcanvas->createLine($x,0,$x, 250,
            -fill=> $color,
            -tags => [$color,'line']
          );
  $x++; 

$realcanvas->bind("line", "<Enter>", 
         sub { 
             my (@tags) = $realcanvas->gettags('current');
             $cur_color = $tags[0];
             });


}
#print "$x\n";
$realcanvas->configure(-scrollregion=>[$realcanvas->bbox("all")]);

MainLoop;
__END__
[download]