Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW
 
PerlMonks  

Tk ImageMap-color-zones

by zentara (Archbishop)
on Feb 22, 2004 at 12:48 UTC ( #330927=snippet: print w/ replies, xml ) Need Help??

Description: Updated jan 07,2007. I wrote this under an older version of Imager, but newer versions have "tightened up the ship", and this script failed because of cropping size problems. (I inadvertently tried to crop from where there was no image :-) )

Anyways, some minor changes fixed this, and it has been tested with Perl5.8.8 and Imager-0.55

Hi, this snippet builds on my snippet at Tk ImageMap

This version adds "clickable color zones", done by shading the tiles with a red or green tint. screenshot

Left click=>green; Right click=>red; Both click=>clear.

It could be useful for identifying "hot spots" on map.

#!/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;
Comment on Tk ImageMap-color-zones
Download Code

Back to Snippets Section

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://330927]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (4)
As of 2014-07-12 14:16 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    When choosing user names for websites, I prefer to use:








    Results (240 votes), past polls