From c58bbc3a8368dc96f1a07e2ee3bf0825c9e2af34 Mon Sep 17 00:00:00 2001
From: Jesse Luehrs <doy@tozt.net>
Date: Tue, 7 Oct 2014 15:43:18 -0400
Subject: implement P4

---
 lib/Image/PNM.pm |  79 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 t/P1.t           |   6 +++++
 t/P2.t           |   6 +++++
 t/P3.t           |   6 +++++
 t/P4.t           |  63 ++++++++++++++++++++++++++++++++++++++++++++
 t/data/P4.pbm    | Bin 0 -> 54 bytes
 6 files changed, 160 insertions(+)
 create mode 100644 t/P4.t
 create mode 100644 t/data/P4.pbm

diff --git a/lib/Image/PNM.pm b/lib/Image/PNM.pm
index 5136220..b927b44 100644
--- a/lib/Image/PNM.pm
+++ b/lib/Image/PNM.pm
@@ -138,6 +138,36 @@ HEADER
     return $data;
 }
 
+sub _as_string_P4 {
+    my $self = shift;
+
+    my $data = <<HEADER;
+P4
+$self->{w} $self->{h}
+HEADER
+
+    for my $row (@{ $self->{pixels} }) {
+        my @vals = map {
+            my $val;
+            if (ref($_)) {
+                $val = $self->_to_greyscale(@$_);
+            }
+            else {
+                $val = $_;
+            }
+            $val * 2 > $self->{max} ? '0' : '1'
+        } @$row;
+        push @vals, '0' until @vals % 8 == 0;
+        while (@vals) {
+            my $bits = join('', splice(@vals, 0, 8));
+            my $byte = oct("0b$bits");
+            $data .= pack("C", $byte);
+        }
+    }
+
+    return $data;
+}
+
 sub _parse_string {
     my $self = shift;
     my ($string) = @_;
@@ -253,6 +283,24 @@ sub _parse_pnm_P3 {
     }
 }
 
+sub _parse_pnm_P4 {
+    my $self = shift;
+    my ($next_line) = @_;
+
+    $self->{max} = 1;
+
+    my $next_word = $self->_make_next_bitfield($next_line, 1);
+
+    $self->{pixels} = [];
+    for my $i (1..$self->{h}) {
+        my $row = [];
+        for my $j (1..$self->{w}) {
+            push @$row, $next_word->() ? '0' : '1';
+        }
+        push @{ $self->{pixels} }, $row;
+    }
+}
+
 sub _make_next_word {
     my $self = shift;
     my ($next_line, $ws) = @_;
@@ -277,6 +325,37 @@ sub _make_next_word {
     };
 }
 
+sub _make_next_bitfield {
+    my $self = shift;
+    my ($next_line, $bits) = @_;
+
+    my @words;
+    return sub {
+        if (!@words) {
+            my $line = $next_line->();
+            return unless $line;
+            if ($bits) {
+                my $padding = 8 - ($self->{w} % 8);
+                my $per = int($self->{w} / 8) + 1;
+                while (length($line)) {
+                    my $chunk = substr($line, 0, $per, '');
+                    push @words, map {
+                        split '', sprintf("%08b", $_)
+                    } unpack("C*", $chunk);
+                    pop @words for 1..$padding;
+                }
+            }
+            else {
+                @words = unpack("C*", $line);
+            }
+        }
+        my $word = shift @words;
+        die "Invalid color: $word"
+            unless $word =~ /^[0-9]+$/ && $word >= 0 && $word <= $self->{max};
+        return $word;
+    };
+}
+
 sub _to_greyscale {
     my $self = shift;
     my ($r, $g, $b) = @_;
diff --git a/t/P1.t b/t/P1.t
index 9e0bf14..030634b 100644
--- a/t/P1.t
+++ b/t/P1.t
@@ -54,4 +54,10 @@ P3
 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
 IMAGE
 
+is($image->as_string('P4') . "\n", <<IMAGE);
+P4
+6 8
+\x00\x30\x48\x84\xfc\x84\x84\x00
+IMAGE
+
 done_testing;
diff --git a/t/P2.t b/t/P2.t
index e7b7fdc..6ff8a29 100644
--- a/t/P2.t
+++ b/t/P2.t
@@ -54,4 +54,10 @@ P3
 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255
 IMAGE
 
+is($image->as_string('P4') . "\n", <<IMAGE);
+P4
+6 8
+\x00\x30\x48\x84\xfc\x84\x84\x00
+IMAGE
+
 done_testing;
diff --git a/t/P3.t b/t/P3.t
index fd55b8d..925b2d7 100644
--- a/t/P3.t
+++ b/t/P3.t
@@ -54,4 +54,10 @@ P3
 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255
 IMAGE
 
+is($image->as_string('P4') . "\n", <<IMAGE);
+P4
+6 8
+\x00\x30\x48\x84\xfc\x84\x84\x00
+IMAGE
+
 done_testing;
diff --git a/t/P4.t b/t/P4.t
new file mode 100644
index 0000000..9655658
--- /dev/null
+++ b/t/P4.t
@@ -0,0 +1,63 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Image::PNM;
+
+my $image = Image::PNM->new('t/data/P4.pbm');
+
+is($image->width, 6);
+is($image->height, 8);
+is($image->max_pixel_value, 1);
+is_deeply($image->raw_pixel(1, 2), [0, 0, 0]);
+is_deeply($image->pixel(4, 1), [0, 0, 0]);
+
+is($image->as_string('P1'), <<IMAGE);
+P1
+6 8
+0 0 0 0 0 0
+0 0 1 1 0 0
+0 1 0 0 1 0
+1 0 0 0 0 1
+1 1 1 1 1 1
+1 0 0 0 0 1
+1 0 0 0 0 1
+0 0 0 0 0 0
+IMAGE
+
+is($image->as_string('P2'), <<IMAGE);
+P2
+6 8
+1
+1 1 1 1 1 1
+1 1 0 0 1 1
+1 0 1 1 0 1
+0 1 1 1 1 0
+0 0 0 0 0 0
+0 1 1 1 1 0
+0 1 1 1 1 0
+1 1 1 1 1 1
+IMAGE
+
+is($image->as_string('P3'), <<IMAGE);
+P3
+6 8
+1
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+1 1 1 1 1 1 0 0 0 0 0 0 1 1 1 1 1 1
+1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1
+0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0
+0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+IMAGE
+
+is($image->as_string('P4') . "\n", <<IMAGE);
+P4
+6 8
+\x00\x30\x48\x84\xfc\x84\x84\x00
+IMAGE
+
+done_testing;
diff --git a/t/data/P4.pbm b/t/data/P4.pbm
new file mode 100644
index 0000000..3512376
Binary files /dev/null and b/t/data/P4.pbm differ
-- 
cgit v1.2.3