From f67f8d68b33a5d0b2ae2409a81c30d852a475ebe Mon Sep 17 00:00:00 2001 From: Masaya Tojo 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 ++++++++---- pnm/pgm.scm | 48 ++++++++----- pnm/ppm.scm | 59 ++++++++++------ pnm/private/bitwise.scm | 38 +++++++++++ pnm/private/checker.scm | 65 ++++++++++++++++++ pnm/private/double-byte.scm | 29 ++++++++ pnm/read.scm | 163 +++++++++++++++++++++++--------------------- 7 files changed, 313 insertions(+), 131 deletions(-) create mode 100644 pnm/private/bitwise.scm create mode 100644 pnm/private/checker.scm create mode 100644 pnm/private/double-byte.scm (limited to 'pnm') 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))))))))) 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)))))))) diff --git a/pnm/ppm.scm b/pnm/ppm.scm index 11331af..bdf60cf 100644 --- a/pnm/ppm.scm +++ b/pnm/ppm.scm @@ -21,13 +21,17 @@ %make-ppm-image) (import (scheme base) (scheme case-lambda) - (pnm image)) + (pnm image) + (pnm private checker) + (pnm private double-byte)) (begin (define make-ppm-image (case-lambda ((width height) (make-ppm-image width height 255)) ((width height maxval) + (make-ppm-image width height maxval #f)) + ((width height maxval unsafe?) (when (or (< maxval 0) (< 65536 maxval)) (error "(pnm ppm) make-ppm-image: Maxval is out of range")) @@ -37,9 +41,25 @@ 3 6)) 0))) - (%make-ppm-image width height maxval data))))) + (%make-ppm-image width height maxval data unsafe?))))) - (define (%make-ppm-image width height maxval data) + (define (%make-ppm-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-r (make-value-checker maxval 'r)) + (check-value-g (make-value-checker maxval 'g)) + (check-value-b (make-value-checker maxval 'b))) + (lambda (x y r g b) + (check-xy x y) + (check-value-r r) + (check-value-g g) + (check-value-b b) + (pixel-setter x y r g b)))) (when (or (< maxval 0) (< 65536 maxval)) (error "(pnm ppm) make-ppm-image: Maxval is out of range")) @@ -59,23 +79,25 @@ (bytevector-u8-set! data (+ idx 2) b))) (unless (= byte-count (bytevector-length data)) (error (string-append "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) - (make-image 'ppm width height maxval data pixel-getter pixel-setter)) + (make-image 'ppm 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* ((w*6 (* width 6)) (byte-count (* w*6 height))) (define (xy->idx x y) (+ (* 6 x) (* y w*6))) (define (pixel-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)))))) + (values (combine-bytes (bytevector-u8-ref data idx) + (bytevector-u8-ref data (+ idx 1))) + (combine-bytes (bytevector-u8-ref data (+ idx 2)) + (bytevector-u8-ref data (+ idx 3))) + (combine-bytes (bytevector-u8-ref data (+ idx 4)) + (bytevector-u8-ref data (+ idx 5)))))) (define (pixel-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))) + (let-values (((r1 r2) (split-double-byte r)) + ((g1 g2) (split-double-byte g)) + ((b1 b2) (split-double-byte b))) (bytevector-u8-set! data idx r1) (bytevector-u8-set! data (+ idx 1) r2) (bytevector-u8-set! data (+ idx 2) g1) @@ -84,11 +106,6 @@ (bytevector-u8-set! data (+ idx 5) b2)))) (unless (= byte-count (bytevector-length data)) (error (string-append "(pnm pbm) make-pbm-image: Invalid bytevector length" byte-count))) - (make-image 'ppm 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 'ppm width height maxval data + (if unsafe? pixel-getter (make-safe-pixel-getter pixel-getter)) + (if unsafe? pixel-setter (make-safe-pixel-setter pixel-setter)))))))) diff --git a/pnm/private/bitwise.scm b/pnm/private/bitwise.scm new file mode 100644 index 0000000..a2f2f74 --- /dev/null +++ b/pnm/private/bitwise.scm @@ -0,0 +1,38 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (pnm private bitwise) + (export bitwise-and + bitwise-ior + arithmetic-shift + bit-set? + copy-bit) + (import (scheme base)) + (cond-expand + ((library (scheme bitwise)) + (import (only (scheme bitwise) + bitwise-and bitwise-ior arithmetic-shift + bit-set? copy-bit))) + ((library (srfi 60)) + (import (only (srfi 60) + bitwise-and bitwise-ior arithmetic-shift + bit-set? copy-bit))) + ((library (srfi 151)) + (import (only (srfi 151) + bitwise-and bitwise-ior arithmetic-shift + bit-set? copy-bit))))) diff --git a/pnm/private/checker.scm b/pnm/private/checker.scm new file mode 100644 index 0000000..e212948 --- /dev/null +++ b/pnm/private/checker.scm @@ -0,0 +1,65 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (pnm private checker) + (export make-xy-checker + make-value-checker + make-boolean-value-checker) + (import (scheme base) + (scheme case-lambda) + (pnm image)) + (begin + (define (make-xy-checker width height) + (lambda (x y) + (when (or (not (exact-integer? x)) + (< x 0) + (<= width x)) + (error (string-append "`x` must be an integer such that 0 <= `x` < " + (number->string width)) + x)) + (when (and (not (exact-integer? y)) + (< y 0) + (<= height y)) + (error (string-append "`y` must be an integer such that 0 <= `y` < " + (number->string width)) + y)))) + + (define (make-value-checker maxval sym) + (define message + (string-append "`" (symbol->string sym) "`" + " must be an integer such that 0 < " + "`" (symbol->string sym) "`" + " < " + (number->string maxval))) + (lambda (v) + (when (or (not (exact-integer? v)) + (< v 0) + (< maxval v)) + (error message v)))) + + (define (make-boolean-value-checker) + (lambda (v) + (when (not (boolean? v)) + (error "`v` must be a boolean value" v)))) + + (define (split-value v) + (values (modulo (quotient v 256) 256) + (modulo v 256))) + + (define (combine-values l r) + (+ (* 256 l) r)))) diff --git a/pnm/private/double-byte.scm b/pnm/private/double-byte.scm new file mode 100644 index 0000000..fd40336 --- /dev/null +++ b/pnm/private/double-byte.scm @@ -0,0 +1,29 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo +;;; +;;; 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 . + +(define-library (pnm private double-byte) + (export split-double-byte combine-bytes) + (import (scheme base) + (pnm private bitwise)) + (begin + (define (split-double-byte v) + (values (arithmetic-shift v -8) + (bitwise-and v 255))) + + (define (combine-bytes l r) + (bitwise-ior (arithmetic-shift l 8) r)))) diff --git a/pnm/read.scm b/pnm/read.scm index a2e0555..f673c35 100644 --- a/pnm/read.scm +++ b/pnm/read.scm @@ -20,89 +20,96 @@ (export image-read pnm-parse-error?) (import (scheme base) - (scheme write) + (scheme case-lambda) (pnm image) (pnm pbm) (pnm pgm) (pnm ppm)) (begin - (define (image-read in) - (define (read-u8*) - (let ((u8 (read-u8 in))) - (when (eof-object? u8) - (unexpected-eof-error)) - u8)) - (define (read-magic-number*) - (let ((magic-number (read-magic-number in))) - (when (eof-object? magic-number) - (unexpected-eof-error)) - (unless magic-number - (unexpected-magic-number-error)) - magic-number)) - (define (read-number*) - (let ((n (read-number in))) - (when (eof-object? n) - (unexpected-eof-error)) - (unless n - (unexpected-character-error)) - n)) - (define (read-whitespaces*) - (let ((result (read-whitespaces in))) - (when (eof-object? result) - (unexpected-eof-error)) - (unless result - (unexpected-character-error)))) - (define (read-single-whitespace*) - (unless (whitespace? (read-u8*)) - (unexpected-character-error))) - - (let ((magic-number (read-magic-number*))) - (read-whitespaces*) - (let ((width (read-number in))) - (read-whitespaces*) - (let ((height (read-number in))) - (case magic-number - ((P4) - (read-single-whitespace*) - (%make-pbm-image width height - (read-bytevector (* (ceiling (/ width 8)) height) in))) - ((P1) - (let ((byte-width (ceiling (/ width 8))) - (pbm-image (make-pbm-image width height))) - (read-text-raster width height #f in - (lambda (x y v) - (image-set! pbm-image x y (= v 1))) - unexpected-eof-error - unexpected-character-error) - pbm-image)) - (else - (read-whitespaces*) - (let ((maxval (read-number in))) - (case magic-number - ((P6) - (read-single-whitespace*) - (%make-ppm-image width height maxval - (if (< maxval 256) - (read-bytevector (* 3 width height) in) - (read-bytevector (* 6 width height) in)))) - ((P3) - (let ((ppm-image (make-ppm-image width height maxval))) - (read-text-raster width height #t in (image-pixel-setter ppm-image) - unexpected-eof-error - unexpected-character-error) - ppm-image)) - ((P5) - (read-single-whitespace*) - (%make-pgm-image width height maxval - (if (< maxval 256) - (read-bytevector (* width height) in) - (read-bytevector (* 2 width height) in)))) - ((P2) - (let ((pgm-image (make-pgm-image width height maxval))) - (read-text-raster width height #f in (image-pixel-setter pgm-image) - unexpected-eof-error - unexpected-character-error) - pgm-image)))))))))) + (define image-read + (case-lambda + ((in) + (image-read in #f)) + ((in unsafe?) + (define (read-u8*) + (let ((u8 (read-u8 in))) + (when (eof-object? u8) + (unexpected-eof-error)) + u8)) + (define (read-magic-number*) + (let ((magic-number (read-magic-number in))) + (when (eof-object? magic-number) + (unexpected-eof-error)) + (unless magic-number + (unexpected-magic-number-error)) + magic-number)) + (define (read-number*) + (let ((n (read-number in))) + (when (eof-object? n) + (unexpected-eof-error)) + (unless n + (unexpected-character-error)) + n)) + (define (read-whitespaces*) + (let ((result (read-whitespaces in))) + (when (eof-object? result) + (unexpected-eof-error)) + (unless result + (unexpected-character-error)))) + (define (read-single-whitespace*) + (unless (whitespace? (read-u8*)) + (unexpected-character-error))) + + (let ((magic-number (read-magic-number*))) + (read-whitespaces*) + (let ((width (read-number in))) + (read-whitespaces*) + (let ((height (read-number in))) + (case magic-number + ((P4) + (read-single-whitespace*) + (%make-pbm-image width height + (read-bytevector (* (ceiling (/ width 8)) height) in) + unsafe?)) + ((P1) + (let ((byte-width (ceiling (/ width 8))) + (pbm-image (make-pbm-image width height unsafe?))) + (read-text-raster width height #f in + (lambda (x y v) + (image-set! pbm-image x y (= v 1))) + unexpected-eof-error + unexpected-character-error) + pbm-image)) + (else + (read-whitespaces*) + (let ((maxval (read-number in))) + (case magic-number + ((P6) + (read-single-whitespace*) + (%make-ppm-image width height maxval + (if (< maxval 256) + (read-bytevector (* 3 width height) in) + (read-bytevector (* 6 width height) in)) + unsafe?)) + ((P3) + (let ((ppm-image (make-ppm-image width height maxval unsafe?))) + (read-text-raster width height #t in (image-pixel-setter ppm-image) + unexpected-eof-error + unexpected-character-error) + ppm-image)) + ((P5) + (read-single-whitespace*) + (%make-pgm-image width height maxval + (if (< maxval 256) + (read-bytevector (* width height) in) + (read-bytevector (* 2 width height) in)) + unsafe?)) + ((P2) + (let ((pgm-image (make-pgm-image width height maxval unsafe?))) + (read-text-raster width height #f in (image-pixel-setter pgm-image) + unexpected-eof-error + unexpected-character-error) + pgm-image)))))))))))) (define (whitespace? u8) (case (integer->char u8) -- cgit v1.2.3