#!/usr/bin/perl
use warnings;
use strict;
use Imager;
use Tk;
use Tk::JPEG;
use MIME::Base64;

my %tiles;
my $file = shift || die "need jpg filename\n";

my $tempname = $file;
$tempname =~ s/^(.+)(\.\w+)$/$1/;
print "$tempname\n";

#set tile size adjustment
my $x = 50;    #must be same
my $y = 50;

my $image = Imager->new();
$image->open( file => $file, type => 'jpeg' ) or die $image->errstr();
my $width  = $image->getwidth();
my $height = $image->getheight();
print "width->$width   height->$height\n";

my $mw = MainWindow->new;
$mw->geometry('+100+100' );
my $canvas = $mw->Scrolled(
    'Canvas',
    -bg     => 'grey',
    -width  => $width,
    -height => $height,
)->pack(-expand=>1,-fill=>'both');

$mw->Button(
    -text    => 'Exit',
    -command => sub {
            Tk::exit;
    }
)->pack();

my $rows = int( $height / $y + 1 ) - 1;    #make it 0 based
my $cols = int( $width / $x + 1 ) - 1;
#print "rows->$rows  cols->$cols\n";

foreach my $row ( 0 .. $rows ) {
    foreach my $col ( 0 .. $cols ) {
        my $imageout = Imager->new( xsize => $x, ysize => $y, type => 
+'direct' );

        $imageout = $image->crop(
            left   => $col * $y,
            right  => $col * $y + $y,
            top    => $row * $x,
            bottom => $row * $x + $x,
    );

        $imageout->write(
            type => 'jpeg',
            data => \$tiles{'c'}{$row}{ $col }
        );
        my $imagered = $imageout->copy();
        my $imageyel = $imageout->copy();

        my @map = map { int( $_ / 2 ) } 0 .. 255;
        $imageout->map( red => \@map );    #green tint
        $imageout->write(
            type => 'jpeg',
            data => \$tiles{'g'}{$row}{ $col }
        );

        $imageyel->map( blue => \@map );    #yellow tint
        $imageyel->write(
            type => 'jpeg',
            data => \$tiles{'y'}{$row}{ $col }
        );

        $imagered->map( green => \@map );    #red tint
        $imagered->write(
            type => 'jpeg',
            data => \$tiles{'r'}{$row}{ $col }
        );

        #or warn $imageout->errstr;

        $tiles{'c'}{$row}{$col} = encode_base64( $tiles{'c'}{$row}{ $c
+ol } );
        $tiles{'g'}{$row}{$col} = encode_base64( $tiles{'g'}{$row}{ $c
+ol } );
        $tiles{'y'}{$row}{$col} = encode_base64( $tiles{'y'}{$row}{ $c
+ol } );
        $tiles{'r'}{$row}{$col} = encode_base64( $tiles{'r'}{$row}{ $c
+ol } );

        $tiles{$row}{$col} = $canvas->createImage(
            $col * $x, $row * $y,
            -image  => $mw->Photo( -data => $tiles{'c'}{$row}{$col} ),
            -anchor => 'nw',
        );

        $tiles{'rect'}{$row}{$col} = $canvas->createRectangle(
            $col * $x, $row * $y, $col * $x + $x, $row * $y + $y,
            -width   => 0,
            -outline => 'black',
           -state   => 'disabled'  #didn't need this in earlier versio
+ns
    );
        $canvas->bind(
            $tiles{$row}{$col},
            '<Enter>',
            sub {

                if ( defined $tiles{'set'}{$row}{$col} ) {
                    print "Entered $row $col\n";
                    return;
                }
                else {
                    $canvas->itemconfigure( $tiles{$row}{$col},
                        -image =>
                          $mw->Photo( -data => $tiles{'y'}{$row}{ $col
+ } ), );

                    $canvas->itemconfigure(
                        $tiles{'rect'}{$row}{$col},
                        -outline => "yellow",
                        -width   => 2
                    );
                    print "Entered $row $col\n";
                }
            }
        );

        $canvas->bind(
            $tiles{$row}{$col},
            '<Button-1>',
            sub {
                $canvas->itemconfigure( $tiles{$row}{$col},
                    -image => $mw->Photo( -data => $tiles{'g'}{$row}{ 
+$col } ), );

                $tiles{'set'}{$row}{$col} = 'g';

                $canvas->itemconfigure(
                    $tiles{'rect'}{$row}{$col},
                    -outline => "green",
                    -width   => 2
                );
            }
        );

        $canvas->bind(
            $tiles{$row}{$col},
            '<Button-3>',
            sub {
                $canvas->itemconfigure( $tiles{$row}{$col},
                    -image =>$mw->Photo( -data => $tiles{'r'}{$row}{ $
+col } ), );

                $tiles{'set'}{$row}{$col} = 'r';

                $canvas->itemconfigure(
                    $tiles{'rect'}{$row}{$col},
                    -outline => "red",
                    -width   => 2
                );
            }
        );

        $canvas->bind(
            $tiles{$row}{$col},
            '<Button-2>',
            sub {
                $canvas->itemconfigure( $tiles{$row}{$col},
                    -image =>$mw->Photo( -data => $tiles{'c'}{$row}{ $
+col } ), );

                $tiles{'set'}{$row}{$col} = undef;

                $canvas->itemconfigure(
                    $tiles{'rect'}{$row}{$col},
                    -outline => "yellow",
                    -width   => 2
                );
            }
        );

        $canvas->bind(
            $tiles{$row}{$col},
            '<Leave>',
            sub {
                if ( defined $tiles{'set'}{$row}{$col} ) { return }
                else {
                    $canvas->itemconfigure( $tiles{$row}{$col},
                        -image =>$mw->Photo( -data => $tiles{'c'}{$row
+}{ $col } ), );

                    $canvas->itemconfigure(
                        $tiles{'rect'}{$row}{$col},
                        -outline => 'black',
                        -state   => 'disabled',
                        -width   => 0,
                    );
                }
            }
        );
        $canvas->update;
    }
}
undef $image;
MainLoop;
[download]

---

---

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

• How do I compose an effective node title?
• How do I post a question effectively?
• Markup in the Monastery

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		&
	<		&lt;
	>		&gt;
	[		&#91;
	]		&#93;

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.