2 Put in a short description of what the code does
source | link

Perl

Here is a rather simplistic approach using Perl. It takes about five seconds to generate 100 frames per image pair on my MacBook Pro with a memory footprint of about 120 MB.

The idea is to sort the pixels in both and palette images by 24-bit packed RGB, and replace colors in the source with colors from the palette sequentially.

River using Marbles colors

Animations

I was lazy, so I put the animations on YouTube: Mona Lisa using colors from Starry Night and American Gothic using colors from Mona Lisa .

Here is a rather simplistic approach using Perl. It takes about five seconds to generate 100 frames per image pair on my MacBook Pro with a memory footprint of about 120 MB.

River using Marbles colors

Perl

Here is a rather simplistic approach. It takes about five seconds to generate 100 frames per image pair on my MacBook Pro with a memory footprint of about 120 MB.

The idea is to sort the pixels in both and palette images by 24-bit packed RGB, and replace colors in the source with colors from the palette sequentially.

River using Marbles colors

Animations

I was lazy, so I put the animations on YouTube: Mona Lisa using colors from Starry Night and American Gothic using colors from Mona Lisa .

1
source | link

Here is a rather simplistic approach using Perl. It takes about five seconds to generate 100 frames per image pair on my MacBook Pro with a memory footprint of about 120 MB.

#!/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);
}

Output

Scream using Starry Night palette

Scream using Starry Night palette

American Gothic using Mona Lisa colors

American Gothic using Mona Lisa colors

Mona Lisa using Scream colors

Mona Lisa using Scream colors

River using Marbles colors

River using Marbles colors