9 files changed, 833 insertions, 0 deletions
diff --git a/image-format/pnm/image.scm b/image-format/pnm/image.scm
new file mode 100644
index 0000000..2e64752
--- /dev/null
+++ b/image-format/pnm/image.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 (image-format pnm image)
+  (export make-pnm-image
+          pnm-image?
+          pnm-image-type
+          pnm-image-width
+          pnm-image-height
+          pnm-image-maxval
+          pnm-image-data
+          pnm-image-pixel-getter
+          pnm-image-pixel-setter
+          pnm-image-ref
+          pnm-image-set!)
+  (import (scheme base)
+          (scheme case-lambda))
+  (begin
+    (define-record-type <pnm-image>
+      (make-pnm-image type width height maxval data pixel-getter pixel-setter)
+      pnm-image?
+      (type pnm-image-type)
+      (width pnm-image-width)
+      (height pnm-image-height)
+      (maxval pnm-image-maxval)
+      (data pnm-image-data)
+      (pixel-getter pnm-image-pixel-getter)
+      (pixel-setter pnm-image-pixel-setter))
+
+    (define (pnm-image-ref pnm-image x y)
+      ((pnm-image-pixel-getter pnm-image) x y))
+
+    (define pnm-image-set!
+      (case-lambda
+        ((pnm-image x y v)
+         ((pnm-image-pixel-setter pnm-image) x y v))
+        ((pnm-image x y r g b)
+         ((pnm-image-pixel-setter pnm-image) x y r g b))))))
diff --git a/image-format/pnm/pbm.scm b/image-format/pnm/pbm.scm
new file mode 100644
index 0000000..eda2677
--- /dev/null
+++ b/image-format/pnm/pbm.scm
@@ -0,0 +1,70 @@
+;;; 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 (image-format pnm pbm)
+  (export make-pbm-image
+          %make-pbm-image)
+  (import (scheme base)
+          (scheme case-lambda)
+          (image-format pnm image)
+          (image-format pnm private checker)
+          (image-format pnm private bitwise))
+  (begin
+    (define make-pbm-image
+      (case-lambda
+        ((width height)
+         (make-pbm-image width height #f))
+        ((width height unsafe?)
+         (let* ((byte-width (ceiling (/ width 8)))
+                (byte-count (* byte-width height))
+                (data (make-bytevector byte-count 0)))
+           (%make-pbm-image width height data unsafe?)))))
+
+    (define (%make-pbm-image width height data unsafe?)
+      (let* ((byte-width (ceiling (/ width 8)))
+             (byte-count (* byte-width height)))
+        (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)))))
+        (unless (= byte-count (bytevector-length data))
+          (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count)))
+        (let ((check-xy (make-xy-checker width height))
+              (check-boolean-value (make-boolean-value-checker)))
+          (make-pnm-image 'pbm width height #t data
+                          (if unsafe?
+                              pixel-getter
+                              (lambda (x y)
+                                (check-xy x y)
+                                (pixel-getter x y)))
+                          (if unsafe?
+                              pixel-setter
+                              (lambda (x y v)
+                                (check-xy x y)
+                                (check-boolean-value v)
+                                (pixel-setter x y v)))))))))
diff --git a/image-format/pnm/pgm.scm b/image-format/pnm/pgm.scm
new file mode 100644
index 0000000..39711e9
--- /dev/null
+++ b/image-format/pnm/pgm.scm
@@ -0,0 +1,91 @@
+;;; 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 (image-format pnm pgm)
+  (export make-pgm-image
+          %make-pgm-image)
+  (import (scheme base)
+          (scheme case-lambda)
+          (image-format pnm image)
+          (image-format pnm private checker)
+          (image-format pnm private double-byte))
+  (begin
+    (define make-pgm-image
+      (case-lambda
+        ((width height)
+         (make-pgm-image width height 255 #f))
+        ((width height maxval)
+         (make-pgm-image width height maxval #f))
+        ((width height maxval unsafe?)
+         (when (or (< maxval 0)
+                   (< 65536 maxval))
+           (error "(image-format pnm pgm) make-pgm: maxval is out of range"))
+         (let* ((byte-count (* width height
+                               (if (< maxval 256)
+                                   1
+                                   2)))
+                (data (make-bytevector byte-count 0)))
+           (%make-pgm-image width height maxval data unsafe?)))))
+
+    (define (%make-pgm-image width height maxval data unsafe?)
+      (define (make-safe-pixel-getter pixel-getter)
+        (let ((check-xy (make-xy-checker width height)))
+          (lambda (x y)
+            (check-xy x y)
+            (pixel-getter x y))))
+      (define (make-safe-pixel-setter pixel-setter)
+        (let ((check-xy (make-xy-checker width height))
+              (check-value (make-value-checker maxval 'v)))
+          (lambda (x y v)
+            (check-xy x y)
+            (check-value v)
+            (pixel-setter x y v))))
+      (when (or (< maxval 0)
+                (< 65536 maxval))
+        (error "(image-format pnm pgm) make-pgm: maxval is out of range"))
+      (if (< maxval 256)
+          (let ((byte-count (* width height)))
+            (define (xy->idx x y)
+              (+ x (* y width)))
+            (define (pixel-getter x y)
+              (let ((idx (xy->idx x y)))
+                (bytevector-u8-ref data idx)))
+            (define (pixel-setter x y v)
+              (let ((idx (xy->idx x y)))
+                (bytevector-u8-set! data idx v)))
+            (unless (= byte-count (bytevector-length data))
+              (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count)))
+            (make-pnm-image 'pgm width height maxval data
+                            (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter))
+                            (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter))))
+          (let ((byte-count (* width height 2)))
+            (define (xy->idx x y) (+ x (* y width)))
+            (define (pixel-getter x y)
+              (let ((idx (xy->idx x y)))
+                (combine-bytes (bytevector-u8-ref data idx)
+                               (bytevector-u8-ref data (+ idx 1)))))
+            (define (pixel-setter x y v)
+              (let ((idx (xy->idx x y)))
+                (let-values (((v1 v2) (split-double-byte v)))
+                  (bytevector-u8-set! data idx v1)
+                  (bytevector-u8-set! data (+ idx 1) v2))))
+            (unless (= byte-count (bytevector-length data))
+              (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count)))
+            (make-pnm-image 'pgm width height maxval data
+                            (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter))
+                            (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter))))))))
diff --git a/image-format/pnm/ppm.scm b/image-format/pnm/ppm.scm
new file mode 100644
index 0000000..2a644bf
--- /dev/null
+++ b/image-format/pnm/ppm.scm
@@ -0,0 +1,111 @@
+;;; 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 (image-format pnm ppm)
+  (export make-ppm-image
+          %make-ppm-image)
+  (import (scheme base)
+          (scheme case-lambda)
+          (image-format pnm image)
+          (image-format pnm private checker)
+          (image-format pnm private double-byte))
+  (begin
+    (define make-ppm-image
+      (case-lambda
+        ((width height)
+         (make-ppm-image width height 255))
+        ((width height maxval)
+         (make-ppm-image width height maxval #f))
+        ((width height maxval unsafe?)
+         (when (or (< maxval 0)
+                   (< 65536 maxval))
+           (error "(image-format pnm ppm) make-ppm-image: Maxval is out of range"))
+         (let ((data (make-bytevector (* width
+                                         height
+                                         (if (< maxval 256)
+                                             3
+                                             6))
+                                      0)))
+           (%make-ppm-image width height maxval data unsafe?)))))
+
+    (define (%make-ppm-image width height maxval data unsafe?)
+      (define (make-safe-pixel-getter pixel-getter)
+        (let ((check-xy (make-xy-checker width height)))
+          (lambda (x y)
+            (check-xy x y)
+            (pixel-getter x y))))
+      (define (make-safe-pixel-setter pixel-setter)
+        (let ((check-xy (make-xy-checker width height))
+              (check-value-r (make-value-checker maxval 'r))
+              (check-value-g (make-value-checker maxval 'g))
+              (check-value-b (make-value-checker maxval 'b)))
+          (lambda (x y r g b)
+            (check-xy x y)
+            (check-value-r r)
+            (check-value-g g)
+            (check-value-b b)
+            (pixel-setter x y r g b))))
+      (when (or (< maxval 0)
+                (< 65536 maxval))
+        (error "(image-format pnm ppm) make-ppm-image: Maxval is out of range"))
+      (if (< maxval 256)
+          (let* ((w*3 (* width 3))
+                 (byte-count (* w*3 height)))
+            (define (xy->idx x y) (+ (* 3 x) (* y w*3)))
+            (define (pixel-getter x y)
+              (let ((idx (xy->idx x y)))
+                (values (bytevector-u8-ref data idx)
+                        (bytevector-u8-ref data (+ idx 1))
+                        (bytevector-u8-ref data (+ idx 2)))))
+            (define (pixel-setter x y r g b)
+              (let ((idx (xy->idx x y)))
+                (bytevector-u8-set! data idx r)
+                (bytevector-u8-set! data (+ idx 1) g)
+                (bytevector-u8-set! data (+ idx 2) b)))
+            (unless (= byte-count (bytevector-length data))
+              (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count)))
+            (make-pnm-image 'ppm width height maxval data
+                            (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter))
+                            (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter))))
+          (let* ((w*6 (* width 6))
+                 (byte-count (* w*6 height)))
+            (define (xy->idx x y) (+ (* 6 x) (* y w*6)))
+            (define (pixel-getter x y)
+              (let ((idx (xy->idx x y)))
+                (values (combine-bytes (bytevector-u8-ref data idx)
+                                       (bytevector-u8-ref data (+ idx 1)))
+                        (combine-bytes (bytevector-u8-ref data (+ idx 2))
+                                       (bytevector-u8-ref data (+ idx 3)))
+                        (combine-bytes (bytevector-u8-ref data (+ idx 4))
+                                       (bytevector-u8-ref data (+ idx 5))))))
+            (define (pixel-setter x y r g b)
+              (let ((idx (xy->idx x y)))
+                (let-values (((r1 r2) (split-double-byte r))
+                             ((g1 g2) (split-double-byte g))
+                             ((b1 b2) (split-double-byte b)))
+                  (bytevector-u8-set! data idx r1)
+                  (bytevector-u8-set! data (+ idx 1) r2)
+                  (bytevector-u8-set! data (+ idx 2) g1)
+                  (bytevector-u8-set! data (+ idx 3) g2)
+                  (bytevector-u8-set! data (+ idx 4) b1)
+                  (bytevector-u8-set! data (+ idx 5) b2))))
+            (unless (= byte-count (bytevector-length data))
+              (error (string-append "(image-format pnm pbm) make-pbm-image: Invalid bytevector length" byte-count)))
+            (make-pnm-image 'ppm width height maxval data
+                            (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter))
+                            (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter))))))))
diff --git a/image-format/pnm/private/bitwise.scm b/image-format/pnm/private/bitwise.scm
new file mode 100644
index 0000000..ffca4e9
--- /dev/null
+++ b/image-format/pnm/private/bitwise.scm
@@ -0,0 +1,38 @@
+;;; 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 (image-format pnm private bitwise)
+  (export bitwise-and
+          bitwise-ior
+          arithmetic-shift
+          bit-set?
+          copy-bit)
+  (import (scheme base))
+  (cond-expand
+    ((library (scheme bitwise))
+     (import (only (scheme bitwise)
+                   bitwise-and bitwise-ior arithmetic-shift
+                   bit-set? copy-bit)))
+    ((library (srfi 60))
+     (import (only (srfi 60)
+                   bitwise-and bitwise-ior arithmetic-shift
+                   bit-set? copy-bit)))
+    ((library (srfi 151))
+     (import (only (srfi 151)
+                   bitwise-and bitwise-ior arithmetic-shift
+                   bit-set? copy-bit)))))
diff --git a/image-format/pnm/private/checker.scm b/image-format/pnm/private/checker.scm
new file mode 100644
index 0000000..8b7fcb6
--- /dev/null
+++ b/image-format/pnm/private/checker.scm
@@ -0,0 +1,65 @@
+;;; 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 (image-format pnm private checker)
+  (export make-xy-checker
+          make-value-checker
+          make-boolean-value-checker)
+  (import (scheme base)
+          (scheme case-lambda)
+          (image-format pnm image))
+  (begin
+    (define (make-xy-checker width height)
+      (lambda (x y)
+        (when (or (not (exact-integer? x))
+                  (< x 0)
+                  (<= width x))
+          (error (string-append  "`x` must be an integer such that 0 <= `x` < "
+                                 (number->string width))
+                 x))
+        (when (and (not (exact-integer? y))
+                   (< y 0)
+                   (<= height y))
+          (error (string-append  "`y` must be an integer such that 0 <= `y` < "
+                                 (number->string width))
+                 y))))
+
+    (define (make-value-checker maxval sym)
+      (define message
+        (string-append "`" (symbol->string sym) "`"
+                       " must be an integer such that 0 < "
+                       "`" (symbol->string sym) "`"
+                       " < "
+                       (number->string maxval)))
+      (lambda (v)
+        (when (or (not (exact-integer? v))
+                  (< v 0)
+                  (< maxval v))
+          (error message v))))
+
+    (define (make-boolean-value-checker)
+      (lambda (v)
+        (when (not (boolean? v))
+          (error "`v` must be a boolean value" v))))
+
+    (define (split-value v)
+      (values (modulo (quotient v 256) 256)
+              (modulo v 256)))
+
+    (define (combine-values l r)
+      (+ (* 256 l) r))))
diff --git a/image-format/pnm/private/double-byte.scm b/image-format/pnm/private/double-byte.scm
new file mode 100644
index 0000000..156b409
--- /dev/null
+++ b/image-format/pnm/private/double-byte.scm
@@ -0,0 +1,29 @@
+;;; 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 (image-format pnm private double-byte)
+  (export split-double-byte combine-bytes)
+  (import (scheme base)
+          (image-format pnm private bitwise))
+  (begin
+    (define (split-double-byte v)
+      (values (arithmetic-shift v -8)
+              (bitwise-and v 255)))
+
+    (define (combine-bytes l r)
+      (bitwise-ior (arithmetic-shift l 8) r))))
diff --git a/image-format/pnm/read.scm b/image-format/pnm/read.scm
new file mode 100644
index 0000000..0086113
--- /dev/null
+++ b/image-format/pnm/read.scm
@@ -0,0 +1,253 @@
+;;; 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 (image-format pnm read)
+  (export pnm-image-read
+          pnm-parse-error?)
+  (import (scheme base)
+          (scheme case-lambda)
+          (image-format pnm image)
+          (image-format pnm pbm)
+          (image-format pnm pgm)
+          (image-format pnm ppm))
+  (begin
+    (define pnm-image-read
+      (case-lambda
+        ((in)
+         (pnm-image-read in #f))
+        ((in unsafe?)
+         (define (read-u8*)
+           (let ((u8 (read-u8 in)))
+             (when (eof-object? u8)
+               (unexpected-eof-error))
+             u8))
+         (define (read-magic-number*)
+           (let ((magic-number (read-magic-number in)))
+             (when (eof-object? magic-number)
+               (unexpected-eof-error))
+             (unless magic-number
+               (unexpected-magic-number-error))
+             magic-number))
+         (define (read-number*)
+           (let ((n (read-number in)))
+             (when (eof-object? n)
+               (unexpected-eof-error))
+             (unless n
+               (unexpected-character-error))
+             n))
+         (define (read-whitespaces*)
+           (let ((result (read-whitespaces in)))
+             (when (eof-object? result)
+               (unexpected-eof-error))
+             (unless result
+               (unexpected-character-error))))
+         (define (read-single-whitespace*)
+           (unless (whitespace? (read-u8*))
+             (unexpected-character-error)))
+
+         (let ((magic-number (read-magic-number*)))
+           (read-whitespaces*)
+           (let ((width (read-number in)))
+             (read-whitespaces*)
+             (let ((height (read-number in)))
+               (case magic-number
+                 ((P4)
+                  (read-single-whitespace*)
+                  (%make-pbm-image width height
+                                   (read-bytevector (* (ceiling (/ width 8)) height) in)
+                                   unsafe?))
+                 ((P1)
+                  (let ((byte-width (ceiling (/ width 8)))
+                        (pbm-image (make-pbm-image width height unsafe?)))
+                    (read-text-raster width height #f in
+                                      (lambda (x y v)
+                                        (pnm-image-set! pbm-image x y (= v 1)))
+                                      unexpected-eof-error
+                                      unexpected-character-error)
+                    pbm-image))
+                 (else
+                  (read-whitespaces*)
+                  (let ((maxval (read-number in)))
+                    (case magic-number
+                      ((P6)
+                       (read-single-whitespace*)
+                       (%make-ppm-image width height maxval
+                                        (if (< maxval 256)
+                                            (read-bytevector (* 3 width height) in)
+                                            (read-bytevector (* 6 width height) in))
+                                        unsafe?))
+                      ((P3)
+                       (let ((ppm-image (make-ppm-image width height maxval unsafe?)))
+                         (read-text-raster width height #t in (pnm-image-pixel-setter ppm-image)
+                                           unexpected-eof-error
+                                           unexpected-character-error)
+                         ppm-image))
+                      ((P5)
+                       (read-single-whitespace*)
+                       (%make-pgm-image width height maxval
+                                        (if (< maxval 256)
+                                            (read-bytevector (* width height) in)
+                                            (read-bytevector (* 2 width height) in))
+                                        unsafe?))
+                      ((P2)
+                       (let ((pgm-image (make-pgm-image width height maxval unsafe?)))
+                         (read-text-raster width height #f in (pnm-image-pixel-setter pgm-image)
+                                           unexpected-eof-error
+                                           unexpected-character-error)
+                         pgm-image))))))))))))
+
+    (define (whitespace? u8)
+      (case (integer->char u8)
+        ((#\newline
+          #\return
+          #\tab
+          #\space
+          #\x000B ;; Vertical Tab
+          #\x000c ;; Form Feed
+          )
+         #t)
+        (else #f)))
+
+    (define (comment? u8)
+      (char=? #\# (integer->char u8)))
+
+    (define (newline? u8)
+      (case (integer->char u8)
+        ((#\newline) #t)
+        (else #f)))
+
+    (define (read-comment in)
+      (let ((u8 (peek-u8 in)))
+        (cond ((eof-object? u8) (eof-object))
+              ((newline? u8)
+               (read-u8 in)
+               (skip-whitespace in))
+              (else
+               (read-u8 in)
+               (read-comment in)))))
+
+    (define (skip-whitespace in)
+      (let ((u8 (peek-u8 in)))
+        (cond ((eof-object? u8) #t)
+              ((whitespace? u8)
+               (read-u8 in)
+               (skip-whitespace in))
+              ((comment? u8)
+               (read-u8 in)
+               (read-comment in))
+              (else #t))))
+
+    (define (digit? u8)
+      (and (<= 48 u8)
+           (<= u8 57)))
+
+    (define (u8->integer u8)
+      (- u8 48))
+
+    (define (read-magic-number in)
+      (let* ((P/u8 (char->integer #\P))
+             (u8-1 (read-u8 in))
+             (u8-2 (read-u8 in))
+             (u8-2/int (u8->integer u8-2)))
+        (cond ((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)
+              ((and (= u8-1 P/u8) (= u8-2/int 3)) 'P3)
+              ((and (= u8-1 P/u8) (= u8-2/int 2)) 'P2)
+              ((and (= u8-1 P/u8) (= u8-2/int 1)) 'P1)
+              (else #f))))
+
+    (define (read-whitespaces in)
+      (let ((u8 (peek-u8 in)))
+        (cond ((eof-object? u8) (eof-object))
+              ((whitespace? u8)
+               (read-u8 in)
+               (skip-whitespace in))
+              (else #f))))
+
+    (define (read-text-raster width height rgb? in proc fail-eof-object fail-unexpected-char)
+      (call-with-current-continuation
+       (lambda (return)
+         (define (read-whitespaces*)
+           (let ((result (read-whitespaces in)))
+             (when (eof-object? result)
+               (return (fail-eof-object)))
+             (unless result
+               (return (fail-unexpected-char)))))
+         (define (read-number*)
+           (let ((number (read-number in)))
+             (when (eof-object? number)
+               (return (fail-eof-object)))
+             (unless number
+               (return (fail-unexpected-char)))
+             number))
+         (let ((size (* width height)))
+           (do ((y 0 (+ y 1)))
+               ((= y height))
+             (do ((x 0 (+ x 1)))
+                 ((= x width))
+               (if rgb?
+                   (let* ((r (begin (read-whitespaces*) (read-number*)))
+                          (g (begin (read-whitespaces*) (read-number*)))
+                          (b (begin (read-whitespaces*) (read-number*))))
+                     (proc x y r g b))
+                   (proc x y (begin (read-whitespaces*) (read-number*))))))))))
+
+    (define (read-number in)
+      (call-with-current-continuation
+       (lambda (return)
+         (let ((u8 (peek-u8 in)))
+           (when (eof-object? u8)
+             (return (eof-object)))
+           (when (not (digit? u8))
+             (return #f)))
+         (let loop ((number 0))
+           (let ((u8 (peek-u8 in)))
+             (cond ((eof-object? u8) (eof-object))
+                   ((digit? u8)
+                    (read-u8 in)
+                    (loop (+ (* number 10) (u8->integer u8))))
+                   (else number)))))))
+
+    (define (unexpected-magic-number-error)
+      (raise (pnm-parse-error "(image-format pnm read) pnm-image-read: Not supported magic number")))
+    (define (unexpected-eof-error)
+      (raise (pnm-parse-error "(image-format pnm read) pnm-image-read: Unexpected end of file")))
+    (define (unexpected-character-error)
+      (raise (pnm-parse-error "(image-format pnm read) pnm-image-read: Unexpected character"))))
+  (cond-expand
+    ((library (srfi 35))
+     (import (srfi 35))
+     (begin
+       (define-condition-type &pnm-parse-error &error
+         pnm-parse-error?)
+
+       (define (pnm-parse-error msg)
+         (raise (condition (&pnm-parse-error)
+                           (&message
+                            (message msg)))))))
+    (r7rs
+     (begin
+       (define-record-type <pnm-parse-error>
+         (make-pnm-parse-error message)
+         pnm-parse-error?
+         (message pnm-parse-error-message))
+
+       (define (pnm-parse-error msg)
+         (raise (make-pnm-parse-error msg)))))))
diff --git a/image-format/pnm/write.scm b/image-format/pnm/write.scm
new file mode 100644
index 0000000..b2f807c
--- /dev/null
+++ b/image-format/pnm/write.scm
@@ -0,0 +1,123 @@
+;;; 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 (image-format pnm write)
+  (export pnm-image-write)
+  (import (scheme base)
+          (scheme case-lambda)
+          (image-format pnm image))
+  (begin
+    (define pnm-image-write
+      (case-lambda
+        ((pnm-image out)
+         (case (pnm-image-type pnm-image)
+           ((ppm)
+            (write-string-u8 "P6\n" out))
+           ((pgm)
+            (write-string-u8 "P5\n" out))
+           ((pbm)
+            (write-string-u8 "P4\n" out))
+           (else
+            (error "(image-format pnm write) pnm-image-write: Not supported type" (pnm-image-type pnm-image))))
+         (write-string-u8 (number->string (pnm-image-width pnm-image)) out)
+         (write-string-u8 " " out)
+         (write-string-u8 (number->string (pnm-image-height pnm-image)) out)
+         (write-string-u8 "\n" out)
+         (case (pnm-image-type pnm-image)
+           ((pgm ppm)
+            (write-string-u8 (number->string (pnm-image-maxval pnm-image)) out)
+            (write-string-u8 "\n" out)))
+         (write-bytevector (pnm-image-data pnm-image) out))
+        ((pnm-image out plain?)
+         (if plain?
+             (pnm-image-write/plan pnm-image out)
+             (pnm-image-write pnm-image out)))))
+
+    (define (pnm-image-write/plan pnm-image out)
+      (case (pnm-image-type pnm-image)
+        ((ppm)
+         (write-string-u8 "P3\n" out))
+        ((pgm)
+         (write-string-u8 "P2\n" out))
+        ((pbm)
+         (write-string-u8 "P1\n" out))
+        (else
+         (error "(image-format pnm write) image-write: Not supported type" (pnm-image-type pnm-image))))
+      (write-string-u8 (number->string (pnm-image-width pnm-image)) out)
+      (write-string-u8 " " out)
+      (write-string-u8 (number->string (pnm-image-height pnm-image)) out)
+      (write-string-u8 "\n" out)
+      (case (pnm-image-type pnm-image)
+        ((pgm ppm)
+         (write-string-u8 (number->string (pnm-image-maxval pnm-image)) out)
+         (write-string-u8 "\n" out)))
+      (let-values (((write-token write-newline)
+                    (limit-line-length-writer 70 out)))
+        (let ((width (pnm-image-width pnm-image))
+              (height (pnm-image-height pnm-image)))
+          (define (write-raster write-pixel)
+            (do ((y 0 (+ y 1)))
+                ((= y height))
+              (write-pixel 0 y)
+              (do ((x 1 (+ x 1)))
+                  ((= x width))
+                (write-pixel x y))
+              (write-newline)))
+          (case (pnm-image-type pnm-image)
+            ((ppm)
+             (write-raster
+              (lambda (x y)
+                (let-values (((r g b) (pnm-image-ref pnm-image x y)))
+                  (write-token (number->string r))
+                  (write-token (number->string g))
+                  (write-token (number->string b))))))
+            ((pgm)
+             (write-raster
+              (lambda (x y)
+                (let ((v (pnm-image-ref pnm-image x y)))
+                  (write-token (number->string v))))))
+            ((pbm)
+             (write-raster
+              (lambda (x y)
+                (let ((b (pnm-image-ref pnm-image x y)))
+                  (write-token (if b "1" "0"))))))))))
+
+    (define (write-string-u8 str out)
+      (string-for-each (lambda (c) (write-u8 (char->integer c) out))
+                       str))
+
+    (define (limit-line-length-writer limit out)
+      (let ((current-length 0))
+        (define (write-token str)
+          (let ((str-len (string-length str)))
+            (cond ((zero? current-length)
+                   (write-string-u8 str out)
+                   (set! current-length str-len))
+                  ((<= (+ current-length str-len 1) limit)
+                   (write-string-u8 " " out)
+                   (write-string-u8 str out)
+                   (set! current-length (+ current-length 1 str-len)))
+                  (else
+                   (write-string-u8 "\n" out)
+                   (write-string-u8 str out)
+                   (set! current-length str-len)))))
+        (define (write-newline)
+          (write-string-u8 "\n" out)
+          (set! current-length 0))
+        (values write-token
+                write-newline)))))