From f67f8d68b33a5d0b2ae2409a81c30d852a475ebe Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Fri, 9 Aug 2024 02:28:45 +0900 Subject: Add `unsafe?` option for image creation procedures - Add (private bitwise) module and use it - Add (private checker) module and use it - Add (private double-byte) module and use it --- pnm/read.scm | 163 +++++++++++++++++++++++++++++++---------------------------- 1 file changed, 85 insertions(+), 78 deletions(-) (limited to 'pnm/read.scm') diff --git a/pnm/read.scm b/pnm/read.scm index a2e0555..f673c35 100644 --- a/pnm/read.scm +++ b/pnm/read.scm @@ -20,89 +20,96 @@ (export image-read pnm-parse-error?) (import (scheme base) - (scheme write) + (scheme case-lambda) (pnm image) (pnm pbm) (pnm pgm) (pnm ppm)) (begin - (define (image-read in) - (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 - (unexpected-magic-number-error)) - magic-number)) - (define (read-number*) - (let ((n (read-number in))) - (when (eof-object? n) - (unexpected-eof-error)) - (unless n - (unexpected-character-error)) - n)) - (define (read-whitespaces*) - (let ((result (read-whitespaces in))) - (when (eof-object? result) - (unexpected-eof-error)) - (unless result - (unexpected-character-error)))) - (define (read-single-whitespace*) - (unless (whitespace? (read-u8*)) - (unexpected-character-error))) - - (let ((magic-number (read-magic-number*))) - (read-whitespaces*) - (let ((width (read-number in))) - (read-whitespaces*) - (let ((height (read-number in))) - (case magic-number - ((P4) - (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-character-error) - pbm-image)) - (else - (read-whitespaces*) - (let ((maxval (read-number in))) - (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-character-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)))) - ((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-character-error) - pgm-image)))))))))) + (define image-read + (case-lambda + ((in) + (image-read in #f)) + ((in unsafe?) + (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 + (unexpected-magic-number-error)) + magic-number)) + (define (read-number*) + (let ((n (read-number in))) + (when (eof-object? n) + (unexpected-eof-error)) + (unless n + (unexpected-character-error)) + n)) + (define (read-whitespaces*) + (let ((result (read-whitespaces in))) + (when (eof-object? result) + (unexpected-eof-error)) + (unless result + (unexpected-character-error)))) + (define (read-single-whitespace*) + (unless (whitespace? (read-u8*)) + (unexpected-character-error))) + + (let ((magic-number (read-magic-number*))) + (read-whitespaces*) + (let ((width (read-number in))) + (read-whitespaces*) + (let ((height (read-number in))) + (case magic-number + ((P4) + (read-single-whitespace*) + (%make-pbm-image width height + (read-bytevector (* (ceiling (/ width 8)) height) in) + unsafe?)) + ((P1) + (let ((byte-width (ceiling (/ width 8))) + (pbm-image (make-pbm-image width height unsafe?))) + (read-text-raster width height #f in + (lambda (x y v) + (image-set! pbm-image x y (= v 1))) + unexpected-eof-error + unexpected-character-error) + pbm-image)) + (else + (read-whitespaces*) + (let ((maxval (read-number in))) + (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)) + unsafe?)) + ((P3) + (let ((ppm-image (make-ppm-image width height maxval unsafe?))) + (read-text-raster width height #t in (image-pixel-setter ppm-image) + unexpected-eof-error + unexpected-character-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)) + unsafe?)) + ((P2) + (let ((pgm-image (make-pgm-image width height maxval unsafe?))) + (read-text-raster width height #f in (image-pixel-setter pgm-image) + unexpected-eof-error + unexpected-character-error) + pgm-image)))))))))))) (define (whitespace? u8) (case (integer->char u8) -- cgit v1.2.3