From 232d1c28ea6d797e01ea069f28c9e4b138117802 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sun, 4 Aug 2024 00:54:15 +0900
Subject: Support reading P1, P2, and P3 formats

---
 pnm/read.scm | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 64 insertions(+), 11 deletions(-)

(limited to 'pnm')

diff --git a/pnm/read.scm b/pnm/read.scm
index e3cb84b..22a6a02 100644
--- a/pnm/read.scm
+++ b/pnm/read.scm
@@ -54,6 +54,9 @@
             (unexpected-eof-error))
           (unless result
             (error "(pnm read) image-read: Unexpected character (expected whitespace)"))))
+      (define (read-single-whitespace*)
+        (unless (whitespace? (read-u8*))
+          (unexpected-char-error)))
 
       (let ((magic-number (read-magic-number*)))
         (read-whitespaces*)
@@ -62,26 +65,46 @@
           (let ((height (read-number in)))
             (case magic-number
               ((P4)
-               (unless (whitespace? (read-u8*))
-                 (unexpected-char-error))
+               (read-single-whitespace*)
                (make-pbm-image width height
                                (read-bytevector (* (ceiling (/ width 8)) height) in)))
+              ((P1)
+               (let ((byte-width (ceiling (/ width 8)))
+                     (pbm-image (make-pbm-image width height)))
+                 (read-text-raster width height #f in
+                                   (lambda (x y v)
+                                     (image-set! pbm-image x y (= v 1)))
+                                   unexpected-eof-error
+                                   unexpected-char-error)
+                 pbm-image))
               (else
                (read-whitespaces*)
                (let ((maxval (read-number in)))
-                 (unless (whitespace? (read-u8*))
-                   (unexpected-char-error))
                  (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))))
+                   ((P3)
+                    (let ((ppm-image (make-ppm-image width height maxval)))
+                      (read-text-raster width height #t in (image-pixel-setter ppm-image)
+                                        unexpected-eof-error
+                                        unexpected-char-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))))))))))))
+                                        (read-bytevector (* 2 width height) in))))
+                   ((P2)
+                    (let ((pgm-image (make-pgm-image width height maxval)))
+                      (read-text-raster width height #f in (image-pixel-setter pgm-image)
+                                        unexpected-eof-error
+                                        unexpected-char-error)
+                      pgm-image))))))))))
 
     (define (whitespace? u8)
       (case (integer->char u8)
@@ -136,12 +159,14 @@
              (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)
-         (else #f))))
+        (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)))
@@ -151,6 +176,34 @@
                (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)
-- 
cgit v1.2.3