path: root/pnm/ppm.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 (pnm ppm)
  (export make-image
          image-width
          image-height
          image-maxval
          image-ref
          image-set!
          image-read
          image-write)
  (import (scheme base))
  (begin
    (define-record-type <ppm:image>
      (%make-image width height maxval data getter setter)
      image?
      (width image-width)
      (height image-height)
      (maxval image-maxval)
      (data image-data)
      (getter image-getter)
      (setter image-setter))

    (define (make-image width height maxval)
      (when (or (< maxval 0)
                (< 65536 maxval))
        (error "(pnm ppm) make-image: maxval is out of range"))
      (let ((data (make-bytevector (* width
                                      height
                                      (if (< maxval 256)
                                          3
                                          6))
                                   0)))
        (make-image* width height maxval data)))

    (define (make-image* width height maxval data)
      (when (or (< maxval 0)
                (< 65536 maxval))
        (error "(pnm ppm) make-image: maxval is out of range"))
      (if (< maxval 256)
          (let* ((w*3 (* width 3)))
            (define (xy->idx x y) (+ (* 3 x) (* y w*3)))
            (define (getter x y)
              (let ((idx (xy->idx x y)))
                (values (bytevector-u8-ref data idx)
                        (bytevector-u8-ref data (+ idx 1))
                        (bytevector-u8-ref data (+ idx 2)))))
            (define (setter x y r g b)
              (let ((idx (xy->idx x y)))
                (bytevector-u8-set! data idx r)
                (bytevector-u8-set! data (+ idx 1) g)
                (bytevector-u8-set! data (+ idx 2) b)))
            (%make-image width height maxval data getter setter))
          (let* ((w*6 (* width 6)))
            (define (xy->idx x y) (+ (* 6 x) (* y w*6)))
            (define (getter x y)
              (let ((idx (xy->idx x y)))
                (values (combine-values (bytevector-u8-ref data idx)
                                        (bytevector-u8-ref data (+ idx 1)))
                        (combine-values (bytevector-u8-ref data (+ idx 2))
                                        (bytevector-u8-ref data (+ idx 3)))
                        (combine-values (bytevector-u8-ref data (+ idx 4))
                                        (bytevector-u8-ref data (+ idx 5))))))
            (define (setter x y r g b)
              (let ((idx (xy->idx x y)))
                (let-values (((r1 r2) (split-value r))
                             ((g1 g2) (split-value g))
                             ((b1 b2) (split-value b)))
                  (bytevector-u8-set! data idx r1)
                  (bytevector-u8-set! data (+ idx 1) r2)
                  (bytevector-u8-set! data (+ idx 2) g1)
                  (bytevector-u8-set! data (+ idx 3) g2)
                  (bytevector-u8-set! data (+ idx 4) b1)
                  (bytevector-u8-set! data (+ idx 5) b2))))
            (%make-image width height maxval data getter setter))))

    (define (split-value v)
      (values (modulo (quotient v 256) 256)
              (modulo v 256)))

    (define (combine-values l r)
      (+ (* 256 l) r))
    
    (define (image-set! image x y r g b)
      ((image-setter image) x y r g b))

    (define (image-ref image x y)
      ((image-getter image) x y))
    
    (define (image-read in)
      (define (unexpected-eof-error)
        (error "(pnm ppm) image-read: Unexpected end of file"))
      (define (unexpected-char-error)
        (error "(pnm ppm) image-read: Unexpected character"))
      (define (read-u8*)
        (let ((u8 (read-u8 in)))
          (when (eof-object? u8)
            (unexpected-eof-error))
          u8))
      (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 ((u8-1 (read-u8*))
            (u8-2 (read-u8*)))
        (unless (p6? u8-1 u8-2)
          (error "(pnm ppm) image-read: No expected magic number (expected P6)"))
        (read-whitespaces*)
        (let ((width (read-number in)))
          (read-whitespaces*)
          (let ((height (read-number in)))
            (read-whitespaces*)
            (let ((maxval (read-number in)))
              (unless (whitespace? (read-u8*))
                (unexpected-char-error))
              (make-image* width height maxval
                           (if (< maxval 256)
                               (read-bytevector (* 3 width height) in)
                               (read-bytevector (* 6 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 (p6? u8-1 u8-2)
      (and (= (char->integer #\P) u8-1)
           (= (char->integer #\6) u8-2)))

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

    (define (image-write image out)
      (define (write-string-u8 str)
        (string-for-each (lambda (c) (write-u8 (char->integer c) out))
                         str))
      (write-string-u8 "P6\n")
      (write-string-u8 (number->string (image-width image)))
      (write-string-u8 "\n")
      (write-string-u8 (number->string (image-height image)))
      (write-string-u8 "\n")
      (write-string-u8 (number->string (image-maxval image)))
      (write-string-u8 "\n")
      (write-bytevector (image-data image) out))))