diff options
Diffstat (limited to 'image-format/pnm/read.scm')
| -rw-r--r-- | image-format/pnm/read.scm | 253 |
1 files changed, 253 insertions, 0 deletions
diff --git a/image-format/pnm/read.scm b/image-format/pnm/read.scm new file mode 100644 index 0000000..0086113 --- /dev/null +++ b/image-format/pnm/read.scm @@ -0,0 +1,253 @@ +;;; R7RS-PNM --- Library for reading and writing PNM (Portable Any Map) files for R7RS +;;; Copyright © 2024 Masaya Tojo <masaya@tojo.tokyo> +;;; +;;; This file is part of R7RS-PNM. +;;; +;;; R7RS-PNM is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as published +;;; by the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; R7RS-PNM is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; 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 (image-format pnm read) + (export pnm-image-read + pnm-parse-error?) + (import (scheme base) + (scheme case-lambda) + (image-format pnm image) + (image-format pnm pbm) + (image-format pnm pgm) + (image-format pnm ppm)) + (begin + (define pnm-image-read + (case-lambda + ((in) + (pnm-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) + (pnm-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 (pnm-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 (pnm-image-pixel-setter pgm-image) + unexpected-eof-error + unexpected-character-error) + pgm-image)))))))))))) + + (define (whitespace? u8) + (case (integer->char u8) + ((#\newline + #\return + #\tab + #\space + #\x000B ;; Vertical Tab + #\x000c ;; Form Feed + ) + #t) + (else #f))) + + (define (comment? u8) + (char=? #\# (integer->char u8))) + + (define (newline? u8) + (case (integer->char u8) + ((#\newline) #t) + (else #f))) + + (define (read-comment in) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) (eof-object)) + ((newline? u8) + (read-u8 in) + (skip-whitespace in)) + (else + (read-u8 in) + (read-comment in))))) + + (define (skip-whitespace in) + (let ((u8 (peek-u8 in))) + (cond ((eof-object? u8) #t) + ((whitespace? u8) + (read-u8 in) + (skip-whitespace in)) + ((comment? u8) + (read-u8 in) + (read-comment in)) + (else #t)))) + + (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) + ((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))) + (cond ((eof-object? u8) (eof-object)) + ((whitespace? u8) + (read-u8 in) + (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) + (let ((u8 (peek-u8 in))) + (when (eof-object? u8) + (return (eof-object))) + (when (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 (unexpected-magic-number-error) + (raise (pnm-parse-error "(image-format pnm read) pnm-image-read: Not supported magic number"))) + (define (unexpected-eof-error) + (raise (pnm-parse-error "(image-format pnm read) pnm-image-read: Unexpected end of file"))) + (define (unexpected-character-error) + (raise (pnm-parse-error "(image-format pnm read) pnm-image-read: Unexpected character")))) + (cond-expand + ((library (srfi 35)) + (import (srfi 35)) + (begin + (define-condition-type &pnm-parse-error &error + pnm-parse-error?) + + (define (pnm-parse-error msg) + (raise (condition (&pnm-parse-error) + (&message + (message msg))))))) + (r7rs + (begin + (define-record-type <pnm-parse-error> + (make-pnm-parse-error message) + pnm-parse-error? + (message pnm-parse-error-message)) + + (define (pnm-parse-error msg) + (raise (make-pnm-parse-error msg))))))) |