aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--pnm/pbm.scm42
-rw-r--r--pnm/pgm.scm48
-rw-r--r--pnm/ppm.scm59
-rw-r--r--pnm/private/bitwise.scm38
-rw-r--r--pnm/private/checker.scm65
-rw-r--r--pnm/private/double-byte.scm29
-rw-r--r--pnm/read.scm161
7 files changed, 312 insertions, 130 deletions
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 <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 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 <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 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 <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 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)))
+ (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)))
- ((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))))))))))
+ (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)
generated by cgit v1.2.3 (git 2.50.1) at 2025-10-30 07:49:55 +0000