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/pbm.scm | 42 +++++++++++++++++++++++++++---------------
 1 file changed, 27 insertions(+), 15 deletions(-)

(limited to 'pnm/pbm.scm')

diff --git a/pnm/pbm.scm b/pnm/pbm.scm
index b3d2c3c..696c4d3 100644
--- a/pnm/pbm.scm
+++ b/pnm/pbm.scm
@@ -21,22 +21,21 @@
           %make-pbm-image)
   (import (scheme base)
           (scheme case-lambda)
-          (pnm image))
-  (cond-expand
-    ((library (scheme bitwise))
-     (import (only (scheme bitwise) bit-set? copy-bit)))
-    ((library (srfi 60))
-     (import (only (srfi 60) bit-set? copy-bit)))
-    ((library (srfi 151))
-     (import (only (srfi 151) bit-set? copy-bit))))
+          (pnm image)
+          (pnm private checker)
+          (pnm private bitwise))
   (begin
-    (define (make-pbm-image width height)
-      (let* ((byte-width (ceiling (/ width 8)))
-             (byte-count (* byte-width height))
-             (data (make-bytevector byte-count 0)))
-        (%make-pbm-image width height data)))
+    (define make-pbm-image
+      (case-lambda
+        ((width height)
+         (make-pbm-image width height #f))
+        ((width height unsafe?)
+         (let* ((byte-width (ceiling (/ width 8)))
+                (byte-count (* byte-width height))
+                (data (make-bytevector byte-count 0)))
+           (%make-pbm-image width height data unsafe?)))))
 
-    (define (%make-pbm-image width height data)
+    (define (%make-pbm-image width height data unsafe?)
       (let* ((byte-width (ceiling (/ width 8)))
              (byte-count (* byte-width height)))
         (define (xy->byte-idx+bit-idx x y)
@@ -55,4 +54,17 @@
                                   (copy-bit (- 7 bit-idx) byte b)))))
         (unless (= byte-count (bytevector-length data))
           (error (string-append "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count)))
-        (make-image 'pbm width height #t data pixel-getter pixel-setter)))))
+        (let ((check-xy (make-xy-checker width height))
+              (check-boolean-value (make-boolean-value-checker)))
+          (make-image 'pbm width height #t data
+                      (if unsafe?
+                          pixel-getter
+                          (lambda (x y)
+                            (check-xy x y)
+                            (pixel-getter x y)))
+                      (if unsafe?
+                          pixel-setter
+                          (lambda (x y v)
+                            (check-xy x y)
+                            (check-boolean-value v)
+                            (pixel-setter x y v)))))))))
-- 
cgit v1.2.3