diff options
Diffstat (limited to 'pnm')
| -rw-r--r-- | pnm/image.scm | 35 | ||||
| -rw-r--r-- | pnm/pgm.scm | 219 | ||||
| -rw-r--r-- | pnm/ppm.scm | 246 | ||||
| -rw-r--r-- | pnm/read.scm | 122 | ||||
| -rw-r--r-- | pnm/write.scm | 25 |
5 files changed, 284 insertions, 363 deletions
diff --git a/pnm/image.scm b/pnm/image.scm new file mode 100644 index 0000000..449afc6 --- /dev/null +++ b/pnm/image.scm @@ -0,0 +1,35 @@ +(define-library (pnm image) + (export make-image + image? + image-type + image-width + image-height + image-maxval + image-data + image-pixel-getter + image-pixel-setter + image-ref + image-set!) + (import (scheme base) + (scheme case-lambda)) + (begin + (define-record-type <image> + (make-image type width height maxval data pixel-getter pixel-setter) + image? + (type image-type) + (width image-width) + (height image-height) + (maxval image-maxval) + (data image-data) + (pixel-getter image-pixel-getter) + (pixel-setter image-pixel-setter)) + + (define (image-ref image x y) + ((image-pixel-getter image) x y)) + + (define image-set! + (case-lambda + ((image x y v) + ((image-pixel-setter image) x y v)) + ((image x y r g b) + ((image-pixel-setter image) x y r g b)))))) diff --git a/pnm/pgm.scm b/pnm/pgm.scm index 7f1675c..5abbab2 100644 --- a/pnm/pgm.scm +++ b/pnm/pgm.scm @@ -15,186 +15,55 @@ ;;; ;;; 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 pgm) - (export make-image - image-width - image-height - image-maxval - image-ref - image-set! - image-read - image-write) - (import (scheme base)) + (export make-pgm-image) + (import (scheme base) + (scheme case-lambda) + (pnm image)) (begin - (define-record-type <pgm: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 pgm) make-image: maxval is out of range")) - (let ((data (make-bytevector (* width - height - (if (< maxval 256) - 1 - 2)) - 0))) - (make-image* width height maxval data))) - - (define (make-image* width height maxval data) - (when (or (< maxval 0) - (< 65536 maxval)) - (error "(pnm pgm) make-image: maxval is out of range")) - (if (< maxval 256) - (let () - (define (xy->idx x y) (+ x (* y width))) - (define (getter x y) - (let ((idx (xy->idx x y))) - (bytevector-u8-ref data idx))) - (define (setter x y v) - (let ((idx (xy->idx x y))) - (bytevector-u8-set! data idx v))) - (%make-image width height maxval data getter setter)) - (let () - (define (xy->idx x y) (+ x (* y width))) - (define (getter x y) - (let ((idx (xy->idx x y))) - (combine-values (bytevector-u8-ref data idx) - (bytevector-u8-ref data (+ idx 1))))) - (define (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)))) - (%make-image width height maxval data getter setter)))) + (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 ((data (make-bytevector (* width + height + (if (< maxval 256) + 1 + 2)) + 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 () + (define (xy->idx x y) (+ x (* y width))) + (define (getter x y) + (let ((idx (xy->idx x y))) + (bytevector-u8-ref data idx))) + (define (setter x y v) + (let ((idx (xy->idx x y))) + (bytevector-u8-set! data idx v))) + (make-image 'pgm width height maxval data getter setter)) + (let () + (define (xy->idx x y) (+ x (* y width))) + (define (getter x y) + (let ((idx (xy->idx x y))) + (combine-values (bytevector-u8-ref data idx) + (bytevector-u8-ref data (+ idx 1))))) + (define (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)))) + (make-image 'pgm 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 v) - ((image-setter image) x y v)) - - (define (image-ref image x y) - ((image-getter image) x y)) - - (define (image-read in) - (define (unexpected-eof-error) - (error "(pnm pgm) image-read: Unexpected end of file")) - (define (unexpected-char-error) - (error "(pnm pgm) 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 (p5? u8-1 u8-2) - (error "(pnm pgm) image-read: No expected magic number (expected P5)")) - (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 (* width height) in) - (read-bytevector (* 2 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 (p5? u8-1 u8-2) - (and (= (char->integer #\P) u8-1) - (= (char->integer #\5) 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 "P5\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)))) 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)))) diff --git a/pnm/read.scm b/pnm/read.scm new file mode 100644 index 0000000..01e74d0 --- /dev/null +++ b/pnm/read.scm @@ -0,0 +1,122 @@ +(define-library (pnm read) + (export image-read) + (import (scheme base) + (pnm image) + (pnm pgm) + (pnm ppm)) + (begin + (define (image-read in) + (define (unexpected-eof-error) + (error "(pnm read) image-read: Unexpected end of file")) + (define (unexpected-char-error) + (error "(pnm read) image-read: Unexpected character")) + (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 + (error "(pnm read) image-read: Not supported magic number")) + magic-number)) + (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 ((magic-number (read-magic-number*))) + (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)) + (case magic-number + ((P6) + (make-ppm-image width height maxval + (if (< maxval 256) + (read-bytevector (* 3 width height) in) + (read-bytevector (* 6 width height) in)))) + ((P5) + (make-pgm-image width height maxval + (if (< maxval 256) + (read-bytevector (* width height) in) + (read-bytevector (* 2 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 (read-magic-number in) + (let* ((P/u8 (char->integer #\P)) + (u8-1 (read-u8 in)) + (u8-2 (read-u8 in)) + (u8-2/int (u8->integer u8-2))) + (cond + ((or (eof-object? u8-1) (eof-object? u8-2)) (eof-object)) + ((and (= u8-1 P/u8) (= u8-2/int 6)) 'P6) + ((and (= u8-1 P/u8) (= u8-2/int 5)) 'P5) + (else #f)))) + + (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))))))))) diff --git a/pnm/write.scm b/pnm/write.scm new file mode 100644 index 0000000..038bf82 --- /dev/null +++ b/pnm/write.scm @@ -0,0 +1,25 @@ +(define-library (pnm write) + (export image-write) + (import (scheme base) + (pnm image)) + (begin + (define (image-write image out) + (define (write-string-u8 str) + (string-for-each (lambda (c) (write-u8 (char->integer c) out)) + str)) + (case (image-type image) + ((ppm) + (write-string-u8 "P6\n")) + ((pgm) + (write-string-u8 "P5\n")) + (else + (error "(pnm write) pnm-write: Not supported type" (image-type image)))) + (write-string-u8 (number->string (image-width image))) + (write-string-u8 "\n") + (write-string-u8 (number->string (image-height image))) + (write-string-u8 "\n") + (case (image-type image) + ((pgm ppm) + (write-string-u8 (number->string (image-maxval image))) + (write-string-u8 "\n"))) + (write-bytevector (image-data image) out)))) |