;;; 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 (pnm read)
  (export image-read)
  (import (scheme base)
          (pnm image)
          (pnm pbm)
          (pnm pgm)
          (pnm ppm))
  (begin
    (define (image-read in)
      (define (unexpected-eof-error)
        (error "(pnm read) image-read: Unexpected end of file"))
      (define (unexpected-char-error)
        (error "(pnm read) image-read: Unexpected character"))
      (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
            (error "(pnm read) image-read: Not supported magic number"))
          magic-number))
      (define (read-number*)
        (let ((n (read-number in)))
          (when (eof-object? n)
            (unexpected-eof-error))
          (unless n
            (unexpected-char-error))
          n))
      (define (read-whitespaces*)
        (when (eof-object? (read-whitespaces in))
          (unexpected-eof-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)
               (unless (whitespace? (read-u8*))
                 (unexpected-char-error))
               (make-pbm-image width height
                               (read-bytevector (* (ceiling (/ width 8)) height) in)))
              (else
               (read-whitespaces*)
               (let ((maxval (read-number in)))
                 (unless (whitespace? (read-u8*))
                   (unexpected-char-error))
                 (case magic-number
                   ((P6)
                    (make-ppm-image width height maxval
                                    (if (< maxval 256)
                                        (read-bytevector (* 3 width height) in)
                                        (read-bytevector (* 6 width height) in))))
                   ((P5)
                    (make-pgm-image width height maxval
                                    (if (< maxval 256)
                                        (read-bytevector (* width height) in)
                                        (read-bytevector (* 2 width height) in))))))))))))

    (define (whitespace? u8)
      (case (integer->char u8)
        ((#\newline #\return #\tab #\space) #t)
        (else #f)))

    (define (comment? u8)
      (char=? #\# (integer->char u8)))

    (define (newline? u8)
      (case (integer->char u8)
        ((#\newline #\return) #t)
        (else #f)))

    (define (read-comment in)
      (let ((u8 (peek-u8 in)))
        (cond ((eof-object? u8) (eof-object))
              ((newline? u8)
               (read-u8 in)
               (read-whitespaces in))
              (else
               (read-u8 in)
               (read-comment in)))))

    (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)
         (else #f))))

    (define (read-whitespaces in)
      (let ((u8 (peek-u8 in)))
        (cond ((eof-object? u8) (eof-object))
              ((whitespace? u8)
               (read-u8 in)
               (read-whitespaces in))
              ((comment? u8)
               (read-u8 in)
               (read-comment in))
              (else #t))))

    (define (read-number in)
      (call-with-current-continuation
       (lambda (return)
         (let ((u8 (peek-u8 in)))
           (when (or (eof-object? u8)
                     (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)))))))))