From f7fed1949869f64c4f71936d12c8ae032e8f9005 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sat, 3 Aug 2024 17:09:05 +0900
Subject: Split pnm/pgm.scm and pnm/ppm.scm to organize interfaces

---
 pnm/image.scm |  35 +++++++++
 pnm/pgm.scm   | 219 +++++++++++----------------------------------------
 pnm/ppm.scm   | 246 ++++++++++++++--------------------------------------------
 pnm/read.scm  | 122 +++++++++++++++++++++++++++++
 pnm/write.scm |  25 ++++++
 5 files changed, 284 insertions(+), 363 deletions(-)
 create mode 100644 pnm/image.scm
 create mode 100644 pnm/read.scm
 create mode 100644 pnm/write.scm

(limited to 'pnm')

diff --git a/pnm/image.scm b/pnm/image.scm
new file mode 100644
index 0000000..449afc6
--- /dev/null
+++ b/pnm/image.scm
@@ -0,0 +1,35 @@
+(define-library (pnm image)
+  (export make-image
+          image?
+          image-type
+          image-width
+          image-height
+          image-maxval
+          image-data
+          image-pixel-getter
+          image-pixel-setter
+          image-ref
+          image-set!)
+  (import (scheme base)
+          (scheme case-lambda))
+  (begin
+    (define-record-type <image>
+      (make-image type width height maxval data pixel-getter pixel-setter)
+      image?
+      (type image-type)
+      (width image-width)
+      (height image-height)
+      (maxval image-maxval)
+      (data image-data)
+      (pixel-getter image-pixel-getter)
+      (pixel-setter image-pixel-setter))
+
+    (define (image-ref image x y)
+      ((image-pixel-getter image) x y))
+
+    (define image-set!
+      (case-lambda
+        ((image x y v)
+         ((image-pixel-setter image) x y v))
+        ((image x y r g b)
+         ((image-pixel-setter image) x y r g b))))))
diff --git a/pnm/pgm.scm b/pnm/pgm.scm
index 7f1675c..5abbab2 100644
--- a/pnm/pgm.scm
+++ b/pnm/pgm.scm
@@ -15,186 +15,55 @@
 ;;;
 ;;; 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 pgm)
