The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#!perl
use strict;
use warnings;
use Getopt::Long;
use Pod::Usage;
use Imager;
use Imager::Fill;
use List::Util qw(max);
use Image::CCV qw(sift);

use vars qw($VERSION);
$VERSION = '0.10';

=pod

Command-line options are:

=over 2

=item *

C<--scene> - image of a scene to use

=item *

C<--object> - image of an object to use

=item *

C<--object> - filename of output file, defaults to out.png

=cut

pod2usage(1) unless @ARGV;
GetOptions(
    'scene|s:s'   => \my $scene,
    'object|t:s'  => \my $object, # t=thing
    'output|o:s'  => \my $output,
) or pod2usage();

die "scene image-file: $scene not found!" unless -f $scene;
die "object image-file: $object not found!" unless -f $object;

$output ||= 'out.png';
print "output file: $output \n";

my @coords = sift( $object, $scene, );
print "@$_\n" for @coords;

my $scene_image = Imager->new( file => $scene );
my $object_image = Imager->new( file => $object );

my $xsize = $scene_image->getwidth + $object_image->getwidth;
my $ysize = max( $scene_image->getheight, $object_image->getheight);

my $out = Imager->new(
    xsize => $xsize,
    ysize => $ysize,
);

# paste the two input images side by side
$out->rubthrough(
    src => $scene_image,
    tx => 0, ty => 0,
    src_minx => 0,
    src_maxx => $scene_image->getwidth-1,
    src_miny => 0,
    src_maxy => $scene_image->getheight-1,
);

my $obj_ofs_x = $scene_image->getwidth;
my $obj_ofs_y = 0;

$out->rubthrough(
    src => $object_image,
    tx => $obj_ofs_x, ty => $obj_ofs_y,
    src_minx => 0,
    src_maxx => $object_image->getwidth-1,
    src_miny => 0,
    src_maxy => $object_image->getheight-1,
);

my @points = @coords;

my $green = Imager::Color->new( 0, 255, 0 );
for (@points) {
    $out->line(
        color => $green,
        x1 => $_->[0]+$obj_ofs_x,
        y1 => $_->[1]+$obj_ofs_y,
        x2 => $_->[2],
        y2 => $_->[3],
    );
};

$out->write( file => $output )
    or die $out->errstr;