;;; 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
          pnm-parse-error?)
  (import (scheme base)
          (scheme write)
          (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-pixel-write! 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-writer 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-writer 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 "(pnm read) image-read: Not supported magic number")))
    (define (unexpected-eof-error)
      (raise (pnm-parse-error "(pnm read) image-read: Unexpected end of file")))
    (define (unexpected-character-error)
      (raise (pnm-parse-error "(pnm read) 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)))))))