diff options
Diffstat (limited to 'pnm/ppm.scm')
| -rw-r--r-- | pnm/ppm.scm | 59 |
1 files changed, 38 insertions, 21 deletions
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)))))))) |