path: root/image-format/pnm/read.scm

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