aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--pnm/pbm.scm56
-rw-r--r--pnm/pgm.scm86
-rw-r--r--pnm/ppm.scm120
-rw-r--r--pnm/read.scm20
4 files changed, 141 insertions, 141 deletions
diff --git a/pnm/pbm.scm b/pnm/pbm.scm
index 7e7bc78..b8e3178 100644
--- a/pnm/pbm.scm
+++ b/pnm/pbm.scm
@@ -17,7 +17,8 @@
;;; along with R7RS-PNM. If not, see <https://www.gnu.org/licenses/>.
(define-library (pnm pbm)
- (export make-pbm-image)
+ (export make-pbm-image
+ %make-pbm-image)
(import (scheme base)
(scheme case-lambda)
(pnm image))
@@ -29,30 +30,29 @@
((library (srfi 151))
(import (only (srfi 151) bit-set? copy-bit))))
(begin
- (define make-pbm-image
- (case-lambda
- ((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)))
- ((width height data)
- (let* ((byte-width (ceiling (/ width 8)))
- (byte-count (* byte-width height)))
- (define (xy->byte-idx+bit-idx x y)
- (let-values (((byte-x bit-x) (floor/ x 8)))
- (values (+ (* y byte-width)
- byte-x)
- bit-x)))
- (define (pixel-getter x y)
- (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y)))
- (let ((byte (bytevector-u8-ref data byte-idx)))
- (bit-set? (- 7 bit-idx) byte))))
- (define (pixel-setter x y b)
- (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y)))
- (let ((byte (bytevector-u8-ref data byte-idx)))
- (bytevector-u8-set! data byte-idx
- (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 1 data pixel-getter pixel-setter)))))))
+ (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 width height data)
+ (let* ((byte-width (ceiling (/ width 8)))
+ (byte-count (* byte-width height)))
+ (define (xy->byte-idx+bit-idx x y)
+ (let-values (((byte-x bit-x) (floor/ x 8)))
+ (values (+ (* y byte-width)
+ byte-x)
+ bit-x)))
+ (define (pixel-getter x y)
+ (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y)))
+ (let ((byte (bytevector-u8-ref data byte-idx)))
+ (bit-set? (- 7 bit-idx) byte))))
+ (define (pixel-setter x y b)
+ (let-values (((byte-idx bit-idx) (xy->byte-idx+bit-idx x y)))
+ (let ((byte (bytevector-u8-ref data byte-idx)))
+ (bytevector-u8-set! data byte-idx
+ (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 1 data pixel-getter pixel-setter)))))
diff --git a/pnm/pgm.scm b/pnm/pgm.scm
index 0f448f6..89f4c35 100644
--- a/pnm/pgm.scm
+++ b/pnm/pgm.scm
@@ -17,53 +17,53 @@
;;; along with R7RS-PNM. If not, see <https://www.gnu.org/licenses/>.
(define-library (pnm pgm)
- (export make-pgm-image)
+ (export make-pgm-image
+ %make-pgm-image)
(import (scheme base)
(scheme case-lambda)
(pnm image))
(begin
- (define make-pgm-image
- (case-lambda
- ((width height maxval)
- (when (or (< maxval 0)
- (< 65536 maxval))
- (error "(pnm pgm) make-pgm: maxval is out of range"))
- (let* ((byte-count (* width height
- (if (< maxval 256)
- 1
- 2)))
- (data (make-bytevector byte-count 0)))
- (make-pgm-image width height maxval data)))
- ((width height maxval data)
- (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 (pixel-getter x y)
- (let ((idx (xy->idx x y)))
- (bytevector-u8-ref data idx)))
- (define (pixel-setter x y v)
- (let ((idx (xy->idx x y)))
- (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))
- (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)))))
- (define (pixel-setter x y v)
- (let ((idx (xy->idx x y)))
- (let-values (((v1 v2) (split-value 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 (make-pgm-image width height maxval)
+ (when (or (< maxval 0)
+ (< 65536 maxval))
+ (error "(pnm pgm) make-pgm: maxval is out of range"))
+ (let* ((byte-count (* width height
+ (if (< maxval 256)
+ 1
+ 2)))
+ (data (make-bytevector byte-count 0)))
+ (%make-pgm-image width height maxval data)))
+
+ (define (%make-pgm-image width height maxval data)
+ (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 (pixel-getter x y)
+ (let ((idx (xy->idx x y)))
+ (bytevector-u8-ref data idx)))
+ (define (pixel-setter x y v)
+ (let ((idx (xy->idx x y)))
+ (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))
+ (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)))))
+ (define (pixel-setter x y v)
+ (let ((idx (xy->idx x y)))
+ (let-values (((v1 v2) (split-value 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)
diff --git a/pnm/ppm.scm b/pnm/ppm.scm
index 95ce837..496eee1 100644
--- a/pnm/ppm.scm
+++ b/pnm/ppm.scm
@@ -17,70 +17,70 @@
;;; along with R7RS-PNM. If not, see <https://www.gnu.org/licenses/>.
(define-library (pnm ppm)
- (export make-ppm-image)
+ (export make-ppm-image
+ %make-ppm-image)
(import (scheme base)
(scheme case-lambda)
(pnm image))
(begin
- (define make-ppm-image
- (case-lambda
- ((width height maxval)
- (when (or (< maxval 0)
- (< 65536 maxval))
- (error "(pnm ppm) make-ppm-image: Maxval is out of range"))
- (let ((data (make-bytevector (* width
- height
- (if (< maxval 256)
- 3
- 6))
- 0)))
- (make-ppm-image width height maxval data)))
- ((width height maxval data)
- (when (or (< maxval 0)
- (< 65536 maxval))
- (error "(pnm ppm) make-ppm-image: Maxval is out of range"))
- (if (< maxval 256)
- (let* ((w*3 (* width 3))
- (byte-count (* w*3 height)))
- (define (xy->idx x y) (+ (* 3 x) (* y w*3)))
- (define (pixel-getter x y)
- (let ((idx (xy->idx x y)))
- (values (bytevector-u8-ref data idx)
- (bytevector-u8-ref data (+ idx 1))
- (bytevector-u8-ref data (+ idx 2)))))
- (define (pixel-setter x y r g b)
- (let ((idx (xy->idx x y)))
- (bytevector-u8-set! data idx r)
- (bytevector-u8-set! data (+ idx 1) g)
- (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))
- (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))))))
- (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)))
- (bytevector-u8-set! data idx r1)
- (bytevector-u8-set! data (+ idx 1) r2)
- (bytevector-u8-set! data (+ idx 2) g1)
- (bytevector-u8-set! data (+ idx 3) g2)
- (bytevector-u8-set! data (+ idx 4) b1)
- (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 (make-ppm-image width height maxval)
+ (when (or (< maxval 0)
+ (< 65536 maxval))
+ (error "(pnm ppm) make-ppm-image: Maxval is out of range"))
+ (let ((data (make-bytevector (* width
+ height
+ (if (< maxval 256)
+ 3
+ 6))
+ 0)))
+ (%make-ppm-image width height maxval data)))
+
+ (define (%make-ppm-image width height maxval data)
+ (when (or (< maxval 0)
+ (< 65536 maxval))
+ (error "(pnm ppm) make-ppm-image: Maxval is out of range"))
+ (if (< maxval 256)
+ (let* ((w*3 (* width 3))
+ (byte-count (* w*3 height)))
+ (define (xy->idx x y) (+ (* 3 x) (* y w*3)))
+ (define (pixel-getter x y)
+ (let ((idx (xy->idx x y)))
+ (values (bytevector-u8-ref data idx)
+ (bytevector-u8-ref data (+ idx 1))
+ (bytevector-u8-ref data (+ idx 2)))))
+ (define (pixel-setter x y r g b)
+ (let ((idx (xy->idx x y)))
+ (bytevector-u8-set! data idx r)
+ (bytevector-u8-set! data (+ idx 1) g)
+ (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))
+ (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))))))
+ (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)))
+ (bytevector-u8-set! data idx r1)
+ (bytevector-u8-set! data (+ idx 1) r2)
+ (bytevector-u8-set! data (+ idx 2) g1)
+ (bytevector-u8-set! data (+ idx 3) g2)
+ (bytevector-u8-set! data (+ idx 4) b1)
+ (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)
diff --git a/pnm/read.scm b/pnm/read.scm
index e277a32..a2e0555 100644
--- a/pnm/read.scm
+++ b/pnm/read.scm
@@ -64,8 +64,8 @@
(case magic-number
((P4)
(read-single-whitespace*)
- (make-pbm-image width height
- (read-bytevector (* (ceiling (/ width 8)) height) in)))
+ (%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)))
@@ -81,10 +81,10 @@
(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))))
+ (%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)
@@ -93,10 +93,10 @@
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))))
+ (%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)
generated by cgit v1.2.3 (git 2.50.1) at 2025-10-30 00:06:28 +0000