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