;;;;;;;;;;;;;;;;;;;;
;;;; PGM.SCM
;;;;
;;;; The two most important procedures in this file are
;;;;    (pgm-file->image fname)
;;;;    (image->pgm-file img fname)
;;;; These procedures allow for saving and loading of image files from ASCII
;;;; PGM files.  For a description of the PGM format, please refer to 
;;;;    http://netpbm.sourceforge.net/doc/pgm.html
;;;; Our Scheme image is a stream of stream of gray pixel values.  The 
;;;; stream-car parts of the image are image rows.  Each image row is a stream
;;;; whose stream-car parts are the grayscale intensity values of the image,
;;;; where 0 is black and 1.0 is white.  Values outside [0,1] are invalid.
;;;; Using list-like notation, a image might look like
;;;;   ((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0   0 0   0 0)
;;;;    (0 1 0 1 0 1 1 1 0 1 0 0 0 1 0 0 0 0.5 1 0.5 0)
;;;;    (0 1 0 1 0 1 0 0 0 1 0 0 0 1 0 0 0   1 0   1 0)
;;;;    (0 1 1 1 0 1 1 0 0 1 0 0 0 1 0 0 0   1 0   1 0)
;;;;    (0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0   1 0   1 0)
;;;;    (0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 0.5 1 0.5 0)
;;;;    (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0   0 0   0 0))


;;; Takes an input-port f and returns a list of strings representing 
;;; the tokens in f.  An ASCII PNM-style file consists of numbers and
;;; (some) special character strings separated by whitespace.  "#" 
;;; delimits end-of-line comments.
;;;
;;; Note: the implementation here returns a stream of tokens so that the user
;;; may choose to stream the image in as needed instead of requiring that it
;;; all be loaded immediately.
(define (tokenize-pnm f)
  (define *whitespace* '(#\Return #\Linefeed #\Tab #\Space))
  ;; Main loop for reading in tokens
  ;; We store the characters of the current token in a list in reverse order.
  ;; This allows us to make simple constant-time prepends.  When we are done,
  ;; we can use the linear-time reverse and list->string to create our final
  ;; string.  Had we modified the else clause to the cond below to do something
  ;; like (set! (append! current-token (list c))), we would end up with a 
  ;; quadratic-time algorithm. 
  (let loop ((current-token-reversed '()))
    ;; Procedure to regulate returning new tokens when recursing.  It creates
    ;; a new stream cons cell only when we actually have a token formed, then
    ;; it recurses to produce the next loop iteration (starting with a new
    ;; empty token).
    (define (recurse current-token-reversed)
      (if (null? current-token-reversed)
          (loop nil)
          (cons-stream (list->string 
                        (reverse current-token-reversed)) 
                       (loop nil))))
    ;; Process each new character
    (let ((c (input-port/read-char f)))
      (cond
        ; Regular whitespace: merge in the current token, if needed
        ((memq c *whitespace*) 
         (recurse current-token-reversed))
        
        ; Comment: slurp up all characters until (and including)
        ; the end of line.
        ((eq? c #\#)
         ; Slurp
         (let comment-slurper ((c c))
           (if (not (eq? c #\Linefeed)) 
               (comment-slurper (input-port/read-char f))))
         ; spit out any current token
         (recurse current-token-reversed))
         
        ; End of file: tack on the final token
        ((eof-object? c) 
         (if (null? current-token-reversed)
             nil
             (cons-stream (list->string (reverse current-token-reversed)) nil)))
         
        ; Else: accumulate characters in the current token
        (else 
         (loop (cons c current-token-reversed)))))))
         
;;; Reads a PGM file into a stream format, where the stream-car
;;; part of the stream is an image row.  Each image row is a
;;; stream where its stream-car part is a pixel gray value, from
;;; 0 to 1.
;;;
;;; http://netpbm.sourceforge.net/doc/pgm.html
(define (pgm-file->image fname)
  (let* ((tokens       (tokenize-pnm (open-input-file fname)))
         (magic-number (stream-ref tokens 0))
         (width        (string->number (stream-ref tokens 1)))
         (height       (string->number (stream-ref tokens 2)))
         (max-value    (string->number (stream-ref tokens 3)))
         (pixel-data   (stream-tail tokens 4)))
         
    ;; Takes a string token representing a gray value and converts it to
    ;; a flonum between 0 and 1.0.
    (define (token-to-gray-value token)
      (/ (string->number token) max-value))
         
    ;; Produces a stream for a row of pixel data
    (define (col-iter pixel-data cols-left)
      (if (<= cols-left 0)
          '()
          (cons-stream (token-to-gray-value (stream-car pixel-data))
                       (col-iter (stream-cdr pixel-data)
                                 (- cols-left 1)))))
                                 
    ;; Produces a stream for a image of pixel data.
    (define (row-iter pixel-data rows-left)
      (if (<= rows-left 0)
          '()
          (cons-stream (col-iter pixel-data width)
                       (row-iter (stream-tail pixel-data width)
                                 (- rows-left 1)))))
         
    ;; Make sure we have an actual PPM file
    (assert-equal magic-number "P2")
    ;; We've omitted the following test since stream-length would force 
    ;; the file to be read in immediately.
    ;(assert= (stream-length tokens) (+ 4 (* width height)))
    
    ;; Build up the nested streams
    (row-iter pixel-data height)))
           
;;; Takes an image, e.g. stream< stream< flonum > > and writes it out
;;; as a PGM file.  The values of the nested stream should be between 0
;;; and 1.0.
(define (image->pgm-file img fname)
  ;; Spit out all rows of image data
  (define (write-rows img f)
    (if (not (null? img)) 
        (begin
          (write-cols (stream-car img) f)
          (write-rows (stream-cdr img) f))))
  
  ;; Spit out the columns in a single image row
  (define (write-cols row f)
    (if (null? row)
        (write-string "\n" f)
        (begin
          (write-string (number->string 
                         (inexact->exact (floor (* (stream-car row) 255.)))) f) 
          (write-string " " f)
          (write-cols (stream-cdr row) f))))               
  
  (let ((f      (open-output-file fname))
        (height (stream-length img))
        (width  (stream-length (stream-car img))))
    ;; Write out the PGM header
    (write-string "P2\n" f)
    (write-string 
     (apply string-append
            `(,(number->string width) " " ,(number->string height) "\n255\n")) 
     f)
    ;; Write out the data
    (write-rows img f)
    ;; Close the file
    (close-port f)))