find_faces.pl

#!/usr/bin/perl

# Use OpenCV to detect faces in photos
# Most of this is take directly from a presentation at Ruhr.pm by Simon Wilper
# http://ruhr.pm.org/files/opencv/docshot/

use strict;
use warnings;
use 5.010;

use Image::ObjectDetect;
use Image::Magick;
use File::Next;
use File::Spec;

my $pic_src  = '/mnt/pics/medium/2009';
my $face_dst = '/tmp/faces/';
my $cascade  = '/usr/share/opencv/haarcascades/haarcascade_frontalface_alt.xml';

# haarcascade_frontalface_alt.xml       haarcascade_fullbody.xml
# haarcascade_frontalface_alt2.xml      haarcascade_lowerbody.xml
# haarcascade_frontalface_alt_tree.xml  haarcascade_profileface.xml
# haarcascade_frontalface_default.xml   haarcascade_upperbody.xml

mkdir $face_dst;
my $detector = Image::ObjectDetect->new($cascade);
my $files    = File::Next::files( {
        file_filter => sub { /\.jpg$/i }
    },
    $pic_src
);

while ( defined( my $file = $files->() ) ) {
    my @faces = $detector->detect($file);
    printf "%s -> %d\n", $file, scalar @faces;

    next unless @faces;
    ( my $new_file = $file ) =~ s{(/mnt/pics/medium/|/)}{}g;
    say "\t$new_file";

    # This commented out section will save the found faces to individual
    # files...
    # my $i = 1;
    # $im->Read($file);
    # for my $face (@faces) {
    #     my $cropped_face = $im->Clone;
    #     $cropped_face->Crop(
    #         geometry => sprintf( "%dx%d+%d+%d",
    #             $face->{x}, $face->{y}, $face->{width}, $face->{height} ) );
    #     $cropped_face->Write( File::Spec->catfile( $face_dst, $i++ . ".jpg" ) );
    # }

    # Put a box around each detected face
    my $im = Image::Magick->new;
    $im->Read($file);
    for my $face (@faces) {
        $im->Draw(
            primitive => 'rectangle',
            points    => sprintf( "%d,%d %d,%d",
                $face->{x},                  $face->{y},
                $face->{x} + $face->{width}, $face->{y} + $face->{height} ),
            stroke      => 'red',
            strokewidth => 2,
            antialias   => 1,
            fill        => 'rgba(100%,100%,0%,0.3)',
        );
    }
    $im->Write( File::Spec->catfile( $face_dst, $new_file ) );
}