diff options
Diffstat (limited to 'pnm/ppm.scm')
| -rw-r--r-- | pnm/ppm.scm | 246 |
1 files changed, 58 insertions, 188 deletions
diff --git a/pnm/ppm.scm b/pnm/ppm.scm index f936e4b..17a7c43 100644 --- a/pnm/ppm.scm +++ b/pnm/ppm.scm @@ -17,198 +17,68 @@ ;;; along with R7RS-PNM. If not, see <https://www.gnu.org/licenses/>. (define-library (pnm ppm) - (export make-image - image-width - image-height - image-maxval - image-ref - image-set! - image-read - image-write) - (import (scheme base)) + (export make-ppm-image) + (import (scheme base) + (scheme case-lambda) + (pnm image)) (begin - (define-record-type <ppm:image> - (%make-image width height maxval data getter setter) - image? - (width image-width) - (height image-height) - (maxval image-maxval) - (data image-data) - (getter image-getter) - (setter image-setter)) - - (define (make-image width height maxval) - (when (or (< maxval 0) - (< 65536 maxval)) - (error "(pnm ppm) make-image: maxval is out of range")) - (let ((data (make-bytevector (* width - height - (if (< maxval 256) - 3 - 6)) - 0))) - (make-image* width height maxval data))) - - (define (make-image* width height maxval data) - (when (or (< maxval 0) - (< 65536 maxval)) - (error "(pnm ppm) make-image: maxval is out of range")) - (if (< maxval 256) - (let* ((w*3 (* width 3))) - (define (xy->idx x y) (+ (* 3 x) (* y w*3))) - (define (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 (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))) - (%make-image width height maxval data getter setter)) - (let* ((w*6 (* width 6))) - (define (xy->idx x y) (+ (* 6 x) (* y w*6))) - (define (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 (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)))) - (%make-image width height maxval data getter setter)))) + (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))) + (define (xy->idx x y) (+ (* 3 x) (* y w*3))) + (define (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 (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))) + (make-image 'ppm width height maxval data getter setter)) + (let* ((w*6 (* width 6))) + (define (xy->idx x y) (+ (* 6 x) (* y w*6))) + (define (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 (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)))) + (make-image 'ppm width height maxval data getter setter)))))) (define (split-value v) (values (modulo (quotient v 256) 256) (modulo v 256))) (define (combine-values l r) - (+ (* 256 l) r)) - - (define (image-set! image x y r g b) - ((image-setter image) x y r g b)) - - (define (image-ref image x y) - ((image-getter image) x y)) - - (define (image-read in) - (define (unexpected-eof-error) - (error "(pnm ppm) image-read: Unexpected end of file")) - (define (unexpected-char-error) - (error "(pnm ppm) image-read: Unexpected character")) - (define (read-u8*) - (let ((u8 (read-u8 in))) - (when (eof-object? u8) - (unexpected-eof-error)) - u8)) - (define (read-number*) - (let ((n (read-number in))) - (when (eof-object? n) - (unexpected-eof-error)) - (unless n - (unexpected-char-error)) - n)) - (define (read-whitespaces*) - (when (eof-object? (read-whitespaces in)) - (unexpected-eof-error))) - (let ((u8-1 (read-u8*)) - (u8-2 (read-u8*))) - (unless (p6? u8-1 u8-2) - (error "(pnm ppm) image-read: No expected magic number (expected P6)")) - (read-whitespaces*) - (let ((width (read-number in))) - (read-whitespaces*) - (let ((height (read-number in))) - (read-whitespaces*) - (let ((maxval (read-number in))) - (unless (whitespace? (read-u8*)) - (unexpected-char-error)) - (make-image* width height maxval - (if (< maxval 256) - (read-bytevector (* 3 width height) in) - (read-bytevector (* 6 width height) in)))))))) - - (define (whitespace? u8) - (case (integer->char u8) - ((#\newline #\return #\tab #\space) #t) - (else #f))) - - (define (comment? u8) - (char=? #\# (integer->char u8))) - - (define (newline? u8) - (case (integer->char u8) - ((#\newline #\return) #t) - (else #f))) - - (define (read-comment in) - (let ((u8 (peek-u8 in))) - (cond ((eof-object? u8) (eof-object)) - ((newline? u8) - (read-u8 in) - (read-whitespaces in)) - (else - (read-u8 in) - (read-comment in))))) - - (define (digit? u8) - (and (<= 48 u8) - (<= u8 57))) - - (define (u8->integer u8) - (- u8 48)) - - (define (p6? u8-1 u8-2) - (and (= (char->integer #\P) u8-1) - (= (char->integer #\6) u8-2))) - - (define (read-whitespaces in) - (let ((u8 (peek-u8 in))) - (cond ((eof-object? u8) (eof-object)) - ((whitespace? u8) - (read-u8 in) - (read-whitespaces in)) - ((comment? u8) - (read-u8 in) - (read-comment in)) - (else #t)))) - - (define (read-number in) - (call-with-current-continuation - (lambda (return) - (let ((u8 (peek-u8 in))) - (when (or (eof-object? u8) - (not (digit? u8))) - (return #f))) - (let loop ((number 0)) - (let ((u8 (peek-u8 in))) - (cond ((eof-object? u8) (eof-object)) - ((digit? u8) - (read-u8 in) - (loop (+ (* number 10) (u8->integer u8)))) - (else number))))))) - - (define (image-write image out) - (define (write-string-u8 str) - (string-for-each (lambda (c) (write-u8 (char->integer c) out)) - str)) - (write-string-u8 "P6\n") - (write-string-u8 (number->string (image-width image))) - (write-string-u8 "\n") - (write-string-u8 (number->string (image-height image))) - (write-string-u8 "\n") - (write-string-u8 (number->string (image-maxval image))) - (write-string-u8 "\n") - (write-bytevector (image-data image) out)))) + (+ (* 256 l) r)))) |