diff options
Diffstat (limited to 'pnm.scm')
| -rw-r--r-- | pnm.scm | 213 |
1 files changed, 213 insertions, 0 deletions
@@ -0,0 +1,213 @@ +;;; "pnm.scm" Read PNM image files. +; Copyright 2000 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'scanf) +(require 'printf) +(require 'array) +(require 'array-for-each) +(require 'byte) +(require 'line-i/o) + +(define (pnm:read+integer port) + (define uint #f) + (do ((chr (peek-char port) (peek-char port))) + ((not (and (char? chr) (or (char-whitespace? chr) (eqv? #\# chr))))) + (if (eqv? #\# chr) + (read-line port) + (read-char port))) + (if (eof-object? (peek-char port)) + (peek-char port) + (and (eqv? 1 (fscanf port " %u" uint)) uint))) + +(define (pnm:type-dimensions port) + (if (input-port? port) + (let* ((c1 (read-char port)) + (c2 (read-char port))) + (cond + ((and (eqv? #\P c1) + (char? c2) + (char-numeric? c2) + (char-whitespace? (peek-char port))) + (let* ((format (string->symbol (string #\p c2))) + (width (pnm:read+integer port)) + (height (pnm:read+integer port)) + (ret + (case format + ((p1) (list 'pbm width height 1)) + ((p4) (list 'pbm-raw width height 1)) + ((p2) (list 'pgm width height (pnm:read+integer port))) + ((p5) (list 'pgm-raw width height (pnm:read+integer port))) + ((p3) (list 'ppm width height (pnm:read+integer port))) + ((p6) (list 'ppm-raw width height (pnm:read+integer port))) + (else #f)))) + (and (char-whitespace? (read-char port)) ret))) + (else #f))) + (call-with-input-file port pnm:type-dimensions))) + +(define (pnm:read-binary! array port) + (array-map! array (lambda () (read-byte port)))) + +(define (pnm:image-file->array path . array) + (set! array (and (not (null? array)) (car array))) + (call-with-input-file path + (lambda (port) + (apply (lambda (type width height max-pixel) + (define (read-binary) + (pnm:read-binary! array port) + (if (eof-object? (peek-char port)) array + (slib:error type 'not 'at 'file 'end))) + (define (read-text) + (array-map! array (lambda () (pnm:read+integer port))) + (if (eof-object? (pnm:read+integer port)) array + (slib:error type 'not 'at 'file 'end))) + (define (read-pbm) + (array-map! array (lambda () (eqv? 1 (pnm:read+integer port)))) + (if (eof-object? (pnm:read+integer port)) array + (slib:error type 'not 'at 'file 'end))) + (case type + ((pbm) + (or array + (set! array (make-array #t height width))) + (read-pbm)) + ((pgm) + (or array + (set! array (make-array max-pixel height width))) + (read-text)) + ((ppm) + (or array + (set! array (make-array max-pixel height width 3))) + (read-text)) + ((pbm-raw) + (or array + (set! array (make-array #t height (quotient width 8)))) + (read-binary)) + ((pgm-raw) + (or array + (set! array (make-array max-pixel height width))) + (read-binary)) + ((ppm-raw) + (or array + (set! array (make-array max-pixel height width 3))) + (read-binary)))) + (pnm:type-dimensions port))))) + +(define (pnm:image-file->uniform-array path . array) + (fluid-let ((make-array make-uniform-array) + (pnm:read-binary! + (lambda (ra port) + (if (array? ra #t) + (error 'pnm:image-file->array + "pbm-raw support unimplemented") + (let ((bytes (apply make-uniform-array #\a + (array-dimensions ra)))) + (uniform-array-read! bytes port) + (array-map! ra char->integer bytes)))))) + (apply pnm:image-file->array path array))) + +;; ARRAY is required to be zero-based. +(define (pnm:array-write type array maxval port) + (define (write-header type height width maxval) + (let ((magic + (case type + ((pbm) "P1") + ((pgm) "P2") + ((ppm) "P3") + ((pbm-raw) "P4") + ((pgm-raw) "P5") + ((ppm-raw) "P6") + (else (error 'pnm:array-write "bad type" type))))) + (fprintf port "%s\n%d %d" magic width height) + (if maxval (fprintf port "\n%d" maxval)))) + (define (write-pixels type array maxval) + (let* ((shp (array-dimensions array)) + (height (car shp)) + (width (cadr shp))) + (case type + ((pbm-raw) + (newline port) + (if (array? array #t) + (uniform-array-write array port) + (error 'pnm:array-write "expected bit-array" array))) + ((pgm-raw ppm-raw) + (newline port) +;;; (let ((bytes (apply make-uniform-array #\a shp))) +;;; (array-map! bytes integer->char array) +;;; (uniform-array-write bytes port)) + (uniform-array-write array port)) + ((pbm) + (do ((i 0 (+ i 1))) + ((>= i height)) + (do ((j 0 (+ j 1))) + ((>= j width)) + (display (if (zero? (remainder j 35)) #\newline #\space) port) + (display (if (array-ref array i j) #\1 #\0) port))) + (newline port)) + ((pgm) + (do ((i 0 (+ i 1))) + ((>= i height)) + (do ((j 0 (+ j 1))) + ((>= j width)) + (display (if (zero? (remainder j 17)) #\newline #\space) port) + (display (array-ref array i j) port))) + (newline port)) + ((ppm) + (do ((i 0 (+ i 1))) + ((>= i height)) + (do ((j 0 (+ j 1))) + ((>= j width)) + (display (if (zero? (remainder j 5)) #\newline " ") port) + (display (array-ref array i j 0) port) + (display #\space port) + (display (array-ref array i j 1) port) + (display #\space port) + (display (array-ref array i j 2) port))) + (newline port))))) + + (if (output-port? port) + (let ((rnk (array-rank array)) + (shp (array-dimensions array))) + (case type + ((pbm pbm-raw) + (or (and (eqv? 2 rnk) + (integer? (car shp)) + (integer? (cadr shp))) + (error 'pnm:array-write "bad shape" type array)) + (or (eqv? 1 maxval) + (error 'pnm:array-write "maxval supplied not 1" type)) + (write-header type (car shp) (cadr shp) #f) + (write-pixels type array 1)) + ((pgm pgm-raw) + (or (and (eqv? 2 rnk) + (integer? (car shp)) + (integer? (cadr shp))) + (error 'pnm:array-write "bad shape" type array)) + (write-header type (car shp) (cadr shp) maxval) + (write-pixels type array maxval)) + ((ppm ppm-raw) + (or (and (eqv? 3 rnk) + (integer? (car shp)) + (integer? (cadr shp)) + (eqv? 3 (caddr shp))) + (error 'pnm:array-write "bad shape" type array)) + (write-header type (car shp) (cadr shp) maxval) + (write-pixels type array maxval)) + (else (error 'pnm:array-write type 'unrecognized 'type)))) + (call-with-output-file port + (lambda (port) + (pnm:array-write type array maxval port))))) |