Support PBM format

3 files changed, 79 insertions, 15 deletions

diff --git a/pnm/pbm.scm b/pnm/pbm.scm
new file mode 100644
index 0000000..d711b82
--- /dev/null
+++ b/pnm/pbm.scm
@@ -0,0 +1,53 @@
+;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS
+;;; Copyright © 2024 Masaya Tojo <masaya@tojo.tokyo>
+;;;
+;;; This file is part of R7RS-PNM.
+;;;
+;;; R7RS-PNM is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; R7RS-PNM is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with R7RS-PNM. If not, see <https://www.gnu.org/licenses/>.
+
+(define-library (pnm pbm)
+  (export make-pbm-image)
+  (import (scheme base)
+          (scheme case-lambda)
+          (pnm image))
+  (cond-expand
+    ((library (scheme bitwise))
+     (import (only (scheme bitwise) bit-set? copy-bit)))
+    ((library (srfi 60))
+     (import (only (srfi 60) bit-set? copy-bit))))
+  (begin
+    (define make-pbm-image
+      (case-lambda
+        ((width height)
+         (let* ((byte-width (ceiling (/ width 8)))
+                (byte-count (* byte-width height))
+                (data (make-bytevector byte-count 0)))
+           (make-pbm-image width height data)))
+        ((width height data)
+         (let* ((byte-width (ceiling (/ width 8))))
+           (define (xy->byte-idx+bit-idx x y)
+             (let-values (((byte-x bit-x) (floor/ x 8)))
+               (values (+ (* y byte-width)
+                          byte-x)
+                       bit-x)))
+           (define (pixel-getter x y)
+             (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y)))
+               (let ((byte (bytevector-u8-ref data byte-idx)))
+                 (bit-set? (- 7 bit-idx) byte))))
+           (define (pixel-setter x y b)
+             (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y)))
+               (let ((byte (bytevector-u8-ref data byte-idx)))
+                 (bytevector-u8-set! data byte-idx
+                                     (copy-bit (- 7 bit-idx) byte b)))))
+           (make-image 'pbm width height 1 data pixel-getter pixel-setter)))))))
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)
diff --git a/pnm/write.scm b/pnm/write.scm
index b41a0d9..75cd433 100644
--- a/pnm/write.scm
+++ b/pnm/write.scm
@@ -30,6 +30,8 @@
          (write-string-u8 "P6\n"))
         ((pgm)
          (write-string-u8 "P5\n"))
+        ((pbm)
+         (write-string-u8 "P4\n"))
         (else
          (error "(pnm write) pnm-write: Not supported type" (image-type image))))
       (write-string-u8 (number->string (image-width image)))