;;; 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)))))))
