1 files changed, 122 insertions, 0 deletions
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)))))))))