diff options
author | Masaya Tojo <masaya@tojo.tokyo> | 2024-08-09 02:28:45 +0900 |
---|---|---|
committer | Masaya Tojo <masaya@tojo.tokyo> | 2024-08-09 02:32:21 +0900 |
commit | f67f8d68b33a5d0b2ae2409a81c30d852a475ebe (patch) | |
tree | 25d27ea49614d03dcd2c9bf41ee80a7b23d4a64c /pnm/pgm.scm | |
parent | eea3a41609ab2ac72d19166812e01213de3b0bc3 (diff) |
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
Diffstat (limited to 'pnm/pgm.scm')
-rw-r--r-- | pnm/pgm.scm | 48 |
1 files changed, 31 insertions, 17 deletions
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)))))))) |