#!/usr/bin/perl --
##
##
##
## perltidy -olq  -csc -csci=3 -cscl="sub : BEGIN END " -otr -opr -ce 
+-nibc -i=4 -pt=0   "-nsak=*"
##
#!/usr/bin/perl --
use strict;
use warnings;

use Tk;

Main( @ARGV );
exit( 0 );

sub Main {
    my @set = qw/ 2 6 A E/;
    my $mw = tkinit( -title => "Print out the canvas" );
    my $dad = $mw;
    Feh( $dad, [qw/-row 0 -column 0/], colorsFromSet( @set ) );
    Feh( $dad, [qw/-row 0 -column 1/], Lumated( @set ) );
    Feh( $dad, [qw/-row 1 -column 0/], Fudgy( @set ) );
    Feh( $dad, [qw/-row 1 -column 1/], FudgyLum( @set ) );
    $mw->MainLoop;
} ## end sub Main

sub Feh {
    my( $mw, $popt, @feh ) = @_;
    
    my $canvas = $mw->Canvas( -background => '#ffffff', )->grid( @$pop
+t );

    for my $i ( 1 .. @feh ) {
        my $color = $feh[ -1 + $i ];
        drLine( $canvas, $i, $color );
    }
} ## end sub Feh

sub Lumated {
    my @colors = colorsFromSet( @_ );
    return
      map { $$_[1] }
      sort { $$a[0] <=> $$b[0] } map { [ luma( $_ ), $_ ]; } @colors;
} ## end sub Lumated

sub FudgyLum {
    my @final;
    my @them = Lumated( @_ );
    while( my @dd = splice @them, 0, 16 ) {
        my @new;
        while( @dd ) {
            push @new, shift @dd;
            push @new, pop @dd;
        }
        push @final, @new;
    }
    @final;
} ## end sub FudgyLum

sub Fudgy {
    my @final;
    my @them = colorsFromSet( @_ );
    while( my @dd = splice @them, 0, 16 ) {
        my @new;
        while( @dd ) {
            push @new, shift @dd;
            push @new, pop @dd;
        }
        push @final, @new;
    }
    @final;
} ## end sub Fudgy

sub drLine {
    my( $canvas, $x, $color ) = @_;
    my $x1 = $x * 5;
    my $y1 = 0;

    my $x2 = $x1 + 180;
    my $y2 = 420;

    $canvas->createLine(
        $x1, $y1, $x2, $y2,
        -fill  => $color,
        -arrow => 'first',
        -smooth, 1, -splinesteps, 9999, -arrowshape => [ $y2, 25, 1 ]
    );
} ## end sub drLine

sub colorsFromSet {
    my @set = @_;
    my @colors;
    for my $r ( @set ) {
        for my $g ( @set ) {
            for my $b ( @set ) {
                push @colors, "#$r$g$b";
            }
        }
    }
    return @colors;
} ## end sub colorsFromSet

sub contraColor {
    my( $color ) = @_;
    return( luma( $color ) >= 165 ) ? '000' : 'fff';
} ## end sub contraColor

sub hexToRgb {
    my( $color ) = @_;
    my( $rr, $gg, $bb ) = $color =~ m{^#?(.?.?)(.?.?)(.?.?)};
    no warnings 'numeric';
    $_ = int unpack 'HH', $_ for( $rr, $gg, $bb );

#~     return [ $rr, $gg, $bb ];
    return $rr, $gg, $bb;
} ## end sub hexToRgb

sub luma {
    my( $color ) = @_;
    my @rgb = ref $color ? @$color : hexToRgb( $color );
## // SMPTE C, Rec. 709 weightings
    return( 0.2126 * $rgb[0] ) + ( 0.7152 * $rgb[1] ) + ( 0.0722 * $rg
+b[2] );
} ## end sub luma

__END__
[download]