-  (export make-image
-          image-width
-          image-height
-          image-maxval
-          image-ref
-          image-set!
-          image-read
-          image-write)
-  (import (scheme base))
+  (export make-pgm-image)
+  (import (scheme base)
+          (scheme case-lambda)
+          (pnm image))
   (begin
-    (define-record-type <pgm:image>
-      (%make-image width height maxval data getter setter)
-      image?
-      (width image-width)
-      (height image-height)
-      (maxval image-maxval)
-      (data image-data)
-      (getter image-getter)
-      (setter image-setter))
-
-    (define (make-image width height maxval)
-      (when (or (< maxval 0)
-                (< 65536 maxval))
-        (error "(pnm pgm) make-image: maxval is out of range"))
-      (let ((data (make-bytevector (* width
-                                      height
-                                      (if (< maxval 256)
-                                          1
-                                          2))
-                                   0)))
-        (make-image* width height maxval data)))
-
-    (define (make-image* width height maxval data)
-      (when (or (< maxval 0)
-                (< 65536 maxval))
-        (error "(pnm pgm) make-image: maxval is out of range"))
-      (if (< maxval 256)
-          (let ()
-            (define (xy->idx x y) (+ x (* y width)))
-            (define (getter x y)
-              (let ((idx (xy->idx x y)))
-                (bytevector-u8-ref data idx)))
-            (define (setter x y v)
-              (let ((idx (xy->idx x y)))
-                (bytevector-u8-set! data idx v)))
-            (%make-image width height maxval data getter setter))
-          (let ()
-            (define (xy->idx x y) (+ x (* y width)))
-            (define (getter x y)
-              (let ((idx (xy->idx x y)))
-                (combine-values (bytevector-u8-ref data idx)
-                                (bytevector-u8-ref data (+ idx 1)))))
-            (define (setter x y v)
-              (let ((idx (xy->idx x y)))
-                (let-values (((v1 v2) (split-value v)))
-                  (bytevector-u8-set! data idx v1)
-                  (bytevector-u8-set! data (+ idx 1) v2))))
-            (%make-image width height maxval data getter setter))))
+    (define make-pgm-image
+      (case-lambda
+        ((width height maxval)
+         (when (or (< maxval 0)
+                   (< 65536 maxval))
+           (error "(pnm pgm) make-pgm: maxval is out of range"))
+         (let ((data (make-bytevector (* width
+                                         height
+                                         (if (< maxval 256)
+                                             1
+                                             2))
+                                      0)))
+           (make-pgm-image width height maxval data)))
+        ((width height maxval data)
+         (when (or (< maxval 0)
+                   (< 65536 maxval))
+           (error "(pnm pgm) make-pgm: maxval is out of range"))
+         (if (< maxval 256)
+             (let ()
+               (define (xy->idx x y) (+ x (* y width)))
+               (define (getter x y)
+                 (let ((idx (xy->idx x y)))
+                   (bytevector-u8-ref data idx)))
+               (define (setter x y v)
+                 (let ((idx (xy->idx x y)))
+                   (bytevector-u8-set! data idx v)))
+               (make-image 'pgm width height maxval data getter setter))
+             (let ()
+               (define (xy->idx x y) (+ x (* y width)))
+               (define (getter x y)
+                 (let ((idx (xy->idx x y)))
+                   (combine-values (bytevector-u8-ref data idx)
+                                   (bytevector-u8-ref data (+ idx 1)))))
+               (define (setter x y v)
+                 (let ((idx (xy->idx x y)))
+                   (let-values (((v1 v2) (split-value v)))
+                     (bytevector-u8-set! data idx v1)
+                     (bytevector-u8-set! data (+ idx 1) v2))))
+               (make-image 'pgm width height maxval data getter setter))))))
 
     (define (split-value v)
       (values (modulo (quotient v 256) 256)
               (modulo v 256)))
 
     (define (combine-values l r)
-      (+ (* 256 l) r))
-    
-    (define (image-set! image x y v)
-      ((image-setter image) x y v))
-
-    (define (image-ref image x y)
-      ((image-getter image) x y))
-    
-    (define (image-read in)
-      (define (unexpected-eof-error)
-        (error "(pnm pgm) image-read: Unexpected end of file"))
-      (define (unexpected-char-error)
-        (error "(pnm pgm) image-read: Unexpected character"))
-      (define (read-u8*)
-        (let ((u8 (read-u8 in)))
-          (when (eof-object? u8)
-            (unexpected-eof-error))
-          u8))
-      (define (read-number*)
-        (let ((n (read-number in)))
-          (when (eof-object? n)
-            (unexpected-eof-error))
-          (unless n
-            (unexpected-char-error))
-          n))
-      (define (read-whitespaces*)
-        (when (eof-object? (read-whitespaces in))
-          (unexpected-eof-error)))
-      (let ((u8-1 (read-u8*))
-            (u8-2 (read-u8*)))
-        (unless (p5? u8-1 u8-2)
-          (error "(pnm pgm) image-read: No expected magic number (expected P5)"))
-        (read-whitespaces*)
-        (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))
-              (make-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)
-        ((#\newline #\return #\tab #\space) #t)
-        (else #f)))
-
-    (define (comment? u8)
-      (char=? #\# (integer->char u8)))
-
-    (define (newline? u8)
-      (case (integer->char u8)
-        ((#\newline #\return) #t)
-        (else #f)))
-
-    (define (read-comment in)
-      (let ((u8 (peek-u8 in)))
-        (cond ((eof-object? u8) (eof-object))
-              ((newline? u8)
-               (read-u8 in)
-               (read-whitespaces in))
-              (else
-               (read-u8 in)
-               (read-comment in)))))
-
-    (define (digit? u8)
-      (and (<= 48 u8)
-           (<= u8 57)))
-
-    (define (u8->integer u8)
-      (- u8 48))
-
-    (define (p5? u8-1 u8-2)
-      (and (= (char->integer #\P) u8-1)
-           (= (char->integer #\5) u8-2)))
-
-    (define (read-whitespaces in)
-      (let ((u8 (peek-u8 in)))
-        (cond ((eof-object? u8) (eof-object))
-              ((whitespace? u8)
-               (read-u8 in)
-               (read-whitespaces in))
-              ((comment? u8)
-               (read-u8 in)
-               (read-comment in))
-              (else #t))))
-
-    (define (read-number in)
-      (call-with-current-continuation
-       (lambda (return)
-         (let ((u8 (peek-u8 in)))
-           (when (or (eof-object? u8)
-                     (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 (image-write image out)
-      (define (write-string-u8 str)
-        (string-for-each (lambda (c) (write-u8 (char->integer c) out))
-                         str))
-      (write-string-u8 "P5\n")
-      (write-string-u8 (number->string (image-width image)))
-      (write-string-u8 "\n")
-      (write-string-u8 (number->string (image-height image)))
-      (write-string-u8 "\n")
-      (write-string-u8 (number->string (image-maxval image)))
-      (write-string-u8 "\n")
-      (write-bytevector (image-data image) out))))
+      (+ (* 256 l) r))))
diff --git a/pnm/ppm.scm b/pnm/ppm.scm
index f936e4b..17a7c43 100644
--- a/pnm/ppm.scm
+++ b/pnm/ppm.scm
@@ -17,198 +17,68 @@
 ;;; along with R7RS-PNM. If not, see <https://www.gnu.org/licenses/>.
 
 (define-library (pnm ppm)
-  (export make-image
-          image-width
-          image-height
-          image-maxval
-          image-ref
-          image-set!
-          image-read
-          image-write)
-  (import (scheme base))
+  (export make-ppm-image)
+  (import (scheme base)
+          (scheme case-lambda)
+          (pnm image))
   (begin
-    (define-record-type <ppm:image>
-      (%make-image width height maxval data getter setter)
-      image?
-      (width image-width)
-      (height image-height)
-      (maxval image-maxval)
-      (data image-data)
-      (getter image-getter)
-      (setter image-setter))
-
-    (define (make-image width height maxval)
-      (when (or (< maxval 0)
-                (< 65536 maxval))
-        (error "(pnm ppm) make-image: maxval is out of range"))
-      (let ((data (make-bytevector (* width
-                                      height
-                                      (if (< maxval 256)
-                                          3
-                                          6))
-                                   0)))
-        (make-image* width height maxval data)))
-
-    (define (make-image* width height maxval data)
-      (when (or (< maxval 0)
-                (< 65536 maxval))
-        (error "(pnm ppm) make-image: maxval is out of range"))
-      (if (< maxval 256)
-          (let* ((w*3 (* width 3)))
-            (define (xy->idx x y) (+ (* 3 x) (* y w*3)))
-            (define (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 (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)))
-            (%make-image width height maxval data getter setter))
-          (let* ((w*6 (* width 6)))
-            (define (xy->idx x y) (+ (* 6 x) (* y w*6)))
-            (define (getter x y)
-              (let ((idx (xy->idx x y)))
-                (values (combine-values (bytevector-u8-ref data idx)
-                                        (bytevector-u8-ref data (+ idx 1)))
-                        (combine-values (bytevector-u8-ref data (+ idx 2))
-                                        (bytevector-u8-ref data (+ idx 3)))
-                        (combine-values (bytevector-u8-ref data (+ idx 4))
-                                        (bytevector-u8-ref data (+ idx 5))))))
-            (define (setter x y r g b)
-              (let ((idx (xy->idx x y)))
-                (let-values (((r1 r2) (split-value r))
-                             ((g1 g2) (split-value g))
-                             ((b1 b2) (split-value 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))))
-            (%make-image width height maxval data getter setter))))
+    (define make-ppm-image
+      (case-lambda
+        ((width height maxval)
+         (when (or (< maxval 0)
+                   (< 65536 maxval))
+           (error "(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)))
+        ((width height maxval data)
+         (when (or (< maxval 0)
+                   (< 65536 maxval))
+           (error "(pnm ppm) make-ppm-image: maxval is out of range"))
+         (if (< maxval 256)
+             (let* ((w*3 (* width 3)))
+               (define (xy->idx x y) (+ (* 3 x) (* y w*3)))
+               (define (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 (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)))
+               (make-image 'ppm width height maxval data getter setter))
+             (let* ((w*6 (* width 6)))
+               (define (xy->idx x y) (+ (* 6 x) (* y w*6)))
+               (define (getter x y)
+                 (let ((idx (xy->idx x y)))
+                   (values (combine-values (bytevector-u8-ref data idx)
+                                           (bytevector-u8-ref data (+ idx 1)))
+                           (combine-values (bytevector-u8-ref data (+ idx 2))
+                                           (bytevector-u8-ref data (+ idx 3)))
+                           (combine-values (bytevector-u8-ref data (+ idx 4))
+                                           (bytevector-u8-ref data (+ idx 5))))))
+               (define (setter x y r g b)
+                 (let ((idx (xy->idx x y)))
+                   (let-values (((r1 r2) (split-value r))
+                                ((g1 g2) (split-value g))
+                                ((b1 b2) (split-value 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))))
+               (make-image 'ppm width height maxval data getter setter))))))
 
     (define (split-value v)
       (values (modulo (quotient v 256) 256)
               (modulo v 256)))
 
     (define (combine-values l r)
-      (+ (* 256 l) r))
-    
-    (define (image-set! image x y r g b)
-      ((image-setter image) x y r g b))
-
-    (define (image-ref image x y)
-      ((image-getter image) x y))
-    
-    (define (image-read in)
-      (define (unexpected-eof-error)
-        (error "(pnm ppm) image-read: Unexpected end of file"))
-      (define (unexpected-char-error)
-        (error "(pnm ppm) image-read: Unexpected character"))
-      (define (read-u8*)
-        (let ((u8 (read-u8 in)))
-          (when (eof-object? u8)
-            (unexpected-eof-error))
-          u8))
-      (define (read-number*)
-        (let ((n (read-number in)))
-          (when (eof-object? n)
-            (unexpected-eof-error))
-          (unless n
-            (unexpected-char-error))
-          n))
-      (define (read-whitespaces*)
-        (when (eof-object? (read-whitespaces in))
-          (unexpected-eof-error)))
-      (let ((u8-1 (read-u8*))
-            (u8-2 (read-u8*)))
-        (unless (p6? u8-1 u8-2)
-          (error "(pnm ppm) image-read: No expected magic number (expected P6)"))
-        (read-whitespaces*)
-        (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))
-              (make-image* width height maxval
-                           (if (< maxval 256)
-                               (read-bytevector (* 3 width height) in)
-                               (read-bytevector (* 6 width height) in))))))))
-        
-    (define (whitespace? u8)
-      (case (integer->char u8)
-        ((#\newline #\return #\tab #\space) #t)
-        (else #f)))
-
-    (define (comment? u8)
-      (char=? #\# (integer->char u8)))
-
-    (define (newline? u8)
-      (case (integer->char u8)
-        ((#\newline #\return) #t)
-        (else #f)))
-
-    (define (read-comment in)
-      (let ((u8 (peek-u8 in)))
-        (cond ((eof-object? u8) (eof-object))
-              ((newline? u8)
-               (read-u8 in)
-               (read-whitespaces in))
-              (else
-               (read-u8 in)
-               (read-comment in)))))
-
-    (define (digit? u8)
-      (and (<= 48 u8)
-           (<= u8 57)))
-
-    (define (u8->integer u8)
-      (- u8 48))
-
-    (define (p6? u8-1 u8-2)
-      (and (= (char->integer #\P) u8-1)
-           (= (char->integer #\6) u8-2)))
-
-    (define (read-whitespaces in)
-      (let ((u8 (peek-u8 in)))
-        (cond ((eof-object? u8) (eof-object))
-              ((whitespace? u8)
-               (read-u8 in)
-               (read-whitespaces in))
-              ((comment? u8)
-               (read-u8 in)
-               (read-comment in))
-              (else #t))))
-
-    (define (read-number in)
-      (call-with-current-continuation
-       (lambda (return)
-         (let ((u8 (peek-u8 in)))
-           (when (or (eof-object? u8)
-                     (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 (image-write image out)
-      (define (write-string-u8 str)
-        (string-for-each (lambda (c) (write-u8 (char->integer c) out))
-                         str))
-      (write-string-u8 "P6\n")
-      (write-string-u8 (number->string (image-width image)))
-      (write-string-u8 "\n")
-      (write-string-u8 (number->string (image-height image)))
-      (write-string-u8 "\n")
-      (write-string-u8 (number->string (image-maxval image)))
-      (write-string-u8 "\n")
-      (write-bytevector (image-data image) out))))
+      (+ (* 256 l) r))))
diff --git a/pnm/read.scm b/pnm/read.scm
new file mode 100644
index 0000000..01e74d0
--- /dev/null
+++ b/pnm/read.scm
@@ -0,0 +1,122 @@
+(define-library (pnm read)
+  (export image-read)
+  (import (scheme base)
+          (pnm image)
+          (pnm pgm)
+          (pnm ppm))
+  (begin
+    (define (image-read in)
+      (define (unexpected-eof-error)
+        (error "(pnm read) image-read: Unexpected end of file"))
+      (define (unexpected-char-error)
+        (error "(pnm read) image-read: Unexpected character"))
+      (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
+            (error "(pnm read) image-read: Not supported magic number"))
+          magic-number))
+      (define (read-number*)
+        (let ((n (read-number in)))
+          (when (eof-object? n)
+            (unexpected-eof-error))
+          (unless n
+            (unexpected-char-error))
+          n))
+      (define (read-whitespaces*)
+        (when (eof-object? (read-whitespaces in))
+          (unexpected-eof-error)))
+
+      (let ((magic-number (read-magic-number*)))
+        (read-whitespaces*)
+        (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))))))))))
+
+    (define (whitespace? u8)
+      (case (integer->char u8)
+        ((#\newline #\return #\tab #\space) #t)
+        (else #f)))
+
+    (define (comment? u8)
+      (char=? #\# (integer->char u8)))
+
+    (define (newline? u8)
+      (case (integer->char u8)
+        ((#\newline #\return) #t)
+        (else #f)))
+
+    (define (read-comment in)
+      (let ((u8 (peek-u8 in)))
+        (cond ((eof-object? u8) (eof-object))
+              ((newline? u8)
+               (read-u8 in)
+               (read-whitespaces in))
+              (else
+               (read-u8 in)
+               (read-comment in)))))
+
+    (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)
+         (else #f))))
+
+    (define (read-whitespaces in)
+      (let ((u8 (peek-u8 in)))
+        (cond ((eof-object? u8) (eof-object))
+              ((whitespace? u8)
+               (read-u8 in)
+               (read-whitespaces in))
+              ((comment? u8)
+               (read-u8 in)
+               (read-comment in))
+              (else #t))))
+
+    (define (read-number in)
+      (call-with-current-continuation
+       (lambda (return)
+         (let ((u8 (peek-u8 in)))
+           (when (or (eof-object? u8)
+                     (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)))))))))
diff --git a/pnm/write.scm b/pnm/write.scm
new file mode 100644
index 0000000..038bf82
--- /dev/null
+++ b/pnm/write.scm
@@ -0,0 +1,25 @@
+(define-library (pnm write)
+  (export image-write)
+  (import (scheme base)
+          (pnm image))
+  (begin
+    (define (image-write image out)
+      (define (write-string-u8 str)
+        (string-for-each (lambda (c) (write-u8 (char->integer c) out))
+                         str))
+      (case (image-type image)
+        ((ppm)
+         (write-string-u8 "P6\n"))
+        ((pgm)
+         (write-string-u8 "P5\n"))
+        (else
+         (error "(pnm write) pnm-write: Not supported type" (image-type image))))
+      (write-string-u8 (number->string (image-width image)))
+      (write-string-u8 "\n")
+      (write-string-u8 (number->string (image-height image)))
+      (write-string-u8 "\n")
+      (case (image-type image)
+        ((pgm ppm)
+         (write-string-u8 (number->string (image-maxval image)))
+         (write-string-u8 "\n")))
+      (write-bytevector (image-data image) out))))
-- 
cgit v1.2.3