File Coverage

blib/lib/Image/Match.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

# $Id: Match.pm,v 1.4 2008/09/02 10:34:44 dk Exp $
package Image::Match;

use strict;
use warnings;
use Prima::noX11;
use Prima;
require Exporter;

our $VERSION = '1.02';
our $Y_GROWS_UPWARDS = 0;
our $DEBUG = 0;

sub match
{
        my ( $image, $subimage, %options) = @_;

	local $Y_GROWS_UPWARDS = $Y_GROWS_UPWARDS;
	mode($options{mode}) if exists $options{mode};

	$options{overlap} ||= 'some';
	die "Bad overlap mode '$options{overlap}': must be one of: none, some, all\n"
		unless $options{overlap} =~ /^(some|all|none)$/;
	my $overlap_all = $options{overlap} eq 'all';

        my $G   = $image-> data;
        my $W   = $image-> width;
        my $H   = $image-> height;
        my $w   = $subimage-> width;
        my $h   = $subimage-> height;
        my $bpp = ($image-> type & im::BPP) / 8;
	print STDERR
		"match image ($w x $h x ",
		$subimage-> type & im::BPP, ") in ",
		"($W x $H x ",
		$image-> type & im::BPP, ") ",
		"length ", length($G), "\n"
		if $DEBUG;

	# Requirements: need same bpp and same colormap.
	# Also, 1 and 4 bit images aren't supported, autoconvert
	if ( $bpp <= 1) {
		my $cm1 = join(',', $image->    colormap);
		my $cm2 = join(',', $subimage-> colormap);
		if ( $cm1 eq $cm2) {
			# good, palettes are equal. now, are types equal?
			if ( $subimage-> type != $image-> type) {
				$subimage-> type( $image-> type);
				printf STDERR ("subimage converted to type=%x\n", $image->type) if $DEBUG;
			}
		} else {
			# force convert to 24bits
			$image-> type(24);
			$subimage-> type(24);
			print STDERR "both images converted to 24 bpp\n" if $DEBUG;
		}
	}

        my $I   = $subimage-> data;
        my $gw  = int(( $W * ( $image->    type & im::BPP) + 31) / 32) * 4;
        my $iw  = int(( $w * ( $subimage-> type & im::BPP) + 31) / 32) * 4;
        my $ibw = $w * $bpp;
        my $dw  = $gw - $ibw;
	print "global=$gw, local=$iw, max=$ibw diff=$dw\n" if $DEBUG;

        my $rx  = join( ".{$dw}", map { quotemeta substr( $I, $_ * $iw, $ibw) }
                (0 .. $subimage-> height - 1));
        my ( $x, $y);
	my @ret;

	pos($G) = 0;
  	study $G;
	while ( 1) {
		if ( $DEBUG) {
			my $ap = pos($G);
			my $ax = $ap % $gw / $bpp;
			my $ay = int(($ap - ($ax + $w) * $bpp) / $gw);
			$ay = $H - $ay - 1 if $Y_GROWS_UPWARDS;
			print STDERR
				"begin match at $ap = $ax $ay, ",
				length($G) - $ap, " bytes left\n";
		}

		# match
	        unless ( $G =~ m/\G.*?$rx/gcs) {
			print STDERR "-> negative\n" if $DEBUG;
			return unless $options{multiple};
			last;
		}
		my $p = pos($G);
		$x = ($p - $w * $bpp) % $gw / $bpp;
		$y = int(($p - ( $x + $w) * $bpp) / $gw) + 1;
		$y = $y - $h;
		$y = $H - $h - $y unless $Y_GROWS_UPWARDS;
		print STDERR "-> positive at $p = $x $y\n" if $DEBUG;

		if ( $x + $w > $W) {
			print STDERR "-> scanline wrap, skipping\n" if $DEBUG;
			next;
		}
		pos($G) -= ($h - 1) * $gw;
		pos($G) -= $ibw - $bpp if $overlap_all;

		# store results
		push @ret, $x, $y;
		return $x, $y unless $options{multiple};
	}

	# filter output
	if ( $options{overlap} eq 'none') {
		my @r;
		my @ranges; # for each scanline store list of occupied pixels as x1-x2 ranges
		print STDERR "removing overlapped rectangles\n" if $DEBUG;
		RECT: for ( my $i = 0; $i < @ret; $i+=2) {
			my ( $x1, $y1) = @ret[$i, $i+1];
			my ( $x2, $y2) = ( $x1 + $w, $y1 + $h);
			print STDERR "checking ($x1,$y1)-($x2,$y2)\n" if $DEBUG;
			for ( my $y = $y1; $y < $y2; $y++) {
				$ranges[$y] ||= [];
				for my $xranges ( @{ $ranges[$y] }) {
					next if
						$x1 >= $xranges->[1] or
						$x2 <  $xranges->[0];
					print STDERR "-> overlaps, skipping\n" if $DEBUG;
					next RECT;
				}

				# does not overlap, register
				push @{ $ranges[$y] }, [ $x1, $x2 ];
			}
			push @r, $x1, $y1;
		}
		@ret = @r;
	}

	print STDERR "return: [@ret]\n" if $DEBUG;
	return @ret;
}

sub screenshot
{
	shift if defined($_[0]) and ( ref($_[0]) or ($_[0] =~ /Image/) );

	unless ( $::application) {
		my $error = Prima::XOpenDisplay();
		die $error if defined $error;
		require Prima::Application;
		import Prima::Application;
	}

	my ( $x, $y, $w, $h) = @_;
	my @as = $::application-> size;

	$x ||= 0;
	$y ||= 0;
	$w = $as[0] unless defined $w;
	$h = $as[1] unless defined $h;

	$y = $as[1] - $h - $y unless $Y_GROWS_UPWARDS;

	return $::application-> get_image( $x, $y, $w, $h);
}

sub mode
{
	shift if defined($_[0]) and ( ref($_[0]) or ($_[0] =~ /Image/) );
	return $Y_GROWS_UPWARDS ? 'geom' : 'screen' unless @_;
	die "bad Image::Match::mode: must be 'geom' or 'screen'\n"
		unless $_[0] =~ /^(geom|screen)$/;
	$Y_GROWS_UPWARDS = $_[0] eq 'geom';
}

*Prima::Image::match = \&match;
*Prima::Image::screenshot = \&screenshot;

1;

=pod

=head1 NAME

Image::Match - locate an image inside another

=head1 DESCRIPTION

The module searches for occurencies of an image inside of a larger image.

The interesting stuff here is the image finding itself - it is done by a regex!
For all practical reasons, regexes operate on strings of bytes, and images can
be easily treated as such. For example, one needs to locate an image 2x2 in a
larger 7x7 image. The constructed regex should contain the first scanline of
the smaller image, 2 bytes, verbatim, then match 7 - 2 = 5 of any byte found,
and finally the second scanline, 2 bytes again. Of course there are some
quirks, but these explained in the API section.

The original idea was implemented in L and L, but
this module extracts the pure matching logic, unburdened from wrappers that
were needed back then for matters at hand.

=head1 SYNOPSIS

  use strict;
  use Image::Match;

  # make screenshot
  my $big = Image::Match-> screenshot;
  # extract 70x70 image
  my $small = $big-> extract( 230, $big-> height - 70 - 230, 70, 70);
  # save
  $small-> save('1.png');
  # load
  $small = Prima::Image-> load('1.png') or die "Can't load: $@";
  # find again
  my ( $x, $y) = $big-> match( $small);
  print defined($x) ? "found at $x:$y\n" : "not found\n";

=head1 API

=over

=item match $IMAGE, $SUBIMAGE, %OPTIONS

Locates a $SUBIMAGE in $IMAGE, returns one or many matches, depending on
C<$OPTIONS{multiple}>.  If single match is requested, stops on the first match,
and returns a single pair of (X,Y) coordinates. If C<$OPTIONS{multiple}> is 1,
returns array of (X,Y) pairs. In both modes, returns empty list if nothing was
found.

C<$OPTIONS{mode}> overrides global C.

C<$OPTIONS{overlap}> can be set to one of three values: I, I,
I, to determine how the overlapping matches are reported when
C<$OPTIONS{multiple}> is set.  I will never report overlapping rectanges,
and I report all possible occurencies of C<$SUBIMAGE> in C<$IMAGE>.
I is similar to I, but is a bit faster, and will not report
overlapping rectangles that begin on the same scanline. I is also the
default overlapping mode.

=item screenshot [ $X = 0, $Y = 0, $W = screen width, $H = screen height ]

Returns a new C object with a screen shot, taken at
given coordinates.

=item mode $MODE = 'screen'

The module uses L for imaging storage and manipulations. Note that Prima
uses coordinate system where Y axis grows upwards. This module however can use
both geometrical (Y grows upwards, C) and screen-based (Y grows
downwards, C) modes. The latter mode is the default.

=back

=head1 NOTES

On unix, C by default will start X11. The module changes that behavior,
so X11 connection is not needed. If your code though needs X11 connection,
change that by adding

   use Prima;

before invoking

   use Image::Match

See L for more information.

If you need to use other image backends than Prima, that can be done too.
There is L that brings together Prima and ImageMagick,
and there is L, that does the same for PDL. GD, Imglib2, and
Imager, those we can't deal much with, except for saving to and loading from png
files.

=head1 SEE ALSO

L, L, L

=head1 LICENSE AND COPYRIGHT

This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 AUTHOR

Dmitry Karasik, [e-mail].

=cut