From 3c1d24af6e0250839358b1c9cab8094ee975ea1a Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sat, 3 Aug 2024 20:57:38 +0900
Subject: Support PBM format

---
 pnm/read.scm | 39 ++++++++++++++++++++++++---------------
 1 file changed, 24 insertions(+), 15 deletions(-)

(limited to 'pnm/read.scm')

diff --git a/pnm/read.scm b/pnm/read.scm
index e88f958..ae7676f 100644
--- a/pnm/read.scm
+++ b/pnm/read.scm
@@ -20,6 +20,7 @@
   (export image-read)
   (import (scheme base)
           (pnm image)
+          (pnm pbm)
           (pnm pgm)
           (pnm ppm))
   (begin
@@ -56,21 +57,28 @@
         (let ((width (read-number in)))
           (read-whitespaces*)
           (let ((height (read-number in)))
-            (read-whitespaces*)
-            (let ((maxval (read-number in)))
-              (unless (whitespace? (read-u8*))
-                (unexpected-char-error))
-              (case magic-number
-                ((P6)
-                 (make-ppm-image width height maxval
-                                 (if (< maxval 256)
-                                     (read-bytevector (* 3 width height) in)
-                                     (read-bytevector (* 6 width height) in))))
-                ((P5)
-                 (make-pgm-image width height maxval
-                                 (if (< maxval 256)
-                                     (read-bytevector (* width height) in)
-                                     (read-bytevector (* 2 width height) in))))))))))
+            (case magic-number
+              ((P4)
+               (unless (whitespace? (read-u8*))
+                 (unexpected-char-error))
+               (make-pbm-image width height
+                               (read-bytevector (* (ceiling (/ width 8)) height) in)))
+              (else
+               (read-whitespaces*)
+               (let ((maxval (read-number in)))
+                 (unless (whitespace? (read-u8*))
+                   (unexpected-char-error))
+                 (case magic-number
+                   ((P6)
+                    (make-ppm-image width height maxval
+                                    (if (< maxval 256)
+                                        (read-bytevector (* 3 width height) in)
+                                        (read-bytevector (* 6 width height) in))))
+                   ((P5)
+                    (make-pgm-image width height maxval
+                                    (if (< maxval 256)
+                                        (read-bytevector (* width height) in)
+                                        (read-bytevector (* 2 width height) in))))))))))))
 
     (define (whitespace? u8)
       (case (integer->char u8)
@@ -111,6 +119,7 @@
          ((or (eof-object? u8-1) (eof-object? u8-2)) (eof-object))
          ((and (= u8-1 P/u8) (= u8-2/int 6)) 'P6)
          ((and (= u8-1 P/u8) (= u8-2/int 5)) 'P5)
+         ((and (= u8-1 P/u8) (= u8-2/int 4)) 'P4)
          (else #f))))
 
     (define (read-whitespaces in)
-- 
cgit v1.2.3