1 files changed, 44 insertions, 175 deletions

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))))