pamtostipje.pl

#!/usr/bin/env perl

# Convert a PAM image to C++ stipje source-code.
#
# PNG Example (requires netpbm tools, imagemagick might work as well):
#
# % pngtopam -alphapam < lena.png | pamtostipje.pl lena rgba > lena.hh
#
# PAM image data is accepted on stdin.

# Copyright (c) 2018, Chris Smeele
#
# Boost Software License - Version 1.0 - August 17th, 2003
#
# Permission is hereby granted, free of charge, to any person or organization
# obtaining a copy of the software and accompanying documentation covered by
# this license (the "Software") to use, reproduce, display, distribute,
# execute, and transmit the Software, and to prepare derivative works of the
# Software, and to permit third-parties to whom the Software is furnished to
# do so, all subject to the following:
#
# The copyright notices in the Software and this entire statement, including
# the above license grant, this restriction and the following disclaimer,
# must be included in all copies of the Software, in whole or in part, and
# all derivative works of the Software, unless such copies or derivative
# works are solely in the form of machine-executable object code generated by
# a source language processor.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT
# SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE
# FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE,
# ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.

use 5.12.0;
use warnings;
use utf8;
binmode STDOUT, ':utf8';

# Alphabets.
# The smallest possible alphabet will be chosen, depending on the number of colors.
my @ALPHAS = (
    ['',  split //, q<# >],
    ['',  split //, q<#- >],
    ['',  split //, q<#=- >],
    ['',  split //, q<#%=- >],
    ['',  split //, q<#%?=- >],
    ['',  split //, q<#%[?=- >],
    ['',  split //, q<#%[?/=- >],
    ['',  split //, q<#%[?/=-. >],
    ['',  split //, q<#%[?/*=-. >],
    ['',  split //, q<#%[?/*=-,. >],
    ['',  split //, q<#%[?/!*=-,. >],
    ['',  split //, q<#@&%$?!;*=+^~-',. >],
    ['',  split //, q<#@&%$?}{][)(/<>!;:*=+^~-'`,. >],
    ['',  split //, q<#@&%$9876543210ZYXWVUTSRQPONMLKJIHGFEDCBAzyxwvutsrqponmlkjihgfedcba?}{][)(/<>!;:*=+^~-'`,. >],

    ['u', reverse map chr, 0x2800 .. 0x28ff], # 256 braille characters, not strictly sorted by weight.
);

sub pixel_order {
    # Pixel value (ABGR uint32) => approximate "whiteness" value (transparent pixels count as "whiter" than white).
    my ($r,$g,$b,$a) = unpack "C*", pack "N", shift;
    $a ? ($r + $g + $b) * ($a / 255) : 99999999
};

my $name   = shift // die "usage: $0 symname <rgba|abgr> [filename]" ;
my $format = shift;

my $file = do { local $/; <> };

die "Could not parse PAM P7 header" unless $file =~ /^P7\s*(.*?)ENDHDR\n(.*)$/s;
my ($header, $body) = ($1, $2);
my %header = map { /^(\S+)\s+(\S+)$/ and $1 => $2 } split /\n/, $header;

unless ($header{TUPLTYPE} eq "RGB_ALPHA"
    and $header{DEPTH}  == 4
    and $header{MAXVAL} == 255) {

    say STDERR "$_ => $header{$_}" for keys %header;
    die "Unsupported PAM format";
}

my @body = unpack "N*", $body;
my %colors = map {$_ => 1} @body;

my $ncolors = scalar %colors;

my ($is16, @alpha) = do {
    my @q = grep { $ncolors <= (@$_ - 1) } @ALPHAS; # subtract 'u'.
    die "No palettes available for that many colors (max " . $#{$ALPHAS[$#ALPHAS]} . ")"
        unless @q;
    @{$q[0]}
};

die "Too many colors (max ".(scalar(@alpha)).")" if $ncolors > @alpha;

print "constexpr auto $name =\n";

{ my $i = 0;
  %colors = map {
      $_ => $alpha[$i++]
  } sort {
      pixel_order($a) <=> pixel_order($b)
  } keys %colors; }

my @colors = sort { pixel_order($a) <=> pixel_order($b) } keys %colors;
$colors{$colors[$#colors]} = ' '; # Heheh.

for my $row (0..($header{HEIGHT}-1)) {
    print $is16.'"';
    for my $col (0..($header{WIDTH}-1)) {
        print $colors{$body[$row * $header{WIDTH} + $col]};
    }
    print '"';
    print "\n" if $row < $header{HEIGHT}-1;
}

sub group {
    # Make into arrayrefs of max $n members.
    my $n = shift;
    my (@a, @c);
    for (@_) {
        push @c, $_;
        if (@c == $n) { push @a, [@c]; @c = () }
    }
    push @a, [@c] if @c;
    @a
}

print "_stipje\n(";
print join "\n ",
    map join(" ", @$_),
    group $ncolors > 16 ? 8 : 1,
    map sprintf('%s"%s %08x"', $is16, $colors{$_}, $_),
    sort { pixel_order($a) <=> pixel_order($b) }
    keys %colors;

print <<EOF;
_stipje_palette,
 uint_<$header{WIDTH}> {},
 uint_<$header{HEIGHT}> {},
 stipje::pixel_format::$format\{});
EOF