Experimental Image::BoxFind module: Image/BoxFind.pm
package Image::BoxFind;
use base qw( Class::Base );
=head1 NAME
Image::BoxFind - scan for rectangles inside of images
=head1 SYNOPSIS
use Image::BoxFind;
my $bf = Image::BoxFind->new({ image_file = "/tmp/menu.jpeg" });
my $count = $bf->count_rectangles; # NOT YET IMPLEMENTED
my ($image_width, $image_height) = $bf->dimensions();
my $bg_color = $bf->background_color();
TODO demo the other routines: "scan"s and so on.
=head1 DESCRIPTION
Image::BoxFind is an OOP module to pick out rectangular shapes
from inside of an image.
The theory is that scanning for rectangles inside of images is
useful for automating tests of graphical user interfaces.
Note: the "rectangles" of interest here are aligned with the
x and y axes.
=head2 concepts
=over
=item rectangle (or "box") data structure
For convenience, a rectangle is represented here as
a list of the four corners, where each corner is a
point (i.e. a list of the two x and y values).
The corners are listed in the following order:
1 2
---------------
| |
| |
| |
---------------
4 3
So, a "list of rectangles" is an aref of arefs of arefs.
To verify that one of these figures truly is a rectangle,
we first check that the corners are (roughly) lined up
horizontally and vertically:
y1 == y2
x2 == x3
y3 == y4
x1 == x4
(and if the corners were found with the "follow*" routines
the edges should be simple straight horizontals and verticals).
=item point
By a "point", we mean two x and y values that specify a pixel in
the image. An array reference.
=item Image::Magick color representation
Where possible, we work with color values in the native
Image::Magick format: a comma-seperated string of decimals:
rr,gg,bb,t
(The fourth entry is 'alpha' or 'transparency' or something like
that: often it's just zero).
=item location cursor
This code maintains a "cursor" location inside of the image:
cursor_x and cursor_y, though most routines accept explicit
coordinates as arguments.
=item spot
The "cursor" points to a single pixel, but we often focus on a
larger area near the cursor, a rectangular region called the
spot. This is a rectangle as defined by two settable parameters
"spotsize_x" and "spotsize_y" (though the spot may be truncated
when near an image boundary: L<spot_bounds_truncated>).
For the sake of simplicity: the cursor is the upper-left hand
corner of the spot.
=item threshold
There are multiple threshold settings for
determining whether a difference in color
is significance. Different values are needed for
different ways of measuring color difference
(luminence, color distance, etc.).
=item fuzziness
Spatial "fuzziness": when two things are almost on top of
each other, we'll consider them to be in the same place.
This parameter controls the cut-off for significance in
spatial difference.
=item pixpat or "pixel pattern"
The pixpat (short for "pixel pattern") summarizes the matrix of
colors in the spot by averaging them in the direction of travel
to get an array of colors. So, the number of colors in the
pixpat array is the width of the spot in the transverse
direction. The family of "follow_*" methods typically look for
changes in the "pixpat" in an attempt at tracking the edge of a
rectangle.
=item horizon
Rather than work with a fixed width and height spotsize, some methods
here can use a "forward_horizon" and "transverse_horizon" to get an
assymetric spotsize who's orientation flips depending on the direction
the cursor is being scanned.
=back
=head1 METHODS
=head2 initialization methods
=over
=cut
use 5.8.0;
use strict;
use warnings;
use Carp;
use Data::Dumper;
use YAML;
use Hash::Util qw( lock_keys unlock_keys );
use List::MoreUtils qw( pairwise all any);
use List::Util qw( max reduce );
use Image::Magick;
# A package variable: used with *every* Image::Magick call.
my $err;
our $VERSION = 0.01;
my $DEBUG = 1;
# needed for accessor generation
our $AUTOLOAD;
my %ATTRIBUTES = (); #'
# TODO the following pod should really list the defaults for
# all these items, but since I keep changing them, I'd rather
# not.
=item new
Creates a new Image::BoxFind object, taking a hashref as an argument, with named
fields identical to the names of the object attributes. Either the attribute
B<image_file> or B<imh> is required.
Inputs:
An optional hashref, with named fields identical to the names
of the object attributes. The attributes, in order of likely
utility:
=over
=item image_file
The name of the file you intend to scan. This is required,
unless an Image::Magick image object is passed in instead (see
B<imh> attribute)
=item imh
The "image handle": an Image::Magick image object either created
internally using the B<image_file> attribute, or passed in as an
argument. (( This is stupid. Require the fucking filename! ))
=item luminance_threshold
Cutoff for significance in color luminance differences.
Defaults to 3500.
=item color_distance_threshold
Cutoff for significance in color distance differences.
Defaults to 10.
=item pixpat_threshold
Threshold of ignorable change in the "pixel pattern".
Used by L<has_pixpat_changed_past_threshold>
=item ignore_subtle_pixpat_change
With this flag on and a smaller pixpat_threshold, *sudden*
changes should be detected but a gradual drift in the appearence
of a border (e.g. a shading effect) might be ignored.
The various 'follow_*' methods that look for changes in the
"pixpat" by
can compare either (1) the current one to the original one at the
start of the follow operation or (2) (the default) with
"ignore_subtle_pixpat_change" set to a true value, then instead
it will compare the current pixpat to the immediately previous
one. Since a threshold of ignorable change is allowed (see
"pixpat_threshold" above), this allows for a shifting standard
with a smaller defined threshold.
Default: on.
=item edge_contrast_cutoff
Minimum difference between min and max color distance in the
colors of a pixpat before it becomes at all plausible the pixpat
represents an edge. Used by L<looks_like_edge>.
=item direction
A direction code: 'x_plus', 'x_minus', 'y_plus', or 'y_minus'
=item forward_horizon
Size of the spotsize in the direction of travel of the cursor.
(Only used by some methods).
Overrides spotsize_x and spotsize_y settings.
=item transverse_horizon
Size of the spotsize in the transverse direction.
(Only used by some methods).
Overrides spotsize_x and spotsize_y settings.
=item spotsize_x
Width of the "spot", the region examined at the cursor. INTERNAL USE ONLY.
("horizon" values are swapped in by "set_direction").
=item spotsize_y
Height of the "spot", the region examined at the cursor. INTERNAL USE ONLY.
("horizon" values are swapped in by "set_direction").
=item fuzziness
A spatial fuzziness parameter. Default: 4.
=item refocus_factor
The routine L<center_on_edge> looks beyond the boundaries of the
spot in an attempt at repositioning the spot with any nearby edge
moved toward it's center. The B<refocus_factor> is the factor
applied to the spot dimension, to determine how widely the
L<center_on_edge> method (and similar methods) will range in
looking for the edge. Default: 4 ((TODO still? Make smaller?))
=item delta_colordist_threshold
Much like the various other thresholds: used by L<center_on_edge>
to skip recentering if there isn't very much color variation
going on nearby. Default: 10
=item step_back
Some operations here back off slightly from an edge (to stay away
from blurred corners and so on). This is a standard step size for
this purpose. Default: 3.
Note: there's no association between L<step_back> and the following
two "step_*".
=item step_x
Horizontal step size for routines that raster across the entire image,
ala L<roughly_raster_for_rectangular_regions>.
=item step_y
Vertical step size for routines that raster across the entire image,
ala L<roughly_raster_for_rectangular_regions>.
=item beware
When you keep running into the wall despite your best efforts
to stop short, you can deploy "beware" throughout your code
to gain an extra margin of safety. I.e. this is a total hack.
Defaults to 10, unless I change it.
Empirically determined it needs to be at least 8 (for *some*
settings, e.g. spotsize of 5?) or "roughly_raster" doesn't.
=item cursor_x
X-coordinate of an internally used "cursor", pointing at a pixel
of the image.
=item cursor_y
Y-coordinate of an internally used "cursor", pointing at a pixel
of the image.
=item image_height
Image_Height of the image (i.e. the maximum "y" value plus one)
=item image_width
Image_Width of the image (i.e. the maximum "x" value plus one)
=item background_color
The background color of the image, as determined by the
L<background_color> method.
=item minimum_height
Minimum allowed width for a rectangle. Default 12.
=item minimum_width
Minimum allowed height for a rectangle. Default 12.
=item color_diff
The name of the method used internally to determine
if color has changed significantly. May be one of:
=over
=item has_changed_luminence (default)
=item has_changed_distance
=item has_changed_peculiar (deprecated)
=back
=item rectangle_finder
The name of a method used internally to find a rectangle
somewhere in the image. Used by routines such as
L<roughly_raster_for_rectangular_regions>. The value may be one
of:
=over
=item look_down_boxfind
=item boxfind_downward_via_pixpat
=item boxfind_upward_via_pixpat
=item boxfind_downward_purely_via_pixpat
=item boxfind_downward_recenter
=back
=back
=item finder_of_rectangles
The name of a method used internally to find some rectangles (plural)
somewhere in the image. A variant of the above B<rectangle_finder>
that holds open the possibility of finding more than one rectangle
at once.
Used by routines such as L<smarter_sweep_for_squarish_shapes>,
but not it's predecessor: L<smart_sweep_for_squarish_shapes>
The value may be one of:
=over
=item boxfind_downward_recenter
=back
=item change_detector
A further generalization of the notion behind
the above L<color_diff>. The name of the method
to be used to detect a change. EXPERIMENTAL.
Used by L<detected_change>, which is not yet in use
(and probably never will be). TODO
=item previous_state
This may be used by the above L<change_detector>,
a way to keep the data that change_detector will
compare the current state to. Note: may be anything,
a scalar value or a ref to any data structure.
=item color
Color of annotations made to images. Typically 'red' or 'green'.
=cut
# Note: "new" is inherited from Class::Base and
# calls the following "init" routine automatically.
=item init
Method that initializes object attributes and then locks them down to prevent
accidental creation of new ones.
Any class that inherits from this one should have an B<init> of
it's own that calls this B<init>. Otherwise, it's an internally
used routine that is not of much interest to client coders.
=cut
sub init {
my $self = shift;
my $args = shift;
unlock_keys( %{ $self } );
# enter object attributes here, including arguments that become attributes
my @attributes = qw(
cursor_x
cursor_y
imh
image_file
image_height
image_width
background_color
spotsize_x
spotsize_y
forward_horizon
transverse_horizon
DEBUG
luminance_threshold
color_distance_threshold
pixpat_threshold
fuzziness
refocus_factor
delta_colordist_threshold
step_back
edge_detect
color_diff
rectangle_finder
finder_of_rectangles
minimum_width
minimum_height
step_x
step_y
beware
previous_state
change_detector
direction
pixpat_delta_method
ignore_subtle_pixpat_change
edge_contrast_cutoff
color
);
foreach my $field (@attributes) {
$ATTRIBUTES{ $field } = 1;
$self->{ $field } = $args->{ $field };
}
lock_keys( %{ $self } );
$self->init_imh;
$self->dimensions; # defines image_height and image_width
my $image_height = $self->image_height;
my $image_width = $self->image_width;
# look at a 5x5 spot, unless told otherwise
# $self->set_spotsize_x( 5 ) unless $self->spotsize_x;
# $self->set_spotsize_y( 5 ) unless $self->spotsize_y;
# currently, this overrides the above...
$self->set_forward_horizon( 3 ) unless $self->forward_horizon;
$self->set_transverse_horizon( 5 ) unless $self->transverse_horizon;
# Use "set_direction" to force horizon values to be swapped in for spotsize
my $default_direction = $self->direction || 'y_plus';
$self->set_direction( $default_direction );
# put cursor at (0,0), unless told otherwise
$self->set_cursor_y( 0 ) unless $self->cursor_y;
$self->set_cursor_x( 0 ) unless $self->cursor_x;
$self->set_luminance_threshold( 3500 )
unless $self->luminance_threshold;
$self->set_color_distance_threshold( 10 )
unless $self->color_distance_threshold;
$self->set_edge_contrast_cutoff( 2 )
unless $self->edge_contrast_cutoff;
$self->set_pixpat_threshold( 500 )
unless $self->pixpat_threshold;
$self->set_ignore_subtle_pixpat_change(1) unless defined( $self->ignore_subtle_pixpat_change );
# Note: any larger than 4 will break a test in 02-is_dupe_box-uniq_boxes-sort_boxes.t
$self->set_fuzziness( 4 ) unless defined( $self->fuzziness );
$self->set_step_back( 3 ) unless defined( $self->step_back );
$self->set_minimum_height( 10 ) unless defined( $self->minimum_height );
$self->set_minimum_width( 10 ) unless defined( $self->minimum_width );
$self->set_step_x( 10 ) unless $self->step_x;
$self->set_step_y( 10 ) unless $self->step_y;
$self->set_beware( 5 ) unless $self->beware;
$self->set_refocus_factor( 2 ) unless defined( $self->refocus_factor );
$self->set_delta_colordist_threshold( 10 ) unless defined( $self->delta_colordist_threshold );
$self->set_color_diff('has_changed_distance')
unless $self->color_diff;
$self->set_rectangle_finder('boxfind_downward_recenter')
unless $self->rectangle_finder;
$self->set_finder_of_rectangles('boxfind_here_or_downward')
unless $self->finder_of_rectangles;
$self->set_color( 'red' )
unless $self->color;
if (my $radius = $self->edge_detect) {
$self->apply_edge_detect( $radius );
}
if( $self->DEBUG ) {
$self->debugging(1); # activates "debug" method
}
$DEBUG = $self->DEBUG; # activates ($DEBUG) && constructs
return $self;
}
=item init_imh
Internally used routine. Initialize a new Image::Magick object using the file
specified by the "image_file" field.
=cut
sub init_imh {
my $self = shift;
unless( $self->imh ) {
my $imh = Image::Magick->new;
my $image_file = $self->image_file;
return unless $image_file;
$err = $imh->Read($image_file);
carp "$err" if "$err";
$self->{ imh } = $imh;
}
}
=back
=head2 whole image transforms
=over
=item apply_edge_detect
Applies the Image::Magick "Edge" image filter to the
current image, using the value of the B<edge_detect>
attribute as a "radius" argument.
=cut
# TODO this should ultimately use save_image_using_suffix
sub apply_edge_detect {
my $self = shift;
my $radius = shift || $self->edge_detect or return;
my $imh = $self->imh;
$err =
$imh->Edge( radius=>"$radius" );
carp "$err" if "$err";
# save a copy of the transformed image (but not
# if generation of output file name fails)
my $suffix = 'edgedet';
if (
( my $output_file = $self->image_file ) =~
s{ ^ (.*?) \. (.{3,4}) $ }
{$1-$suffix.$2}x
) {
$err =
$imh->Write($output_file);
carp "$err" if "$err";
}
}
=item save_image_using_suffix
Saves the current image under a modified name using
the given string as a "suffix" for a new file name,
and placing the new file in a sub-directory named
"output".
=cut
sub save_image_using_suffix {
my $self = shift;
my $suffix = shift;
unless ($suffix) {
croak "Will not save image without a suffix to distinguish from original";
}
my $imh = $self->imh;
# append suffix to filename (in front of extension)
( my $output_file = $self->image_file ) =~
s{ ^ (.*?) \. (.{3,4}) $ }
{$1-$suffix.$2}x;
# move output down a level into sub-dir called "output"
$output_file =~ s{ ^ (.*?) / ([^/]*) $ }
{$1/output/$2}x;
# save a copy of the image
$err =
$imh->Write($output_file);
carp "$err" if "$err";
}
=back
=head2 image info
Routines that get information about the entire image.
=over
=item dimensions
Determine (and stash) width and height of the image.
Returns array of width and height values.
=cut
sub dimensions {
my $self = shift;
my $imh = $self->imh;
return unless $imh;
my $y_bound = $imh->Get('height');
my $x_bound = $imh->Get('width');
$self->set_image_height( $y_bound );
$self->set_image_width( $x_bound );
return ($y_bound, $x_bound);
}
=item background_color
Determines the most common color in an image, and returns it in the native
Image::Magick form, a comma-seperated string of decimals:
rr,gg,bb,t
=cut
sub background_color {
my $self = shift;
my $imh = $self->imh;
my $y_bound = $self->image_height - 1;
my $x_bound = $self->image_width - 1;
my %count;
for my $x (0 .. $x_bound) {
for my $y (0 .. $y_bound) {
my $color_string = $imh->Get("pixel[$x,$y]");
$count{ $color_string }++;
}
}
# get count of each color sorted by count
my @top_colors;
foreach my $color ( sort { $count{$b} <=> $count{$a} } keys %count ) {
# printf "%10d: %s \n", $count{$color}, $color;
unshift @top_colors, $color unless $#top_colors > 10;
}
# Note, the top of the list there is the background color.
my $bg_color_string = pop @top_colors;
$self->set_background_color( $bg_color_string );
return $bg_color_string;
}
=back
=head2 geometry
Utility routines to do geometric calculations
=over
=item spot_bounds
Returns the coordinates of the upper-left and lower-right corners
of the spot at the given x, y location, or at the spot at the
cursor if the location is not specified.
Note: The spot is prevented from extending past the image boundaries,
erroring out if asked to do so.
=cut
sub spot_bounds {
my $self = shift;
my $x1 = shift || $self->cursor_x;
my $y1 = shift || $self->cursor_y;
my $x_bound = $self->image_width - 1;
my $y_bound = $self->image_height - 1;
my $spotsize_x = $self->spotsize_x;
my $spotsize_y = $self->spotsize_y;
my $x2 = $x1 + $spotsize_x - 1;
if ($x2 > $x_bound) {
$x2 = $x_bound;
confess "Spot at ($x1, $y1) hit the image x boundary: $x_bound";
}
my $y2 = $y1 + $spotsize_y - 1;
if ($y2 > $y_bound) {
$y2 = $y_bound;
confess "Spot at ($x1, $y1) hit the image y boundary: $y_bound";
}
return ($x1, $y1, $x2, $y2);
}
=item spot_bounds_truncated
Returns the coordinates of the upper-left and lower-right corners
of the spot at the given x, y location, or at the spot at the
cursor if the location is not specified.
Note: The spot is prevented from extending past the image boundaries,
it is silently truncated to keep it from doing so.
Example usage:
my ($x1, $y1, $x2, $y2) = $self->spot_bounds_truncated( $x0, $y0 );
=cut
sub spot_bounds_truncated {
my $self = shift;
my $x1 = shift || $self->cursor_x;
my $y1 = shift || $self->cursor_y;
my $x_bound = $self->image_width - 1;
my $y_bound = $self->image_height - 1;
my $spotsize_x = $self->spotsize_x;
my $spotsize_y = $self->spotsize_y;
my $x2 = $x1 + $spotsize_x - 1;
if ($x2 > $x_bound) {
$x2 = $x_bound;
}
my $y2 = $y1 + $spotsize_y - 1;
if ($y2 > $y_bound) {
$y2 = $y_bound;
}
return ($x1, $y1, $x2, $y2);
}
=item main_bounding
Calculate the effective x and y boundaries to be used by a
routines that move the "spot" though the entire image.
Example:
my ($x_bound, $y_bound) = $self->main_bounding;
=cut
sub main_bounding {
my $self = shift;
my $x_bound = $self->image_width - $self->spotsize_x - 2;
my $y_bound = $self->image_height - $self->spotsize_y - 2;
return ($x_bound, $y_bound);
}
=item looks_rectangular
Given four points, tries to determine if they (roughly) define
the corners of a rectangle, and if the rectangle is of a
significant size.
The object attribute "fuzziness" is used to determine how close
two locations need to be to be considered the same: the
differences in the x and y components both need to be less than
the fuzziness value.
The object attributes "minimum_width" and "minimum_height"
determine how wide and tall a rectangle is required to be.
=cut
# Identifying a rectangle, given corner coords:
# o--------------------------> x
# |
# | x1,y1 x2,y2
# |
# |
# | x4,y4 x3,y3
# |
# v y
# Looking for:
# x1 near x4, x2 near x3
# y1 near y2, y3 near y4
# And also:
# x1 away from x2 ( or x4 away from x3)
# y1 away from y4 ( or y2 away from y3)
sub looks_rectangular {
my $self = shift;
my $corners = shift;
# $self->debug( "rect: " . Dumper($corners) );
my $x1 = $corners->[0][0];
my $y1 = $corners->[0][1];
my $x2 = $corners->[1][0];
my $y2 = $corners->[1][1];
my $x3 = $corners->[2][0];
my $y3 = $corners->[2][1];
my $x4 = $corners->[3][0];
my $y4 = $corners->[3][1];
# define fuzziness/threshold/cutoffs...
# my $fz = 7; # "fuzziness"
my $fz = $self->fuzziness; # default is 4.
# required "seperation" between edges.
my $separation_x = $self->minimum_width;
my $separation_y = $self->minimum_height;
my ($corners_aligned, $edges_apart); # flags
if(
( abs($x1 - $x4) <= $fz ) &&
( abs($x2 - $x3) <= $fz ) &&
( abs($y1 - $y2) <= $fz ) &&
( abs($y3 - $y4) <= $fz )
) {
$corners_aligned = 1;
};
if(
( abs($x1 - $x2) > $separation_x ) &&
( abs($y1 - $y4) > $separation_y )
) {
$edges_apart = 1;
};
if( ( $corners_aligned && $edges_apart ) ) {
return 1;
} else {
return; # undef
}
}
=item looks_rectangular_any_size
Given four points, tries to determine if they (roughly) define the corners of a
rectangle.
This version makes no effort to throw away small fry. Rectangles
of any size qualify.
=cut
sub looks_rectangular_any_size {
my $self = shift;
my $corners = shift;
# $self->debug( "rect: " . Dumper($corners) );
my $x1 = $corners->[0][0];
my $y1 = $corners->[0][1];
my $x2 = $corners->[1][0];
my $y2 = $corners->[1][1];
my $x3 = $corners->[2][0];
my $y3 = $corners->[2][1];
my $x4 = $corners->[3][0];
my $y4 = $corners->[3][1];
my $fz = 7; # "fuzziness"
if(
( abs($x1 - $x2) <= $fz ) &&
( abs($x3 - $x4) <= $fz ) &&
( abs($y1 - $y4) <= $fz ) &&
( abs($y2 - $y3) <= $fz )
) {
return 1;
} else {
return; # undef
}
}
=back
=head2 color arithmetic
Utility routines to do color calculations
=over
=item luminence
Given a list of the RR GG BB values for a color, calculates
the luminence using the weighting factors defined in the
object: B<weights>. Note: luminence is an easily calculated
value that approximates the subjective impression of
brightness.
Example:
$l = luminence( $rr, $gg, $bb );
=cut
sub luminence {
my $self = shift;
my @rgb = @_;
my $luminence =
0.212671 * $rgb[0] +
0.715160 * $rgb[1] +
0.072169 * $rgb[2];
return $luminence;
}
=item has_changed
Compares the two given colors, and returns true if they're significantly
different, and false otherwise.
This is a wrapper method that makes it eaisier to swap in
different ways of calculating color differences. It defaults
to L<has_changed_distance>.
=cut
sub has_changed {
my $self = shift;
my $color1 = shift;
my $color2 = shift;
my $method = $self->color_diff;
my $ret = $self->$method( $color1, $color2 );
return $ret
}
=item has_changed_luminence
Compares the given two colors, and returns true if they're luminence is
significantly different, and false otherwise.
Example usage:
if(
$self->has_changed_luminence( $color, $ref_color);
) { print "Color has changed significantly\n";
last;
}
A "color" is the color string (as used by Image::Magick).
As written, this routine checks if the difference in luminence
exceeds the B<luminance_threshold>. It returns the value of the luminance
difference, or 0 (to indicate "false"), so this can be thought of
as a "luminence difference" routine, which rounds down to 0 if
below the luminance_threshold.
Note: as written, this ignores any changes in "alpha".
=cut
sub has_changed_luminence {
my $self = shift;
my $color1 = shift;
my $color2 = shift;
my $luminance_threshold = $self->luminance_threshold;
my ($rr1, $gg1, $bb1, $alph1) = split m/,/, $color1;
my ($rr2, $gg2, $bb2, $alph2) = split m/,/, $color2;
my $v1 = $self->luminence( $rr1, $gg1, $bb1 );
my $v2 = $self->luminence( $rr2, $gg2, $bb2 );
my $diff = abs( $v1 - $v2 );
if ($diff > $luminance_threshold) {
return $diff;
} else {
return 0;
}
}
=item has_changed_distance
Compares the given two colors, and returns true if they're color distance is
significantly different, and false otherwise.
Uses the L<color_distance_threshold> settting to determine
significance.
Note: as written, this ignores any changes in "alpha".
=cut
sub has_changed_distance {
my $self = shift;
my $color1 = shift;
my $color2 = shift;
my $color_distance_threshold = $self->color_distance_threshold;
my ($rr1, $gg1, $bb1, $alph1) = split m/,/, $color1;
my ($rr2, $gg2, $bb2, $alph2) = split m/,/, $color2;
my $distance =
sqrt(
( $rr1 - $rr2 ) ** 2 +
( $gg1 - $gg2 ) ** 2 +
( $bb1 - $bb2 ) ** 2
);
if ($distance > $color_distance_threshold) {
return $distance;
} else {
return 0;
}
}
=item has_changed_peculiar
Compares the given two colors, and returns true if they're color distance is
significantly (?) different, and false otherwise.
This is an older, poorly implemented version of a method intended
to use color distance. (Note: in perl '**' is expotentiation, not
'^'). It remains slightly possible that it does something useful
(for the wrong reasons).
Still uses the L<color_distance_threshold> settting to determine
significance.
Note: as written, this ignores any changes in "alpha".
=cut
sub has_changed_peculiar {
my $self = shift;
my $color1 = shift;
my $color2 = shift;
my $color_distance_threshold = $self->color_distance_threshold;
my ($rr1, $gg1, $bb1, $alph1) = split m/,/, $color1;
my ($rr2, $gg2, $bb2, $alph2) = split m/,/, $color2;
# Note: '**' is expotentiation, not '^'.
# So the following was el wrongo, but I'm preserving
# it here in case it was doing something "right"
# albeit for the wrong reasons.
my $distance =
sqrt(
( $rr1 - $rr2 ) ^ 2 +
( $gg1 - $gg2 ) ^ 2 +
( $bb1 - $bb2 ) ^ 2
);
if ($distance > $color_distance_threshold) {
return $distance;
} else {
return 0;
}
}
=back
=head2 probes
A probe examines conditions in a particular location.
=over
=item major_color
Returns the most common color of all the pixels in the spot.
Note: this need not be the "majority", just the "plurality".
=cut
sub major_color {
my $self = shift;
my $imh = $self->imh;
my $cursor_y = $self->cursor_y;
my $cursor_x = $self->cursor_x;
# my $spotsize_x = $self->spotsize_x;
# my $spotsize_y = $self->spotsize_y;
my ($x1, $y1, $x2, $y2) = $self->spot_bounds();
my %count;
for my $x ($x1 .. $x2) {
for my $y ($y1 .. $y2) {
my $color_string = $imh->Get("pixel[$x,$y]");
$count{ $color_string }++;
}
}
# get count of top colors sorted by count
my @top_colors;
foreach my $color ( sort { $count{$b} <=> $count{$a} } keys %count ) {
unshift @top_colors, $color unless $#top_colors > 10;
}
$self->debug( "Top colors are:\n " . join "\n ", @top_colors, "\n" );
my $most_common_color = pop @top_colors;
my $common_count = $count{ $most_common_color };
return $most_common_color;
}
=item average_color
Determine the average color of the spot at the given x,y location, or at the
current spot by default.
=cut
sub average_color {
my $self = shift;
my $x0 = shift || $self->cursor_x;
my $y0 = shift || $self->cursor_y;
my $imh = $self->imh;
my $spotsize_x = $self->spotsize_x;
my $spotsize_y = $self->spotsize_y;
my $numb_pixels = $spotsize_x * $spotsize_y;
my ($x1, $y1, $x2, $y2) = $self->spot_bounds( $x0, $y0 );
my ($total_rr, $total_gg, $total_bb, $total_alph);
for my $x ($x1 .. $x2) {
for my $y ($y1 .. $y2) {
my $color_string = $imh->Get("pixel[$x,$y]");
my ($rr, $gg, $bb, $alph) = split m/,/, $color_string;
$total_rr += $rr;
$total_gg += $gg;
$total_bb += $bb;
$total_alph += $alph;
$numb_pixels++;
}
}
my $ave_rr = int $total_rr / $numb_pixels;
my $ave_gg = int $total_gg / $numb_pixels;
my $ave_bb = int $total_bb / $numb_pixels;
my $ave_alph = int $total_alph / $numb_pixels;
my $ave_color_string = "$ave_rr,$ave_gg,$ave_bb,$ave_alph";
return $ave_color_string;
}
=item analyze_pixpat_for_edge
Given a B<pixpat>, this looks through it to find the location of an "edge"
in the image. Determines the offset of the edge inside the pixpat by
finding location of the maximum delta colordistance value, and returns both
offset and "max_delta_colordist".
Example usage:
my ($offset, $max_delta_colordist) = $bf->analyze_pixpat_for_edge( $pixpat );
Note: this uses an empirically determined technique for picking
the edge out of the field of colors: it finds the place where the
change of the color-distance is maximized (loosely speaking,
this is a maximum of the rate of change of color).
This appears to be slightly better than the more conventional
approaches of looking for a steep color gradient (the maximum
color-distance), or of looking for inflection points
(zero-crossings in the rate of change of the color distance,
taking it as an approximation of the second-derivative).
=cut
sub analyze_pixpat_for_edge {
my $self = shift;
my $pixpat = shift;
my ($prev_color, $max_delta_colordist, $max_offset);
my $prev_color_distance = 0;
### $self->debug( sprintf "%7s%20s%12s%12s\n", 'off', 'color', 'col_dist', 'del col_dist' );
# find inflection point: determine the "offset" of location of steepest color gradient (sort of)
foreach my $offset ( 0 .. $#{ $pixpat } ) {
my $color = $pixpat->[$offset];
unless( defined( $prev_color ) ) { $prev_color = $color; } # initialize prev_color as the first color, whatever it is.
my $color_distance = $self->color_distance( $color, $prev_color );
my $delta_colordist = $color_distance - $prev_color_distance;
### $self->debug( sprintf "%7s%20s%12d%12d\n", $offset, $color, $color_distance, $delta_colordist );
unless( defined( $max_delta_colordist ) ) { $max_delta_colordist = abs( $delta_colordist ); }
if (abs( $delta_colordist ) > $max_delta_colordist ) {
$max_delta_colordist = abs( $delta_colordist );
$max_offset = $offset;
}
$prev_color = $color;
$prev_color_distance = $color_distance;
}
return ($max_offset, $max_delta_colordist);
}
=back
=head2 location adjustment
=over
=item center_on_edge
Adjusts the location of the cursor to center the spot on any nearby edge.
Optionally takes a pair of x, y values, otherwise it uses the object cursor.
Returns the new point, after setting the object cursor to the adjusted location.
Looks beyond the spot by temporarily expanding the size of the
spot in the transverse direction, by multiplying the spotsize by
the B<refocus_factor> object attribute.
Also relies on the object-attribute: B<delta_colordist_threshold>
(a lower threshold would mean greater sensitivity to changes).
Uses L<analyze_pixpat_for_edge> to do the work of picking out an edge from
inside of a pixpat.
=cut
sub center_on_edge {
my $self = shift;
my $x0 = shift || $self->cursor_x;
my $y0 = shift || $self->cursor_y;
my $refocus_factor = $self->refocus_factor;
my $delta_colordist_threshold = $self->delta_colordist_threshold;
# my $sign = $self->direction_sign;
# my ($x_bound, $y_bound) = $self->main_bounding;
my $axis = $self->direction_axis;
my $spotsize_x_0 = $self->spotsize_x;
my $spotsize_y_0 = $self->spotsize_y;
# temporarily expand the spotsize to examine a larger region
# also: move the spot origin up by half of change, to look on both sides of current location
# Q: do we need to use $y_adjust and $x_adjust later to manually undo this temp move?
# A: no, because we reset to ($x0, $y0) if we need to bail, and if we don't there's a new value
# Note: no need to check $sign, we *always* subtract the "adjust".
my ($spotsize_x, $spotsize_y, $x_adjust, $y_adjust);
my ($x, $y) = ($x0, $y0);
if ($axis eq 'x') {
$spotsize_y = $self->set_spotsize_y( $spotsize_y_0 * $refocus_factor );
$y_adjust = int( ($spotsize_y - $spotsize_y_0) /2 );
$y -= $y_adjust;
$y = 0 if ($y < 0);
} elsif ($axis eq 'y') {
$spotsize_x = $self->set_spotsize_x( $spotsize_x_0 * $refocus_factor );
$x_adjust = int( ($spotsize_x - $spotsize_x_0) /2 );
$x -= $x_adjust;
$x = 0 if ($x < 0);
}
my $pixpat = $self->determine_pixpat_transverse( $x, $y );
my ($offset, $max_delta_colordist) = $self->analyze_pixpat_for_edge( $pixpat );
# if we're in a very flat colorspace, don't bother moving
unless ($max_delta_colordist > $delta_colordist_threshold) {
return [ $x0, $y0 ];
}
# reset the spotsize to it's original dimensions
$spotsize_x = $self->set_spotsize_x( $spotsize_x_0 );
$spotsize_y = $self->set_spotsize_y( $spotsize_y_0 );
my ($half_spot_x, $half_spot_y) = (0,0);
# Add the offset to get to the edge, subtract off half of the spot to put edge in center of spot
if ($axis eq 'x') { # 'transverse' case: if x adjust y, and vice versa
$half_spot_y = int( $self->spotsize_y /2 ) ;
$y = $y + $offset - $half_spot_y;
$x = $x0;
} elsif ($axis eq 'y') {
$half_spot_x = int( $self->spotsize_x /2 ) ;
$x = $x + $offset - $half_spot_x;
$y = $y0;
}
$self->set_cursor_x( $x );
$self->set_cursor_y( $y );
# $self->debug( sprintf( "Edge found at (%d, %d)\n", $x + $half_spot_x, $y + $half_spot_y ) );
# $self->debug( sprintf( "Positioned cursor at (%d, %d)\n", $x, $y ) );
return [ $x, $y ];
}
=back
=head2 scans
A scan sweeps in a particular direction looking for some feature
(e.g. some sort of change, e.g. a change in the average color of
the spot, as in the "*_spotcolor" methods).
=over
=item scan_down_spotcolor
Scans vertically, starting at the given x, y location,
defaulting to the the cursor location -- until a significant
change in the average color is detected.
Sets the cursor at new location.
Detects a change in the average color larger than the
"threshold" setting.
=cut
sub scan_down_spotcolor {
my $self = shift;
my $x0 = shift;
unless( defined( $x0 ) ){
$x0 = $self->cursor_x;
}
my $y0 = shift;
unless( defined( $y0 )) {
$y0 = $self->cursor_y;
}
my $x = $x0;
my $imh = $self->imh;
my $y_bound = $self->image_height - $self->spotsize_y - 2;
my $initial_color = $self->average_color;
for my $y ($y0 .. $y_bound) {
my $color_string = $self->average_color( $x, $y );
# $self->debug( "scan_v: $color_string at ($x, $y)\n" );
if ( $self->has_changed( $color_string, $initial_color) ) {
$self->set_cursor_y( $y );
return $y;
}
}
return; # undef, no color change found
}
=item scan_right_spotcolor
Scans horizontally -- starting at the cursor location -- until a significant
change in the average color is detected.
Sets the cursor at new location.
Detects a change in the average color larger than the
"threshold" setting.
=cut
sub scan_right_spotcolor {
my $self = shift;
my $imh = $self->imh;
my $y = $self->cursor_y;
my $cursor_x = $self->cursor_x;
my $x_bound = $self->image_width - $self->spotsize_x - 2;
my $initial_color = $self->average_color;
for my $x ($cursor_x .. $x_bound) {
my $color_string = $self->average_color( $x, $y );
# $self->debug( "scan_h: $color_string at ($x, $y)\n" );
if ( $self->has_changed( $color_string, $initial_color) ) {
$self->set_cursor_x($x);
return $x;
}
}
return; # undef, no color change found
}
=item scan_up_spotcolor
Scans vertically -- starting at the cursor location -- until a significant
change in the average color is detected.
Sets the cursor at new location.
Detects a change in the average color larger than the
"threshold" setting.
=cut
sub scan_up_spotcolor {
my $self = shift;
my $imh = $self->imh;
my $x = $self->cursor_x;
my $cursor_y = $self->cursor_y;
my $y_bound = 0;
my $initial_color = $self->average_color;
for (my $y = $cursor_y; $y >= $y_bound; $y-- ) {
my $color_string = $self->average_color( $x, $y );
# $self->debug( "scan_v: $color_string at ($x, $y)\n" );
if ( $self->has_changed( $color_string, $initial_color) ) {
$self->set_cursor_y( $y );
return $y;
}
}
return; # undef, no color change found
}
=item scan_left_spotcolor
Scans horizontally backwards (toward the left edge), starting at the cursor
location, until a significant change in the average color is detected.
Sets the cursor at new location.
Detects a change in the average color larger than the
"threshold" setting.
=cut
sub scan_left_spotcolor {
my $self = shift;
my $imh = $self->imh;
my $y = $self->cursor_y;
my $cursor_x = $self->cursor_x;
my $x_bound = 0;
my $initial_color = $self->average_color;
for (my $x = $cursor_x; $x >= $x_bound; $x-- ) {
my $color_string = $self->average_color( $x, $y );
# $self->debug( "scan_h: $color_string at ($x, $y)\n" );
if ( $self->has_changed( $color_string, $initial_color) ) {
$self->set_cursor_x($x);
return $x;
}
}
return; # undef, no color change found
}
=item scan_for_edgey_pixpat
Takes a location as a pair of x/y values as arguments.
If omitted uses the cursor_x and cursor_y object data.
Sweeps downward looking for something that looks like an edge, as
defined by L<looks_like_edge>, with L<determine_pixpat_forward>.
Returns the y value if it finds an edge, or undef it it doesn't
see one before the image boundary.
=cut
sub scan_for_edgey_pixpat {
my $self = shift;
my $x0 = shift;
my $y0 = shift;
unless( defined( $x0 ) ){
$x0 = $self->cursor_x;
}
unless( defined( $y0 )) {
$y0 = $self->cursor_y;
}
$self->set_direction( 'y_plus' );
my $x = $x0;
my $imh = $self->imh;
my $y_bound = $self->image_height - $self->spotsize_y - 2;
my $step = $self->forward_horizon;
my $y_init = $y0 + $step; # TODO EXPERIMENTAL
my $pixpat;
for my $y ($y_init .. $y_bound) {
$pixpat = $self->determine_pixpat_forward( $x, $y );
if( $self->looks_like_edge( $pixpat ) ) {
$self->set_cursor_y( $y );
return $y;
}
}
return; # undef, no edge-like pixpat found.
}
=item look_down_boxfind
Scan downward and attempt to find a rectangle. Looks for
changes of the average spot color.
Begins searching at the given x, y location (but defaults to
the cursor location).
If found, returns a data structure containing the four
points at (or near) the corners of the rectangle.
Otherwise, returns undef.
Example:
if ( my $corners = $self->look_down_boxfind( $x, $y) ) {
push @raw_rectangles, $corners;
}
Note: the edge of the image is never taken as the edge of a "rectangle",
(we're interested in GUI applications, where the fashion is
to have boxes and buttons offset from the window borders).
=cut
# Note, this finds corners in the order 2, 3, 4, 1
sub look_down_boxfind {
my $self = shift;
my $x0 = shift;
my $y0 = shift;
$self->set_cursor_x( $x0 ) if defined( $x0 );
$self->set_cursor_y( $y0 ) if defined( $y0 );
my (@corners, $cursor_y, $cursor_x);
my $nudge = $self->step_back;;
# nudge a little away from an edge (HACK)
# swoop down on a rectangle (we hope)
$cursor_y = $self->scan_down_spotcolor || return;
$self->set_cursor_y( $cursor_y + 2*$nudge ); # dive inside
# sweep to the right, save corner, back off slightly
$cursor_x = $self->scan_right_spotcolor || return;
$corners[1] = [ $self->cursor_x , ($self->cursor_y - $nudge) ]; # not 2*$nudge?
$self->set_cursor_x( $cursor_x - $nudge );
# down the right side to the bottom, save corner, step back up
$cursor_y = $self->scan_down_spotcolor || return;
$corners[2] = [ ( $self->cursor_x + $nudge ) , $self->cursor_y ];
$self->set_cursor_y( $cursor_y - $nudge );
# across to the left edge, save corner, back up to the right
$cursor_x = $self->scan_left_spotcolor || return;
$corners[3] = [ $self->cursor_x , ($self->cursor_y + $nudge) ];
$self->set_cursor_x( $cursor_x + $nudge );
# up to the upper-left corner (we hope), save corner
$cursor_y = $self->scan_up_spotcolor || return;
$corners[0] = [ ( $self->cursor_x - $nudge ) , $self->cursor_y ];
if( $self->looks_rectangular( \@corners ) ) {
return \@corners;
} else {
return;
}
}
=back
=head2 whole image analysis
=over
=item roughly_raster_for_rectangular_regions
Scan the image for rectangles.
Returns a list of rectangles (see concepts section above).
=cut
sub roughly_raster_for_rectangular_regions {
my $self = shift;
my $rectangle_finder = $self->rectangle_finder;
# Currently defaults to: 'boxfind_downward_recenter'
my ($x_bound, $y_bound) = $self->main_bounding;
$self->debug( $self->adjustable_parameter_report );
$self->debug("x_bound: $x_bound, y_bound: $y_bound\n");
my $step_x = $self->step_x;
my $step_y = $self->step_y;
my @raw_rectangles;
my $beware = $self->beware;
for (my $y = 0; $y < ($y_bound - $beware); $y = $y + $step_y ) {
for (my $x = $step_x; $x < ($x_bound - $beware); $x = $x + $step_x ) {
if ( my $corners = $self->$rectangle_finder( $x, $y) ) {
push @raw_rectangles, $corners;
}
}
}
my $sorted_rectangles = $self->sort_boxes( \@raw_rectangles );
my $rectangles = $self->uniq_boxes( $sorted_rectangles );
return $rectangles;
}
=item bang_along_from_below_for_boxes {
Scan the image for rectangles.
Returns a list of rectangles (see concepts section above).
Like L<roughly_raster_for_rectangular_regions>, but it works from
the lower-right hand corner, stepping backwards through the image;
which is presumably this is better for using the "rectangle_finder":
L<boxfind_upward_via_pixpat>.
=cut
sub bang_along_from_below_for_boxes {
my $self = shift;
my $rectangle_finder = $self->rectangle_finder;
# Currently defaults to: 'boxfind_downward_recenter'
my ($x_bound, $y_bound) = $self->main_bounding;
$self->debug( Dumper( $self ) . "\n");
$self->debug("x_bound: $x_bound, y_bound: $y_bound\n");
my $step_x = $self->step_x;
my $step_y = $self->step_y;
my @raw_rectangles;
my $beware = $self->beware;
for (my $y = ($y_bound - $beware); $y > 0 ; $y -= $step_y ) {
for (my $x = ($x_bound - $beware); $x > 0 ; $x -= $step_x ) {
if ( my $corners = $self->$rectangle_finder( $x, $y) ) {
push @raw_rectangles, $corners;
}
}
}
my $sorted_rectangles = $self->sort_boxes( \@raw_rectangles );
my $rectangles = $self->uniq_boxes( $sorted_rectangles );
return $rectangles;
}
=item smart_sweep_for_squarish_shapes
Scan the image for rectangles.
Returns an array reference, a list of rectangles (see
concepts section above).
Like L<roughly_raster_for_rectangular_regions>, but smarter.
Can not find nested rectangles, however.
=cut
sub smart_sweep_for_squarish_shapes {
my $self = shift;
my ($x_bound, $y_bound) = $self->main_bounding;
$self->debug( $self->adjustable_parameter_report );
$self->debug("x_bound: $x_bound, y_bound: $y_bound\n");
# initialize recursive search for rectangles below rectangles
# using a degenerate rectangle of 0 height that spans the image
my $dummy_rect = [ [0,0] , [$x_bound,0], [$x_bound,0], [0,0] ];
my $raw_rectangles = $self->peer_under_rect_for_rects( $dummy_rect );
my $rectangles = $self->uniq_boxes( $raw_rectangles );
return $rectangles;
}
=item peer_under_rect_for_rects
Given a rectangle, looks at the region below it to find any rectangles down
there (it calls itself recursively to find rectangles below rectangles).
Returns list of rectangles found.
Note: first time, can be given a dummy "degenerate" rectangle zero
pixels high, to trick it into scanning the whole image from the top.
Example usage:
my $new_rects = $self->peer_under_rect_for_rects( $given_rect );
=cut
sub peer_under_rect_for_rects {
my $self = shift;
my $rect0 = shift;
my @rects;
# need to do check because it might be a degenerate dummy rect
# TODO having to do this here is silly, I think. Push this one level up?
# (which also means doing it below, since there's a recursive call here).
if( $self->looks_rectangular( $rect0 ) ) {
push @rects, $rect0; # add the current rect
}
my $finder_of_rectangles = $self->finder_of_rectangles;
my $point_1 = $rect0->[3];
my $point_2 = $rect0->[2];
my $y = max( $point_1->[1], $point_2->[1] ); # List::Util
my $x1 = $point_1->[0];
my $x2 = $point_2->[0];
my $step_x = $self->step_x;
for (my $x = $x1; $x < $x2; $x += $step_x ) {
my $rects = $self->$finder_of_rectangles( $x, $y);
if ( $self->is_aref_three_deep( $rects ) ) { # make sure it's not an empty aref
foreach my $rect ( @{ $rects } ) {
my $new_rects = $self->peer_under_rect_for_rects( $rect );
push @rects, @{ $new_rects }; # add returned new rects
}
my $last = $rects->[-1];
my $width = ($last->[1][0] - $last->[0][0]);
$x += $width;
}
}
return \@rects;
}
=back
=head2 boxing
=over
=item uniq_boxes
Uniquifies a list of sorted rectangles: by scanning through the list,
comparing all pairs of them.
We use the L<is_dupe_box> method to determine if they're roughly
identical, and if so we keep only one of them.
Note: Instead of just choosing one member of a duplicate pair, it
might be better to take a geometric average of the corners of the near
duplicates. TODO
If the list is empty, is should also return an empty list without
error, but if it looks like something else has been passed in,
this should 'confess' (i.e. die with a stack trace).
=cut
# An odd limitation (problem with doing a "uniq" with fuzzy criteria):
# Q: given => means (is a dupe of) and !=> (is not a dupe of)
# what if there's an A => B => C where A !=> C
# A: as written: A will scan for dupes, see B, and skip
# B will scan for dupes, see C, and skip
# We will end up with just C.
# That's *one* good answer. Another would be to return A & C, yes?
# Except: presuming some fuzziness about the fuzziness threshold,
# returning just one is probably better... though A might be
# closer to the mark than C.
sub uniq_boxes {
my $self = shift;
my $rectangles = shift;
if ( ref( $rectangles ) eq 'ARRAY' && (not defined( $rectangles->[0] )) ) {
return $rectangles;
}
unless( $self->is_aref_three_deep( $rectangles ) ) {
confess "uniq_boxes: arg must be a rectangle list: " . Dumper( $rectangles );
}
my @r = @{ $rectangles };
my (@uniq);
while ( my $r1 = shift @r ) {
my $dupe_found = 0;
CHECK:
foreach my $r2 (@r) {
if ( $self->is_dupe_box( $r1, $r2 ) ) {
$dupe_found = 1;
last CHECK;
}
}
push @uniq, $r1 unless $dupe_found;
}
return \@uniq;
}
=item sort_boxes
Given a list of rectangles, sorts them in the obvious numeric order.
If the list is empty, is should also return an empty list without
error, but if it looks like something else has been passed in,
this should 'confess' (i.e. die with a stack trace).
=cut
sub sort_boxes {
my $self = shift;
my $rectangles = shift;
if ( ref( $rectangles ) eq 'ARRAY' && (not defined( $rectangles->[0] )) ) {
return $rectangles;
}
unless( $self->is_aref_three_deep( $rectangles ) ) {
confess "sort_boxes: arg must be a rectangle list: " . Dumper( $rectangles );
}
my @results =
sort
{ $a->[0][0] <=> $b->[0][0] ||
$a->[0][1] <=> $b->[0][1] ||
$a->[1][0] <=> $b->[1][0] ||
$a->[1][1] <=> $b->[1][1] ||
$a->[2][0] <=> $b->[2][0] ||
$a->[2][1] <=> $b->[2][1] ||
$a->[3][0] <=> $b->[3][0] ||
$a->[3][1] <=> $b->[3][1]
} @{ $rectangles };
return \@results;
}
=item is_dupe_box
Returns true if the two given rectangles are (roughly)
duplicates of each other (i.e. their corners coincide with
a delta-x and delta-y smaller than the "fuzziness" parameter,
an object attribute).
Note: instead of looking at delta-x and delta-y, it might
be more rigorous to calculate the distance between the two
points (using the L<geometric_distance> method)...
but I suspect thinking in terms of x any y errors maps
more closely to the way this data is determined,
so I'm sticking with this simpler calculation.
=cut
sub is_dupe_box {
my $self = shift;
my $r1 = shift;
my $r2 = shift;
my $fz = $self->fuzziness;
my $dupe_p =
reduce { $a && $b }
pairwise { ( ( abs($a->[0] - $b->[0]) <= $fz ) &&
( abs($a->[1] - $b->[1]) <= $fz ) ) }
@{ $r1 }, @{ $r2 };
return $dupe_p;
}
=item is_dupe_box_list
Compares lists of rectangles, returns true if they're effectively identical
(within the limits of "fuzziness", as in L<is_dupe_box>.
=cut
sub is_dupe_box_list {
my $self = shift;
my $r_list_1 = shift;
my $r_list_2 = shift;
my $rl1 = $self->sort_boxes( $r_list_1 );
my $rl2 = $self->sort_boxes( $r_list_2 );
my $list_dupe_p = 1;
for (my $i = 0; $i <= $#{ $rl1 }; $i++ ) {
my $r1 = $rl1->[ $i ];
my $r2 = $rl2->[ $i ];
my $rect_dupe_p = $self->is_dupe_box( $r1, $r2 );
$list_dupe_p &&= $rect_dupe_p;
}
return $list_dupe_p;
}
=item is_dupe_box_list_croaker
Compares lists of rectangles, returns true if they're effectively identical
(within the limits of "fuzziness", as in L<is_dupe_box>. If they're not
identical, it croaks, returning a message explaining at what point they diverge.
=cut
sub is_dupe_box_list_croaker {
my $self = shift;
my $r_list_1 = shift;
my $r_list_2 = shift;
my $rl1 = $self->sort_boxes( $r_list_1 );
my $rl2 = $self->sort_boxes( $r_list_2 );
my $list_dupe_p = 1;
for (my $i = 0; $i <= $#{ $rl1 }; $i++ ) {
my $r1 = $rl1->[ $i ];
my $r2 = $rl2->[ $i ];
my $rect_dupe_p = $self->is_dupe_box( $r1, $r2 );
if ($rect_dupe_p) {
$list_dupe_p &&= $rect_dupe_p;
} else {
my $r1_text = $self->print_box_to_string( $r1 );
my $r2_text = $self->print_box_to_string( $r2 );
my $rl1_text = $self->dump_boxes_to_string( $rl1 );
my $rl2_text = $self->dump_boxes_to_string( $rl2 );
croak "rect list diverged at row $i: $r1_text $r2_text\nlist 1:\n" .
$rl1_text . "\nlist 2:\n" . $rl2_text;
}
}
return $list_dupe_p;
}
=item diff_box_list
Compares two lists of rectangles, and reports on the place where they diverge.
Returns an empty string if they match each other, within the limits of
"fuzziness", as in L<is_dupe_box>.
=cut
sub diff_box_list {
my $self = shift;
my $r_list_1 = shift;
my $r_list_2 = shift;
unless( $self->is_aref_three_deep( $r_list_1 ) ) {
croak "First argument is not a rectangle list";
}
unless( $self->is_aref_three_deep( $r_list_2 ) ) {
croak "Second argument is not a rectangle list";
}
my $rl1 = $self->sort_boxes( $r_list_1 );
my $rl2 = $self->sort_boxes( $r_list_2 );
my $status = '';
my $list_dupe_p = 1;
for (my $i = 0; $i <= $#{ $rl1 }; $i++ ) {
my $r1 = $rl1->[ $i ];
my $r2 = $rl2->[ $i ];
my $rect_dupe_p = $self->is_dupe_box( $r1, $r2 );
$list_dupe_p &&= $rect_dupe_p;
if (not ($rect_dupe_p)) {
my $r1_text = $self->print_box_to_string( $r1 );
my $r2_text = $self->print_box_to_string( $r2 );
$status = "rectangle list diverged at row $i:\n $r1_text\n $r2_text\n";
}
}
return $status;
}
=item is_aref_three_deep
A rough check to see if we have a ref to an array of arrays of arrays.
Note: can yield false positives.
=cut
sub is_aref_three_deep {
my $self = shift;
my $r = shift;
if (ref $r eq 'ARRAY') {
if (ref $r->[0] eq 'ARRAY') {
if (ref $r->[0][0] eq 'ARRAY') {
return 1; # tentatively
}
}
}
return; # definitely
}
=item is_aref_two_deep
A rough check to see if we have a ref to an array of arrays, as opposed to an
array of arrays of arrays.
Note: can yield false positives.
=cut
sub is_aref_two_deep {
my $self = shift;
my $r = shift;
if (ref $r eq 'ARRAY') {
if (ref $r->[0] eq 'ARRAY') {
if (not (ref $r->[0][0] eq 'ARRAY')) {
return 1; # tentatively
}
}
}
return; # definitely
}
=item geometric_distance
Given two points, calculates the distance between them.
As written, restricted to 2D (x,y) points.
=cut
sub geometric_distance {
my $self = shift;
my $p1 = shift;
my $p2 = shift;
my $distance =
sqrt(
( $p1->[0] - $p2->[0] ) ^ 2 +
( $p1->[1] - $p2->[1] ) ^ 2
);
return $distance;
}
=item count_boxes_from_list
Given a list of rectangles, returns the number of rectangles.
TODO: not yet in use. But the goal is a L<count_rectangles>
command, remember? This is a (trivial) piece of the problem.
=cut
sub count_boxes_from_list {
my $self = shift;
my $rectangles = shift;
unless( $self->is_aref_three_deep( $rectangles ) ) {
croak "Argument is not a rectangle list";
}
my $count = scalar( @{ $rectangles } ); # not off by one is it?
return $count;
}
=back
=head2 follow
A "follow" method moves forward and looks to one or both sides,
trying to maintain some condition as it proceeds (e.g. a pixel
pattern indicating an edge).
=over
=item follow_pixel_pattern
Given a direction code: 'x_plus', 'x_minus', 'y_plus', or 'y_minus'
Moves in that direction as far as it can go while maintaining the same
pattern of pixels throughout a certain width (the spotsize in
the direction transverse, for now).
Returns the point where it stops (x, y).
Sets the cursor to that location.
=cut
sub follow_pixel_pattern {
my $self = shift;
my $new_direction = shift;
my $direction;
if ($new_direction) {
$self->set_direction($new_direction);
$direction = $new_direction;
} else {
$direction = $self->direction;
}
my $method = 'follow_pixpat_' . $direction;
my $point = $self->$method;
return $point;
}
=back
=head3 follow pixel patterns
The 'follow_pixpat_*' methods below move in the direction
indicated by their suffixes:
'x_plus', 'x_minus', 'y_plus', or 'y_minus'
Each of them makes use of the "spot", averaging the color of
the rows of pixels in the direction of travel, but preserving
differences in the transverse direction. They look for
a change in this array of average colors
(using the L<has_pixpat_changed> method),
and then stop, setting the cursor and returning the x and y
values of the point (as an aref).
If no change is detected the extreme limit at the edge of
the image is returned.
(( TODO review that design decision -- the main idea is that it
saves me from propagating an undef return and handling it in
a special way, or alternately from trapping an error. ))
=over
=item follow_pixpat_x_plus
Starting at the given (x, y) location (defaulting to the cursor)
moves in the "x_plus" direction until a change in the pixpat
is detected.
Example usage:
my $end_point = $bf->follow_pixpat_x_plus( $x0, $y0 );
=cut
sub follow_pixpat_x_plus {
my $self = shift;
my $x0 = shift;
unless( defined( $x0 ) ) {
$x0 = $self->cursor_x;
}
my $y0 = shift;
unless( defined( $y0 ) ) {
$y0 = $self->cursor_y;
}
my $pixpat_delta_method = $self->pixpat_delta_method || 'has_pixpat_changed';
$self->set_direction('x_plus');
my $imh = $self->imh;
my ($x_max, $y_max) = $self->main_bounding;
my ($x_min, $y_min) = (0, 0);
my $previous = $self->determine_pixpat_transverse( $x0, $y0 );
if( not( $self->looks_like_edge($previous) ) ) {
# return [$x0, $y0]; # if not on an edge, don't move at all...
return;
}
my $y = $y0;
for my $x ($x0 .. $x_max) {
my $current = $self->determine_pixpat_transverse( $x, $y );
if ( $self->$pixpat_delta_method( $current, $previous ) ){
$self->set_cursor_x( $x );
return [$x, $y];
}
$previous = $current if $self->ignore_subtle_pixpat_change;
}
return [$x_max, $y]; # nothing detected, so return extreme limit
}
=item follow_pixpat_x_minus
=cut
sub follow_pixpat_x_minus {
my $self = shift;
my $x0 = shift;
unless( defined( $x0 ) ) {
$x0 = $self->cursor_x;
}
my $y0 = shift;
unless( defined( $y0 ) ) {
$y0 = $self->cursor_y;
}
my $pixpat_delta_method = $self->pixpat_delta_method || 'has_pixpat_changed';
$self->set_direction('x_minus');
my $imh = $self->imh;
my ($x_max, $y_max) = $self->main_bounding;
my ($x_min, $y_min) = (0, 0);
my $previous = $self->determine_pixpat_transverse( $x0, $y0 );
if( not( $self->looks_like_edge($previous) ) ) {
# return [$x0, $y0]; # if not on an edge, don't move at all...
return;
}
my $y = $y0;
for (my $x = $x0; $x >= $x_min; $x-- ) {
my $current = $self->determine_pixpat_transverse( $x, $y );
if ($self->$pixpat_delta_method( $current, $previous ) ){
$self->set_cursor_x( $x );
return [$x, $y];
}
$previous = $current if $self->ignore_subtle_pixpat_change;
}
return [$x_max, $y]; # nothing detected, so return extreme limit
}
=item follow_pixpat_y_plus
=cut
sub follow_pixpat_y_plus {
my $self = shift;
my $x0 = shift;
unless( defined( $x0 ) ) {
$x0 = $self->cursor_x;
}
my $y0 = shift;
unless( defined( $y0 ) ) {
$y0 = $self->cursor_y;
}
my $pixpat_delta_method = $self->pixpat_delta_method || 'has_pixpat_changed';
$self->set_direction('y_plus');
my $imh = $self->imh;
my ($x_max, $y_max) = $self->main_bounding;
my ($x_min, $y_min) = (0, 0);
my $previous = $self->determine_pixpat_transverse( $x0, $y0 );
if( not( $self->looks_like_edge($previous) ) ) {
# return [$x0, $y0]; # if not on an edge, don't move at all...
return;
}
my $x = $x0;
for my $y ($y0 .. $y_max) {
my $current = $self->determine_pixpat_transverse( $x, $y );
if ($self->$pixpat_delta_method( $current, $previous ) ){
$self->set_cursor_y( $y );
return [$x, $y];
}
$previous = $current if $self->ignore_subtle_pixpat_change;
}
return [$x_max, $y0]; # nothing detected, so return extreme limit
}
=item follow_pixpat_y_minus
=cut
sub follow_pixpat_y_minus {
my $self = shift;
my $x0 = shift;
unless( defined( $x0 ) ) {
$x0 = $self->cursor_x;
}
my $y0 = shift;
unless( defined( $y0 ) ) {
$y0 = $self->cursor_y;
}
my $pixpat_delta_method = $self->pixpat_delta_method || 'has_pixpat_changed';
$self->set_direction('y_minus');
my $imh = $self->imh;
my ($x_max, $y_max) = $self->main_bounding;
my ($x_min, $y_min) = (0, 0);
my $previous = $self->determine_pixpat_transverse( $x0, $y0 );
if( not( $self->looks_like_edge($previous) ) ) {
# return [$x0, $y0]; # if not on an edge, don't move at all...
return;
}
my $x = $x0;
for (my $y = $y0; $y >= $y_min; $y-- ) {
my $current = $self->determine_pixpat_transverse( $x, $y );
if ($self->$pixpat_delta_method( $current, $previous ) ){
$self->set_cursor_y( $y );
return [$x, $y];
}
$previous = $current if $self->ignore_subtle_pixpat_change;
}
return [$x_max, $y0]; # nothing detected, so return extreme limit
}
=item has_pixpat_changed
Given two "pixpats", the current and the previous one, this
returns true if there's a difference between the two.
If the second argument is omitted, this will instead use the
"previous_state" value from the object data.
Ex. usage:
if ($self->has_pixpat_changed( $current, $previous ) ){
my $self->set_cursor_y( $y );
return ($y, $x);
}
Note that this is a comparison sensitive to the slightest
change (no "fuzziness" or "threshold" concept applies here).
=cut
sub has_pixpat_changed {
my $self = shift;
my $current_pixpat = shift;
my $previous_pixpat = shift || $self->previous_state;
my $status = not all {$_} pairwise { ($a eq $b) }
@{ $current_pixpat }, @{ $previous_pixpat };
return $status;
}
=item has_pixpat_changed_past_threshold
=cut
sub has_pixpat_changed_past_threshold {
my $self = shift;
my $current_pixpat = shift;
my $previous_pixpat = shift || $self->previous_state;
my $pixpat_threshold = $self->pixpat_threshold; # current default 5500 (too high?)
my $status = any {$_}
pairwise {
( $self->color_distance( $a, $b ) > $pixpat_threshold )
}
@{ $current_pixpat }, @{ $previous_pixpat };
return $status;
}
=item color_distance
Calculate the difference in "color distance" from two Image::Magick color strings.
Ex. usage:
my $color_distance = $self->color_distance( $color1, $color2 );
Note, any difference in the fourth parameter (alpha) is ignored.
If the second color is skipped, the distance to the origin is returned.
=cut
sub color_distance {
my $self = shift;
my $color1 = shift;
my $color2 = shift || '0,0,0,0';
my ($rr1, $gg1, $bb1, $alph1) = split m/,/, $color1;
my ($rr2, $gg2, $bb2, $alph2) = split m/,/, $color2;
my $distance =
sqrt(
( $rr1 - $rr2 ) ** 2 +
( $gg1 - $gg2 ) ** 2 +
( $bb1 - $bb2 ) ** 2
);
return $distance;
}
=item determine_pixpat_forward
See "pixpat" in L<concepts>.
Averages colors in the spot, in stripes aligned B<across> the direction
of travel: this determines a "pixel pattern" that can be used to
detect an edge. This is used to look ahead for an edge, in the "forward"
direction.
Ex. usage:
$self->set_direction('x_plus');
my @colors = $self->determine_pixpat_forward( $x, $y );
(Remember, "set_direction" has a side-effect: it sets the spotsize in
the forward direction to the "forward_horizon", and the spotsize
in the transverse direction to the "transverse_horizon".)
This uses a "spot" (see L<concepts>) that is silently truncated
to fit the image boundaries.
=cut
sub determine_pixpat_forward {
my $self = shift;
my $x0 = shift || $self->cursor_x;
my $y0 = shift || $self->cursor_y;
my $axis = $self->direction_axis;
my $imh = $self->imh;
my @pixpat = ();
my %colors = ();
my ($x1, $y1, $x2, $y2) = $self->spot_bounds_truncated( $x0, $y0 );
if ($axis eq 'x') {
for my $x ($x1 .. $x2) {
my $ave = '';
for my $y ($y1 .. $y2) {
my $color_string = $imh->Get("pixel[$x,$y]");
$colors{ $y } = $color_string;
}
my @colors = values( %colors );
$ave = $self->average_array_of_colors( \@colors );
push @pixpat, $ave;
}
} elsif ($axis eq 'y') {
for my $y ($y1 .. $y2) {
my $ave = '';
for my $x ($x1 .. $x2) {
my $color_string = $imh->Get("pixel[$x,$y]");
$colors{ $y } = $color_string;
}
my @colors = values( %colors );
$ave = $self->average_array_of_colors( \@colors );
push @pixpat, $ave;
}
}
return \@pixpat;
}
=item determine_pixpat_transverse
See "pixpat" in L<concepts>.
Averages colors in the spot, in stripes aligned B<with> the
direction of travel, to determine a "pixel pattern" that can be
used to follow an edge. (This looks sideways for an edge, hence
the name "transverse".)
Ex. usage:
$self->set_direction('x_plus');
my @colors = $self->determine_pixpat_transverse( $x, $y );
(Remember, "set_direction" has a side-effect: it sets the spotsize in
the forward direction to the "forward_horizon", and the spotsize
in the transverse direction to the "transverse_horizon".)
This uses a "spot" (see L<concepts>) that is silently truncated
to fit the image boundaries.
=cut
sub determine_pixpat_transverse {
my $self = shift;
my $x0 = shift || $self->cursor_x;
my $y0 = shift || $self->cursor_y;
my $direction = $self->direction;
my $x_or_y = ( split( /_/, $direction ) )[0];
my $imh = $self->imh;
my @pixpat = ();
my %colors = ();
my ($x1, $y1, $x2, $y2) = $self->spot_bounds_truncated( $x0, $y0 );
if ($x_or_y eq 'x') {
my $ave = '';
for my $y ($y1 .. $y2) {
for my $x ($x1 .. $x2) {
my $color_string = $imh->Get("pixel[$x,$y]");
$colors{ $y } = $color_string;
}
my @colors = values( %colors );
$ave = $self->average_array_of_colors( \@colors );
push @pixpat, $ave;
}
} elsif ($x_or_y eq 'y') {
my $ave = '';
for my $x ($x1 .. $x2) {
for my $y ($y1 .. $y2) {
my $color_string = $imh->Get("pixel[$x,$y]");
$colors{ $y } = $color_string;
}
my @colors = values( %colors );
$ave = $self->average_array_of_colors( \@colors );
push @pixpat, $ave;
}
}
return \@pixpat;
}
=item average_array_of_colors
Given an array of color strings, returns the color string of the average.
Ex. my $ave = $self->average_array_of_colors( \@colors );
=cut
sub average_array_of_colors {
my $self = shift;
my $colors = shift;
my ($total_rr, $total_gg, $total_bb, $total_alph);
foreach my $color_string ( @{ $colors } ) {
my ($rr, $gg, $bb, $alph) = split m/,/, $color_string;
$total_rr += $rr;
$total_gg += $gg;
$total_bb += $bb;
$total_alph += $alph;
}
my $count = scalar( @{ $colors } );
my $ave_rr = sprintf("%.0f", $total_rr / $count );
my $ave_gg = sprintf("%.0f", $total_gg / $count );
my $ave_bb = sprintf("%.0f", $total_bb / $count );
my $ave_alph = sprintf("%.0f", $total_alph / $count );
my $ave_color_string = "$ave_rr,$ave_gg,$ave_bb,$ave_alph";
return $ave_color_string;
}
=item looks_like_edge
Given a pixpat, returns true if there's enough variation in color (as measured
by color distance) over the pattern so that it's plausible it represents an
"edge" of a GUI element.
Uses the object setting L<edge_contrast_cutoff> to determine if
there's enough difference bettween min and max color distance.
Looks at the change in color distance between adjacent colors in the
"pixpat" array.
=cut
sub looks_like_edge {
my $self = shift;
my $pixpat = shift;
my $cutoff = $self->edge_contrast_cutoff;
my ($dist);
my ($max_dist, $min_dist) = (0, undef);
my $prev_color = $pixpat->[0];
for (my $i=1; $i <= $#{ $pixpat }; $i++) {
my $color = $pixpat->[ $i ];
$dist = $self->color_distance( $color, $prev_color );
# ensure min and max are never undef
unless (defined( $max_dist ) ) {
$max_dist = $dist;
}
unless (defined( $min_dist ) ) {
$min_dist = $dist;
}
if ($dist > $max_dist) {
$max_dist = $dist;
} elsif ($dist < $min_dist) {
$min_dist = $dist;
}
$prev_color = $color;
}
my $delta = $max_dist - $min_dist;
if ($delta >= $cutoff) {
return 1;
} else {
return '';
}
}
### TODO
### The vague thought here: groping toward a system where the
### guts can be stubbed out, so I can test the outer control
### structures (e.g. 'roughly_raster_*' and friends) independant
### of any real (i.e. time consuming) activity.
=item detected_change
A very general routine to compare a saved state to the current state, using a
method of detecting change defined in the object data.
Ex. usage (TODO)
$self->set_change_detector( "null_change_detector" );
for my $x (0 .. $xmin) {
for my $y (0 .. $ymin) {
($mark_x, $mark_y) = $self->follow_y_plus( $x, $y);
$self->set_cursor_x( $x );
$self->set_cursor_y( $y );
}
}
$self->set_previous_state( $current_state );
=cut
sub detected_change {
my $self = shift;
my $current_state = shift;
my $previous_state = shift || $self->previous_state;
my $change_detector = $self->change_detector;
my $status = $self->$change_detector( $current_state, $previous_state );
return $status;
}
=item boxfind_downward_via_pixpat
Scan downward and attempt to find a rectangle. Begins from the current cursor
location, or from a given location if the x/y values have been supplied.
If found, returns a data structure containing the four
points at (or near) the corners of the rectangle.
Otherwise, returns undef.
Example:
$self->set_forward_horizon( 3 );
$self->set_transverse_horizon( 4);
if ( my $corners = $self->boxfind_downward_via_pixpat( $x, $y) ) {
push @raw_rectangles, $corners;
}
Note: this routine tries to use the "follow_*" family of methods,
which scan using "pixel_patterns". As written, these routines
might actually treat the edge of the image as the edge of a rectangle.
=cut
# Note, this finds corners in the order 2, 3, 4, 1
sub boxfind_downward_via_pixpat {
my $self = shift;
my $x0 = shift;
my $y0 = shift;
$self->set_cursor_x( $x0 ) if defined( $x0 );
$self->set_cursor_y( $y0 ) if defined( $y0 );
my $minimum_width = $self->minimum_width;
my (@corners, $point, $x, $y);
my $step = $self->forward_horizon;
my $half_step = int( ($step/2) );
# Set up for "scan_down_spotcolor": doesn't know about "horizon"
$self->set_spotsize_x( $self->transverse_horizon );
$self->set_spotsize_y( $self->forward_horizon );
# swoop down on a rectangle (we hope)
$y = $self->scan_down_spotcolor($x0, $y0) || return;
$y = $self->set_cursor_y( $y + $half_step ); # step a little closer
# sweep to the right, step foward, save corner
$point = $self->follow_pixpat_x_plus( $x0, $y);
unless( $point ) {
return;
}
$x = $point->[0] + $half_step;
# $y = $point->[1];
$corners[1] = [ $x, $y ];
# nudge down, then down the right side to the bottom, step down, save corner
$y = $y + $step;
$point = $self->follow_pixpat_y_plus( $x, $y );
unless( $point ) {
return;
}
# $x = $point->[0];
$y = $point->[1] + $half_step;
$corners[2] = [ $x, $y ];
# across to the left edge, step back, save corner
$x = $x - $step; # nudge to the right, get spot on the edge away from corner
$point = $self->follow_pixpat_x_minus( $x, $y ); # TODO goes a *little* further than I expected
unless( $point ) {
return;
}
$x = $point->[0] - $half_step;
# $y = $point->[1];
$corners[3] = [ $x, $y ];
# up to the upper-left corner (we hope), step back, save corner
$y = $y - $step; # nudge up
$point = $self->follow_pixpat_y_minus( $x, $y );
unless( $point ) {
return;
}
# $x = $point->[0];
$y = $point->[1] - $half_step;
$corners[0] = [ $x, $y ];
if( $self->looks_rectangular( \@corners ) ) {
return \@corners;
} else {
return;
}
}
=item boxfind_downward_purely_via_pixpat
This is much like L<boxfind_downward_via_pixpat>, except that instead of
scanning down for a change in spotcolor, it scans downward for something that
looks like it might be an edge pixpat (uses L<scan_for_edgey_pixpat>).
Begins from the current cursor location, or from a given location
if the x/y values have been supplied.
If found, returns a data structure containing the four points at
(or near) the corners of the rectangle.
Otherwise, returns undef.
Example:
$self->set_forward_horizon( 3 );
$self->set_transverse_horizon( 4);
if ( my $corners = $self->boxfind_downward_purely_via_pixpat( $x, $y) ) {
push @raw_rectangles, $corners;
}
Note: this routine tries to use the "follow_*" family of methods,
which scan using "pixel patterns". As written, these routines
might actually treat the edge of the image as the edge of a rectangle.
=cut
# Note, this finds corners in the order 2, 3, 4, 1
sub boxfind_downward_purely_via_pixpat {
my $self = shift;
my $x0 = shift;
my $y0 = shift;
$self->set_cursor_x( $x0 ) if defined( $x0 );
$self->set_cursor_y( $y0 ) if defined( $y0 );
my $minimum_width = $self->minimum_width;
my (@corners, $point, $x, $y);
my $step = $self->forward_horizon;
my $half_step = int( ($step/2) );
$x = $x0;
# swoop down on a rectangle (we hope)
$y = $self->scan_for_edgey_pixpat($x0, $y0) || return;
$y = $self->set_cursor_y( $y + $half_step ); # step a little closer
# sweep to the right, step foward, save corner
$point = $self->follow_pixpat_x_plus( $x, $y);
unless( $point ) {
return;
}
$x = $point->[0] + $half_step;
$corners[1] = [ $x, $y ];
# nudge down, then down the right side to the bottom, step down, save corner
$y = $y + 2*$step;
$point = $self->follow_pixpat_y_plus( $x, $y );
unless( $point ) {
return;
}
$y = $point->[1] + $half_step;
$corners[2] = [ $x, $y ];
$y = $y + $half_step;
# across to the left edge, step back, save corner
$x = $x - $step; # nudge to the right, get spot on the edge away from corner
$point = $self->follow_pixpat_x_minus( $x, $y );
unless( $point ) {
return;
}
$x = $point->[0] - $half_step;
$corners[3] = [ $x, $y ];
# up to the upper-left corner (we hope), step back, save corner
$y = $y - $step; # nudge up
$point = $self->follow_pixpat_y_minus( $x, $y );
unless( $point ) {
return;
}
$y = $point->[1] - $half_step;
$corners[0] = [ $x, $y ];
$y = $point->[1] - $step;
if( $self->looks_rectangular( \@corners ) ) {
return \@corners;
} else {
return;
}
}
=item boxfind_upward_via_pixpat
Scan upward and attempt to find a rectangle. Begins from the current cursor
location, or from a given location if the x/y values have been supplied.
If found, returns a data structure containing the four
points at (or near) the corners of the rectangle.
Otherwise, returns undef.
Example:
$self->set_forward_horizon( 3 );
$self->set_transverse_horizon( 4);
if ( my $corners = $self->boxfind_upward_via_pixpat( $x, $y) ) {
push @raw_rectangles, $corners;
}
Note: this routine tries to use the "follow_*" family of methods,
which scan using "pixel_patterns" instead of simple average spot
color differences.
As written, these routines might actually treat the edge of the
image as the edge of a rectangle.
=cut
# In outline:
# scan_up_spotcolor
# follow LEFT => point 4
# follow UP => point 1
# follow RIGHT => point 2
# follow DOWN => point 3
# Note, this finds corners in the order 4, 1, 2, 3
sub boxfind_upward_via_pixpat {
my $self = shift;
my $x0 = shift;
my $y0 = shift;
$self->set_cursor_x( $x0 ) if defined( $x0 );
$self->set_cursor_y( $y0 ) if defined( $y0 );
my $minimum_width = $self->minimum_width;
my (@corners, $point, $x, $y);
my $step = $self->forward_horizon;
my $half_step = int( ($step/2) );
# Set up for "scan_up_spotcolor": doesn't know about "horizon"
$self->set_spotsize_x( $self->transverse_horizon );
$self->set_spotsize_y( $self->forward_horizon );
# swoop *upwards* to find a rectangle (we hope)
$x = $x0;
$y = $self->scan_up_spotcolor($x0, $y0) || return;
$y = $self->set_cursor_y( $y - $half_step ); # step a little closer ((try a whole step? TODO))
# across to the left edge, step back, save corner
# $x = $x - $step; # nudge to the right, get spot on the edge away from corner # No point now...
$point = $self->follow_pixpat_x_minus( $x, $y );
unless( $point ) {
return;
}
$x = $point->[0] - $half_step;
$corners[3] = [ $x, $y ];
# up to the upper-left corner (we hope), step back, save corner
$y = $y - $step; # nudge up
$point = $self->follow_pixpat_y_minus( $x, $y );
unless( $point ) {
return;
}
$y = $point->[1] - $half_step;
$corners[0] = [ $x, $y ];
# sweep to the right, step foward, save corner
$x = $x + $step; # nudge right
$point = $self->follow_pixpat_x_plus( $x, $y);
unless( $point ) {
return;
}
$x = $point->[0] + $half_step;
$corners[1] = [ $x, $y ];
# nudge down, then down the right side to the bottom, step down, save corner
$y = $y + $step;
$point = $self->follow_pixpat_y_plus( $x, $y );
unless( $point ) {
return;
}
$y = $point->[1] + $half_step;
$corners[2] = [ $x, $y ];
if( $self->looks_rectangular( \@corners ) ) {
return \@corners;
} else {
return;
}
}
=item boxfind_downward_recenter
This is much like L<boxfind_downward_via_pixpat>, except that instead
of scanning down for a change in spotcolor, it scans downward for
something that looks like it might be an edge pixpat (uses
L<scan_for_edgey_pixpat>), and further, it uses calls to
"center_on_edge" to try to improve it's precision in edge following.
Scan downward and attempt to find a rectangle. Begins from the
current cursor location, or from a given location if the x/y values
have been supplied.
If found, returns a data structure containing the four
points at (or near) the corners of the rectangle.
Otherwise, returns undef.
Example:
$self->set_forward_horizon( 3 );
$self->set_transverse_horizon( 4);
if ( my $corners = $self->boxfind_downward_recenter( $x, $y) ) {
push @raw_rectangles, $corners;
}
Note: this routine tries to use the "follow_*" family of methods,
which scan using "pixel_patterns" instead of simple average spot
color differences.
As written, these routines might actually treat the edge of the
image as the edge of a rectangle.
=cut
# Note, this finds corners in the order 2, 3, 4, 1
sub boxfind_downward_recenter {
my $self = shift;
my $x = shift;
my $y = shift;
$self->set_cursor_x( $x ) if defined( $x );
$self->set_cursor_y( $y ) if defined( $y );
my $step = $self->forward_horizon;
my $half_step = int( ($step/2) );
$self->set_direction('y_plus');
# swoop down on a rectangle (we hope)
$y = $self->scan_for_edgey_pixpat($x, $y) || return;
$y = $self->set_cursor_y( $y + $half_step ); # step a little closer
(undef, $y) = @{ $self->center_on_edge( $x, $y ) }; # remember: the edge is a half_step lower.
my $rect = $self->trace_box( $x, $y ) || return;;
if( $self->looks_rectangular( $rect ) ) {
return $rect;
} else {
return;
}
}
=item boxfind_here_or_downward
Looks at both the current location, and also looks some
indefinite distance below, to attempt to find a
rectangle.
This is like L<boxfind_downward_recenter> above,
EXCEPT: since this may return more than one rect, it must
use a "list of rects" data structure for it's return.
=cut
sub boxfind_here_or_downward {
my $self = shift;
my $x = shift;
my $y = shift;
$self->set_cursor_x( $x ) if defined( $x );
$self->set_cursor_y( $y ) if defined( $y );
my $rect_list = [];
my $step = $self->forward_horizon;
my $half_step = int( ($step/2) );
# try the possibility that we're already on the top border of a box
if( my $rect = $self->trace_box( $x, $y ) ) {
push @{ $rect_list }, $rect;
}
$self->set_direction('y_plus');
# swoop down on a rectangle (we hope)
$y = $self->scan_for_edgey_pixpat($x, $y) || return;
$y = $self->set_cursor_y( $y + $half_step ); # step a little closer
(undef, $y) = @{ $self->center_on_edge( $x, $y ) }; # remember: the edge is a half_step lower.
if( my $rect = $self->trace_box( $x, $y ) ) {
push @{ $rect_list }, $rect;
}
return $rect_list;
}
=back
=head2 boxfind utilities
Common code factored out from the above boxfind_* methods.
=over
=item trace_box
Given an x and y value, presumes that that location is right on the
top edge of a rectangle. It traces the sides of the rectangle
(internally using the "follow_pixpat_*" routines and "center_on_edge")
and returns a rect data structure or undef if one is not found.
=cut
sub trace_box {
my $self = shift;
my $x = shift;
my $y = shift;
my (@rect, $point);
my $step = $self->forward_horizon;
my $half_step = int( ($step/2) );
# do corner 1
# sweep to the right, step foward, save corner
$point = $self->follow_pixpat_x_plus( $x, $y);
unless( $point ) { return; }
$x = $point->[0] + $half_step;
$rect[1] = [ ($x + $half_step), ($y + $half_step) ];
# nudge down, change direction, *then* center on edge
$y += 2 * $step;
$self->direction('y_plus');
($x, undef) = @{ $self->center_on_edge( $x, $y ) }; # remember: the edge is a half_step right
# do corner 2
# now down the right side to the bottom, step down, save corner
$point = $self->follow_pixpat_y_plus( $x, $y );
unless( $point ) { return; }
$y = $point->[1] + $half_step;
$rect[2] = [ ($x + $half_step), ($y + $half_step) ];
# nudge left, change direction, then center on edge
$x -= 2 * $step;
$self->direction('x_minus');
(undef, $y) = @{ $self->center_on_edge( $x, $y ) };
# do corner 3
# across to the left edge, half-step forward, save corner
$point = $self->follow_pixpat_x_minus( $x, $y );
unless( $point ) { return; }
$x = $point->[0] - $half_step; # nudge to the left, put spot on top of the corner
$rect[3] = [ ($x + $half_step), ($y + $half_step) ];
# nudge up, change direction, then center on edge
$y -= 2 * $step;
$self->direction('y_minus');
($x, undef) = @{ $self->center_on_edge( $x, $y ) };
# do corner 0
# up to the upper-left corner (we hope), half-step forward, save corner
$point = $self->follow_pixpat_y_minus( $x, $y );
unless( $point ) { return; }
$y = $point->[1] - $half_step;
$rect[0] = [ ($x + $half_step), ($y + $half_step) ];
if( $self->looks_rectangular( \@rect ) ) {
return \@rect;
} else {
return;
}
}
=back
=head2 Debugging Utilities
=over
=item dump_boxes
Takes a list of rectangles and pretty-prints them to STDOUT.
=cut
sub dump_boxes {
my $self = shift;
my $rectangles = shift;
my $text = $self->dump_boxes_to_string( $rectangles );
print $text;
}
=item dump_boxes_to_string
Takes a list of rectangles and pretty-prints them to a string.
=cut
sub dump_boxes_to_string {
my $self = shift;
my $rectangles = shift;
my $text = '';
foreach my $r (@{ $rectangles }) {
$text .=
sprintf "( %4d, %4d ), ( %4d, %4d ), ( %4d, %4d ), ( %4d, %4d )\n",
$r->[0][0],
$r->[0][1],
$r->[1][0],
$r->[1][1],
$r->[2][0],
$r->[2][1],
$r->[3][0],
$r->[3][1];
}
return $text;
}
=item print_box
Given a single rectangle, pretty-prints it to STDOUT.
=cut
sub print_box {
my $self = shift;
my $r = shift;
my $text =
sprintf "( %4d, %4d ), ( %4d, %4d ), ( %4d, %4d ), ( %4d, %4d )",
$r->[0][0],
$r->[0][1],
$r->[1][0],
$r->[1][1],
$r->[2][0],
$r->[2][1],
$r->[3][0],
$r->[3][1];
print "$text\n";
}
=item print_box_to_string
Given a single rectangle, returns a pretty-printed string.
=cut
sub print_box_to_string {
my $self = shift;
my $r = shift;
return '' unless defined( $r );
return '' unless ( ref( $r ) eq 'ARRAY');
my $text =
sprintf "( %4d, %4d ), ( %4d, %4d ), ( %4d, %4d ), ( %4d, %4d )",
$r->[0][0],
$r->[0][1],
$r->[1][0],
$r->[1][1],
$r->[2][0],
$r->[2][1],
$r->[3][0],
$r->[3][1];
return $text;
}
=item adjustable_parameter_report
Dumps a report of the "adjustable parameters" in the
object data.
=cut
sub adjustable_parameter_report {
my $self = shift;
my $cursor_x = $self->cursor_x || '';
my $cursor_y = $self->cursor_y || '';
my $direction = $self->direction || '';
my $step_y = $self->step_y || '';
my $step_x = $self->step_x || '';
my $forward_horizon = $self->forward_horizon || '';
my $transverse_horizon = $self->transverse_horizon || '';
my $step_back = $self->step_back || '';
my $beware = $self->beware || '';
my $fuzziness = $self->fuzziness || '';
my $pixpat_threshold = $self->pixpat_threshold || '';
my $minimum_width = $self->minimum_width || '';
my $minimum_height = $self->minimum_height || '';
my $edge_contrast_cutoff = $self->edge_contrast_cutoff || '';
my $color_distance_threshold = $self->color_distance_threshold || '';
my $luminance_threshold = $self->luminance_threshold || '';
my $spotsize_y = $self->spotsize_y || '';
my $spotsize_x = $self->spotsize_x || '';
my $ignore_subtle_pixpat_change = $self->ignore_subtle_pixpat_change || '';
my $pixpat_delta_method = $self->pixpat_delta_method || '';
my $edge_detect = $self->edge_detect || '';
my $color_diff = $self->color_diff || '';
my $change_detector = $self->change_detector || '';
my $refocus_factor = $self->refocus_factor || '';
my $report =<<"REPORT_END";
Adjustable Parameters Report:
cursor_x: $cursor_x cursor_y: $cursor_y direction: $direction
step_y: $step_y forward_horizon: $forward_horizon
step_x: $step_x transverse_horizon: $transverse_horizon
step_back: $step_back refocus_factor: $refocus_factor
beware: $beware
fuzziness: $fuzziness pixpat_threshold: $pixpat_threshold
minimum_width: $minimum_width minimum_height: $minimum_height
edge_contrast_cutoff: $edge_contrast_cutoff
color_distance_threshold: $color_distance_threshold
luminance_threshold: $luminance_threshold
spotsize_y: $spotsize_y spotsize_x: $spotsize_x
pixpat_delta_method: $pixpat_delta_method
ignore_subtle_pixpat_change: $ignore_subtle_pixpat_change
REPORT_END
return $report;
}
# TODO not using these now (?) so skipping.
# edge_detect: $edge_detect
# color_diff: $color_diff
# change_detector: $change_detector
=item draw_rects_corners
Applies the Image::Magick "Edge" image filter to the current
image, using the value of the B<edge_detect> attribute as a
"radius" argument.
=cut
sub draw_rects_corners {
my $self = shift;
my $rects = shift;
my $imh = $self->imh;
foreach my $rect ( @{ $rects } ) {
foreach my $corner ( @{ $rect } ) {
my $x = $corner->[0];
my $y = $corner->[1];
$err =
$imh->Set("pixel[$x,$y]"=>'red');
carp "$err" if "$err";
}
}
$self->save_image_using_suffix('rex');
}
=item draw_rects
Applies the Image::Magick "Edge" image filter to the current
image, using the value of the B<edge_detect> attribute as a
"radius" argument.
=cut
sub draw_rects {
my $self = shift;
my $rects = shift;
my $imh = $self->imh;
my $color = $self->color;
foreach my $rect ( @{ $rects } ) {
my ($x0, $y0) = @{ $rect->[0] };
my ($x2, $y2) = @{ $rect->[2] };
my $width = $rect->[1][0] - $rect->[0][0];
my $height = $rect->[3][1] - $rect->[0][1];
# $imh->Draw( "primitive=>rectangle, x=>$x0, y=>$y0, scale=>$width, $height" );
$err =
$imh->Draw(stroke=>"$color", primitive=>'rectangle', points=>"$x0,$y0 $x2,$y2");
carp "$err" if "$err";
}
$self->save_image_using_suffix('rex');
}
=back
=head2 DEPRECATED
Methods that might not be that useful, but are
reasonably well tested.
=over
=item scan_down_one_pix
Scans vertically, until a change in color is detected.
Sets the cursor at new location.
Detects a single-pixel change of any quantity.
=cut
sub scan_down_one_pix {
my $self = shift;
my $imh = $self->imh;
my $x = $self->cursor_x;
my $cursor_y = $self->cursor_y;
my $y_bound = $self->image_height;
my $initial_color = $imh->Get("pixel[$x,$cursor_y]");
for my $y ($cursor_y .. $y_bound) {
my $color_string = $imh->Get("pixel[$x,$y]");
$self->debug("$color_string at ($x, $y)\n");
if ($color_string ne $initial_color) {
$self->set_cursor_y( $y );
return $y;
}
}
return; # undef for failure
}
=item scan_right_one_pix
Scans horizontally, until a change in color is detected.
Sets the cursor at new location.
Detects a single-pixel change of any quantity.
=cut
sub scan_right_one_pix {
my $self = shift;
my $imh = $self->imh;
my $y = $self->cursor_y;
my $cursor_x = $self->cursor_x;
my $x_bound = $self->image_width;
my $initial_color = $imh->Get("pixel[$cursor_x,$y]");
for my $x ($cursor_x .. $x_bound) {
my $color_string = $imh->Get("pixel[$x,$y]");
if ($color_string ne $initial_color) {
$self->set_cursor_x($x);
return $x;
}
}
return; # undef for failure
}
=back
=head2 special setters with side-effects
=over
=item set_direction
Setter for object attribute "direction".
Side-effect: sets the spotsize in the forward direction to the
"forward_horizon", and the spotsize in the transverse direction
to the "transverse_horizon".
=cut
sub set_direction {
my $self = shift;
my $direction = shift;
$self->{ direction } = $direction;
# TODO strip this check when "in production" ?
if (not (defined( $direction ) ) ) {
confess("set_direction: undefined arg");
} elsif ( not( $direction =~ m/_/ ) ) {
confess("set_direction: odd arg sans '_': $direction");
} elsif ( not( $direction =~ m{ ^ [xy] }ix ) ) {
confess("set_direction: odd arg sans 'x or y': $direction");
};
# twiddle spotsize depending on direction of motion
my $x_or_y = ( split( /_/, $direction ) )[0];
if ($x_or_y eq 'x') {
$self->set_spotsize_x( $self->forward_horizon );
$self->set_spotsize_y( $self->transverse_horizon );
} elsif ($x_or_y eq 'y') {
$self->set_spotsize_x( $self->transverse_horizon );
$self->set_spotsize_y( $self->forward_horizon );
}
return $direction;
}
=back
=head2 setters and getters
The naming convention used:
setters begin with "set_", I<but> getters have *no* prefix.
This is on the principle that the most commonly used case
deserves the simplest syntax
(Note: in general mutators are now deprecated, see Conway "Best Practices").
These accessors exist for all of the object attributes
(documented above) irrespective of whether they're expected to be
externally useful. Note: no leading underscores have been used
to indicate "internal" use.
=head2 special getters
=over
=item direction_axis
A wrapper around the getter for L<direction>, that returns only
the first portion of it, the axis: "x" or "y".
=cut
sub direction_axis {
my $self = shift;
my $direction = $self->direction;
my $axis = ( split( /_/, $direction ) )[0];
return $axis;
}
=item direction_sign
A wrapper around the getter for L<direction>, that returns only
the second portion of it, the sign "+" or "-".
Note: the internal codes 'plus' and 'minus' are converted to the
mathematical symbols.
=cut
sub direction_sign {
my $self = shift;
my $direction = $self->direction;
my $sign = ( split( /_/, $direction ) )[1];
if ($sign eq 'plus') {
$sign = '+';
} elsif ( $sign eq 'minus') {
$sign = '-';
}
return $sign;
}
=back
=head2 automatic generation of accessors
=over
=item AUTOLOAD
=cut
sub AUTOLOAD {
return if $AUTOLOAD =~ /DESTROY$/; # skip calls to DESTROY ()
my ($name) = $AUTOLOAD =~ /([^:]+)$/; # extract method name
(my $field = $name) =~ s/^set_//;
# check that this is a valid accessor call
croak("Unknown method '$AUTOLOAD' called")
unless defined( $ATTRIBUTES{ $field } );
{ no strict 'refs';
# create the setter and getter and install them in the symbol table
if ( $name =~ /^set_/ ) {
$name = sub {
my $self = shift;
$self->{ $field } = shift;
return $self->{ $field };
};
goto &$name; # jump to the new method.
} elsif ( $name =~ /^get_/ ) {
carp("Apparent attempt at using a getter with unneeded 'get_' prefix.");
}
$name = sub {
my $self = shift;
return $self->{ $field };
};
goto &$name; # jump to the new method.
}
}
1;
=back
=head1 Discussion
Representing a rectangle as four points may seem excessive:
mathematically, this is twice as much information as is necessary
(e.g. postgresql's "box" geometric datatype uses only two
diagonally opposite points, alternately a rectangle could be
represented by a single point plus width and height).
Using all four corners is a convenience suited to the way this
code tries to identify rectangles: crawling along the edges from
corner-to-corner, only checking later to make sure they line up
with each other. Also, the redundant specification allows a
certain amount of spatial fuzziness: the alignment need not be
perfect in order for us to call it "rectangular". To reduce our
rectangles to postgresql's box-type, we would need to throw away
some information (possibly by taking averages of each of the x
and y coordinates).
=head2 data structures
A rectangle example:
$rect =
[
[ 20, 66 ],
[ 20, 99 ],
[ 130, 99 ],
[ 130, 66 ]
];
(( TODO add an example of a list of rectangles? ))
=head1 SEE ALSO
http://obsidianrook.com/Perl/image-boxfind
=head1 AUTHOR
Joseph Brenner, E<lt>doom@kzsu.stanford.eduE<gt>,
28 Sep 2007
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2007 by Joseph Brenner
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.2 or,
at your option, any later version of Perl 5 you may have available.
=head1 BUGS
None reported... yet.
=cut
Joseph Brenner,
Tue Nov 27 17:40:02 2007