diff options
| -rw-r--r-- | pnm/read.scm | 75 |
1 files changed, 64 insertions, 11 deletions
diff --git a/pnm/read.scm b/pnm/read.scm index e3cb84b..22a6a02 100644 --- a/pnm/read.scm +++ b/pnm/read.scm @@ -54,6 +54,9 @@ (unexpected-eof-error)) (unless result (error "(pnm read) image-read: Unexpected character (expected whitespace)")))) + (define (read-single-whitespace*) + (unless (whitespace? (read-u8*)) + (unexpected-char-error))) (let ((magic-number (read-magic-number*))) (read-whitespaces*) @@ -62,26 +65,46 @@ (let ((height (read-number in))) (case magic-number ((P4) - (unless (whitespace? (read-u8*)) - (unexpected-char-error)) + (read-single-whitespace*) (make-pbm-image width height (read-bytevector (* (ceiling (/ width 8)) height) in))) + ((P1) + (let ((byte-width (ceiling (/ width 8))) + (pbm-image (make-pbm-image width height))) + (read-text-raster width height #f in + (lambda (x y v) + (image-set! pbm-image x y (= v 1))) + unexpected-eof-error + unexpected-char-error) + pbm-image)) (else (read-whitespaces*) (let ((maxval (read-number in))) - (unless (whitespace? (read-u8*)) - (unexpected-char-error)) (case magic-number ((P6) + (read-single-whitespace*) (make-ppm-image width height maxval (if (< maxval 256) (read-bytevector (* 3 width height) in) (read-bytevector (* 6 width height) in)))) + ((P3) + (let ((ppm-image (make-ppm-image width height maxval))) + (read-text-raster width height #t in (image-pixel-setter ppm-image) + unexpected-eof-error + unexpected-char-error) + ppm-image)) ((P5) + (read-single-whitespace*) (make-pgm-image width height maxval (if (< maxval 256) (read-bytevector (* width height) in) - (read-bytevector (* 2 width height) in)))))))))))) + (read-bytevector (* 2 width height) in)))) + ((P2) + (let ((pgm-image (make-pgm-image width height maxval))) + (read-text-raster width height #f in (image-pixel-setter pgm-image) + unexpected-eof-error + unexpected-char-error) + pgm-image)))))))))) (define (whitespace? u8) (case (integer->char u8) @@ -136,12 +159,14 @@ (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) - ((and (= u8-1 P/u8) (= u8-2/int 4)) 'P4) - (else #f)))) + (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) + ((and (= u8-1 P/u8) (= u8-2/int 4)) 'P4) + ((and (= u8-1 P/u8) (= u8-2/int 3)) 'P3) + ((and (= u8-1 P/u8) (= u8-2/int 2)) 'P2) + ((and (= u8-1 P/u8) (= u8-2/int 1)) 'P1) + (else #f)))) (define (read-whitespaces in) (let ((u8 (peek-u8 in))) @@ -151,6 +176,34 @@ (skip-whitespace in)) (else #f)))) + (define (read-text-raster width height rgb? in proc fail-eof-object fail-unexpected-char) + (call-with-current-continuation + (lambda (return) + (define (read-whitespaces*) + (let ((result (read-whitespaces in))) + (when (eof-object? result) + (return (fail-eof-object))) + (unless result + (return (fail-unexpected-char))))) + (define (read-number*) + (let ((number (read-number in))) + (when (eof-object? number) + (return (fail-eof-object))) + (unless number + (return (fail-unexpected-char))) + number)) + (let ((size (* width height))) + (do ((y 0 (+ y 1))) + ((= y height)) + (do ((x 0 (+ x 1))) + ((= x width)) + (if rgb? + (let* ((r (begin (read-whitespaces*) (read-number*))) + (g (begin (read-whitespaces*) (read-number*))) + (b (begin (read-whitespaces*) (read-number*)))) + (proc x y r g b)) + (proc x y (begin (read-whitespaces*) (read-number*)))))))))) + (define (read-number in) (call-with-current-continuation (lambda (return) |