diff options
| -rw-r--r-- | pnm/write.scm | 108 |
1 files changed, 93 insertions, 15 deletions
diff --git a/pnm/write.scm b/pnm/write.scm index 75cd433..849e3de 100644 --- a/pnm/write.scm +++ b/pnm/write.scm @@ -19,27 +19,105 @@ (define-library (pnm write) (export image-write) (import (scheme base) + (scheme case-lambda) (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)) + (define image-write + (case-lambda + ((image out) + (case (image-type image) + ((ppm) + (write-string-u8 "P6\n" out)) + ((pgm) + (write-string-u8 "P5\n" out)) + ((pbm) + (write-string-u8 "P4\n" out)) + (else + (error "(pnm write) image-write: Not supported type" (image-type image)))) + (write-string-u8 (number->string (image-width image)) out) + (write-string-u8 " " out) + (write-string-u8 (number->string (image-height image)) out) + (write-string-u8 "\n" out) + (case (image-type image) + ((pgm ppm) + (write-string-u8 (number->string (image-maxval image)) out) + (write-string-u8 "\n" out))) + (write-bytevector (image-data image) out)) + ((image out plain?) + (if plain? + (image-write/plan image out) + (image-write image out))))) + + (define (image-write/plan image out) (case (image-type image) ((ppm) - (write-string-u8 "P6\n")) + (write-string-u8 "P3\n" out)) ((pgm) - (write-string-u8 "P5\n")) + (write-string-u8 "P2\n" out)) ((pbm) - (write-string-u8 "P4\n")) + (write-string-u8 "P1\n" out)) (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") + (error "(pnm write) image-write: Not supported type" (image-type image)))) + (write-string-u8 (number->string (image-width image)) out) + (write-string-u8 " " out) + (write-string-u8 (number->string (image-height image)) out) + (write-string-u8 "\n" out) (case (image-type image) ((pgm ppm) - (write-string-u8 (number->string (image-maxval image))) - (write-string-u8 "\n"))) - (write-bytevector (image-data image) out)))) + (write-string-u8 (number->string (image-maxval image)) out) + (write-string-u8 "\n" out))) + (let-values (((write-token write-newline) + (limit-line-length-writer 70 out))) + (let ((width (image-width image)) + (height (image-height image))) + (define (write-raster write-pixel) + (do ((y 0 (+ y 1))) + ((= y height)) + (write-pixel 0 y) + (do ((x 1 (+ x 1))) + ((= x width)) + (write-pixel x y)) + (write-newline))) + (case (image-type image) + ((ppm) + (write-raster + (lambda (x y) + (let-values (((r g b) (image-ref image x y))) + (write-token (number->string r)) + (write-token (number->string g)) + (write-token (number->string b)))))) + ((pgm) + (write-raster + (lambda (x y) + (let ((v (image-ref image x y))) + (write-token (number->string v)))))) + ((pbm) + (write-raster + (lambda (x y) + (let ((b (image-ref image x y))) + (write-token (if b "1" "0")))))))))) + + (define (write-string-u8 str out) + (string-for-each (lambda (c) (write-u8 (char->integer c) out)) + str)) + + (define (limit-line-length-writer limit out) + (let ((current-length 0)) + (define (write-token str) + (let ((str-len (string-length str))) + (cond ((zero? current-length) + (write-string-u8 str out) + (set! current-length str-len)) + ((<= (+ current-length str-len 1) limit) + (write-string-u8 " " out) + (write-string-u8 str out) + (set! current-length (+ current-length 1 str-len))) + (else + (write-string-u8 "\n" out) + (write-string-u8 str out) + (set! current-length str-len))))) + (define (write-newline) + (write-string-u8 "\n" out) + (set! current-length 0)) + (values write-token + write-newline))))) |