From f67f8d68b33a5d0b2ae2409a81c30d852a475ebe Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Fri, 9 Aug 2024 02:28:45 +0900
Subject: Add `unsafe?` option for image creation procedures

- Add (private bitwise) module and use it
- Add (private checker) module and use it
- Add (private double-byte) module and use it
---
 pnm/pgm.scm | 48 +++++++++++++++++++++++++++++++-----------------
 1 file changed, 31 insertions(+), 17 deletions(-)

(limited to 'pnm/pgm.scm')

diff --git a/pnm/pgm.scm b/pnm/pgm.scm
index 200720f..6bb29d2 100644
--- a/pnm/pgm.scm
+++ b/pnm/pgm.scm
@@ -21,13 +21,17 @@
           %make-pgm-image)
   (import (scheme base)
           (scheme case-lambda)
-          (pnm image))
+          (pnm image)
+          (pnm private checker)
+          (pnm private double-byte))
   (begin
     (define make-pgm-image
       (case-lambda
         ((width height)
-         (make-pgm-image width height 255))
+         (make-pgm-image width height 255 #f))
         ((width height maxval)
+         (make-pgm-image width height maxval #f))
+        ((width height maxval unsafe?)
          (when (or (< maxval 0)
                    (< 65536 maxval))
            (error "(pnm pgm) make-pgm: maxval is out of range"))
@@ -36,15 +40,28 @@
                                    1
                                    2)))
                 (data (make-bytevector byte-count 0)))
-           (%make-pgm-image width height maxval data)))))
+           (%make-pgm-image width height maxval data unsafe?)))))
 
-    (define (%make-pgm-image width height maxval data)
+    (define (%make-pgm-image width height maxval data unsafe?)
+      (define (make-safe-pixel-getter pixel-getter)
+        (let ((check-xy (make-xy-checker width height)))
+          (lambda (x y)
+            (check-xy x y)
+            (pixel-getter x y))))
+      (define (make-safe-pixel-setter pixel-setter)
+        (let ((check-xy (make-xy-checker width height))
+              (check-value (make-value-checker maxval 'v)))
+          (lambda (x y v)
+            (check-xy x y)
+            (check-value v)
+            (pixel-setter x y v))))
       (when (or (< maxval 0)
                 (< 65536 maxval))
         (error "(pnm pgm) make-pgm: maxval is out of range"))
       (if (< maxval 256)
           (let ((byte-count (* width height)))
-            (define (xy->idx x y) (+ x (* y width)))
+            (define (xy->idx x y)
+              (+ x (* y width)))
             (define (pixel-getter x y)
               (let ((idx (xy->idx x y)))
                 (bytevector-u8-ref data idx)))
@@ -53,25 +70,22 @@
                 (bytevector-u8-set! data idx v)))
             (unless (= byte-count (bytevector-length data))
               (error (string-append "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count)))
-            (make-image 'pgm width height maxval data pixel-getter pixel-setter))
+            (make-image 'pgm width height maxval data
+                        (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter))
+                        (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter))))
           (let ((byte-count (* width height 2)))
             (define (xy->idx x y) (+ x (* y width)))
             (define (pixel-getter x y)
               (let ((idx (xy->idx x y)))
-                (combine-values (bytevector-u8-ref data idx)
-                                (bytevector-u8-ref data (+ idx 1)))))
+                (combine-bytes (bytevector-u8-ref data idx)
+                               (bytevector-u8-ref data (+ idx 1)))))
             (define (pixel-setter x y v)
               (let ((idx (xy->idx x y)))
-                (let-values (((v1 v2) (split-value v)))
+                (let-values (((v1 v2) (split-double-byte v)))
                   (bytevector-u8-set! data idx v1)
                   (bytevector-u8-set! data (+ idx 1) v2))))
             (unless (= byte-count (bytevector-length data))
               (error (string-append "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count)))
-            (make-image 'pgm width height maxval data pixel-getter pixel-setter))))
-
-    (define (split-value v)
-      (values (modulo (quotient v 256) 256)
-              (modulo v 256)))
-
-    (define (combine-values l r)
-      (+ (* 256 l) r))))
+            (make-image 'pgm width height maxval data
+                        (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter))
+                        (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter))))))))
-- 
cgit v1.2.3