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