Fun with image transformations in Perl

I came across American Gothic in the palette of Mona Lisa: Rearrange the pixels thanks to Reddit.

Basically, the task is to:

… create an algorithm that makes the most accurate looking copy of the Source by only using the pixels in the Palette. Each pixel in the Palette must be used exactly once in a unique position in this copy. The copy must have the same dimensions as the Source.

There are some interesting animations on that page. But, honestly, I couldn’t bring myself to read through a lot of Java and Python. I immediately wondered how far I could get by using a rather naive method.

What I had in mind was this: First, given a source image with no more pixels than the palette image, sort the pixels in both images into a list of (color, coordinate) tuples by the 24-bit RGB value of the pixel color. Second, extract from the source pixel list just the coordinates, and from the palette pixel list just the colors. Finally, go through source image coordinates, setting the color of each pixel to the color in list of palette image pixel colors.

Yeah, OK, so I am not matching on the basis of color perception in radiation damaged mosquito eyes or some such scientific principle, but, still, the world is full of awful stuff these days, and I wanted to entertain myself for a few minutes.

I reached for an old favorite, GD::Image.

Here is the heart of the script:

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}
    ];
}

pack_rgb is simple: sub pack_rgb { $_[0] << 16 | $_[1] << 8 | $_[2] }.

I only want the coordinates from the source image:

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

And, from the palette image, I just want the colors:

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

That sprintf isn’t really necessary at all, but it does help if you have to print stuff to figure out a silly error. 00ef0812 is much more meaningful than 15665170.

The following function does the mapping:

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});
    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);
}

First, we create a hash %colors to store the color indexes we need to create via GD::Image->colorAllocate.

Then, it is just a matter of looping through each source coordinate, and setting the color at that pixel to the corresponding one from the palette image. I wanted to generate short animations of the transformations as well, so I also pass this routine a save callback.

Again, I couldn’t be bothered with fancy math(!) trying to ensure the completed bitmap was also saved, so, to make up for my laziness, this function returns the final frame.

The results are not spectacular, but not completely disgusting either. Generating the 101 frames takes about 5 seconds for each image pair on my old MacBook Pro.

Here are some examples thanks to ffmpeg: