Fun with image transformations in Perl: American Gothic in the palette of Mona Lisa: Rearrange the pixels

imgxform.pl

#!/usr/bin/env perl

use 5.020; # just because
use strict;
use warnings;

use Const::Fast;
use GD;
GD::Image->trueColor(1);

use Path::Class;

const my $COLOR => 0;
const my $COORDINATES => 1;
const my $RGB => 2;
const my $ANIMATION_FRAMES => 100;

const my %MASK => (
    RED => 0x00ff0000,
    GREEN => 0x0000ff00,
    BLUE => 0x000000ff,
);

run(@ARGV);

sub run {
    unless (@_ == 2) {
        die "Need source and palette images\n";
    }
    my $source_file = file(shift)->resolve;
    my $palette_file = file(shift)->resolve;

    my $source = GD::Image->new("$source_file")
        or die "Failed to create source image from '$source_file'";
    my $palette = GD::Image->new("$palette_file")
        or die "Failed to create palette image from '$palette_file'";

    my %source =  map { $_ => $source->$_ } qw(width height);
    my %palette = map { $_ => $palette->$_ } qw(width height);
    my ($frame_prefix) = ($source_file->basename =~ /\A([^.]+)/);

    unless (
        (my $source_area = $source{width} * $source{height}) <=
        (my $palette_area = $palette{width} * $source{height})
    ) {
        die "Source area ($source_area) is greater than palette area ($palette_area)";
    }

    my ($last_frame, $png) = recreate_source_image_from_palette(
        \%source,
        get_source_pixels( get_pixels_by_color($source, \%source) ),
        get_palette_colors( get_pixels_by_color($palette, \%palette) ),
        sub { save_frame($frame_prefix, @_) }
    );

    save_frame($frame_prefix, $last_frame, $png);
    return;
}

sub save_frame {
    my $frame_prefix = shift;
    my $frame = shift;
    my $png = shift;
    file(
        sprintf("${frame_prefix}-%d.png", $frame)
    )->spew(iomode => '>:raw', $$png);
    return;
}

sub recreate_source_image_from_palette {
    my $dim = shift;
    my $source_pixels = shift;
    my $palette_colors = shift;
    my $callback = shift;
    my $frame = 0;

    my %colors;
    $colors{$_} = undef for @$palette_colors;

    my $gd = GD::Image->new($dim->{width}, $dim->{height}, 1);
    for my $x (keys %colors) {
          $colors{$x} = $gd->colorAllocate(unpack_rgb($x));
    }

    my $period = sprintf '%.0f', @$source_pixels / $ANIMATION_FRAMES;
    for my $i (0 .. $#$source_pixels) {
        $gd->setPixel(
            @{ $source_pixels->[$i] },
            $colors{ $palette_colors->[$i] }
        );
        if ($i % $period == 0) {
            $callback->($frame, \ $gd->png);
            $frame += 1;
        }
    }
    return ($frame, \ $gd->png);
}

sub get_palette_colors { [ map sprintf('%08X', $_->[$COLOR]), @{ $_[0] } ] }

sub get_source_pixels { [ map $_->[$COORDINATES], @{ $_[0] } ] }

sub get_pixels_by_color {
    my $gd = shift;
    my $dim = shift;
    return [
        sort { $a->[$COLOR] <=> $b->[$COLOR] }
        map {
            my $y = $_;
            map {
                [ pack_rgb( $gd->rgb( $gd->getPixel($_, $y) ) ), [$_, $y] ];
            } 0 .. $dim->{width}
        } 0 .. $dim->{height}
    ];
}

sub pack_rgb { $_[0] << 16 | $_[1] << 8 | $_[2] }

sub unpack_rgb {
    my ($r, $g, $b) = map $MASK{$_} & hex($_[0]), qw(RED GREEN BLUE);
    return ($r >> 16, $g >> 8, $b);
}