Initial commit

2 files changed, 414 insertions, 0 deletions

diff --git a/pnm/pgm.scm b/pnm/pgm.scm
new file mode 100644
index 0000000..7f1675c
--- /dev/null
+++ b/pnm/pgm.scm
@@ -0,0 +1,200 @@
+;;; 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 (pnm pgm)
+  (export make-image
+          image-width
+          image-height
+          image-maxval
+          image-ref
+          image-set!
+          image-read
+          image-write)
+  (import (scheme base))
+  (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 (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))))
diff --git a/pnm/ppm.scm b/pnm/ppm.scm
new file mode 100644
index 0000000..f936e4b
--- /dev/null
+++ b/pnm/ppm.scm
@@ -0,0 +1,214 @@
+;;; 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 (pnm ppm)
+  (export make-image
+          image-width
+          image-height
+          image-maxval
+          image-ref
+          image-set!
+          image-read
+          image-write)
+  (import (scheme base))
+  (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 (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))))