diff options
Diffstat (limited to 'pnm.scm')
| -rw-r--r-- | pnm.scm | 277 |
1 files changed, 179 insertions, 98 deletions
@@ -1,5 +1,5 @@ -;;; "pnm.scm" Read PNM image files. -; Copyright 2000 Aubrey Jaffer +;;; "pnm.scm" Read and write PNM image files. +; Copyright 2000, 2003 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 @@ -8,7 +8,7 @@ ;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 +;2. I have made no warranty 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. ; @@ -17,24 +17,63 @@ ;promotional, or sales literature without prior written consent in ;each case. -(require 'scanf) -(require 'printf) (require 'array) +(require 'subarray) (require 'array-for-each) -(require 'byte) (require 'line-i/o) +(require 'logical) +(require 'byte) -(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))) +;;@code{(require 'pnm)} +;;@ftindex pnm +(define (pnm:read-pbm-char port) + (let loop ((chr (read-char port))) + (case chr + ((#\0) #f) + ((#\1) #t) + ((#\#) + (read-line port) + (loop (read-char port))) + (else + (if (char-whitespace? chr) + (loop (read-char port)) + (slib:error chr 'unexpected 'character)))))) + +;;@args path +;;The string @1 must name a @dfn{portable bitmap graphics} file. +;;@0 returns a list of 4 items: +;;@enumerate +;;@item +;;A symbol describing the type of the file named by @1. +;;@item +;;The image width in pixels. +;;@item +;;The image height in pixels. +;;@item +;;The maximum value of pixels assume in the file. +;;@end enumerate +;; +;;The current set of file-type symbols is: +;;@table @asis +;;@item pbm +;;@itemx pbm-raw +;;@cindex pbm +;;@cindex pbm-raw +;;Black-and-White image; pixel values are 0 or 1. +;;@item pgm +;;@itemx pgm-raw +;;@cindex pgm +;;@cindex pgm-raw +;;Gray (monochrome) image; pixel values are from 0 to @var{maxval} +;;specified in file header. +;;@item ppm +;;@itemx ppm-raw +;;@cindex ppm +;;@cindex ppm-raw +;;RGB (full color) image; red, green, and blue interleaved pixel values +;;are from 0 to @var{maxval} +;;@end table (define (pnm:type-dimensions port) (if (input-port? port) (let* ((c1 (read-char port)) @@ -45,83 +84,122 @@ (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)) + (width (read port)) + (height (read 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))) + ((p2) (list 'pgm width height (read port))) + ((p5) (list 'pgm-raw width height (read port))) + ((p3) (list 'ppm width height (read port))) + ((p6) (list 'ppm-raw width height (read port))) (else #f)))) (and (char-whitespace? (read-char port)) ret))) (else #f))) - (call-with-input-file port pnm:type-dimensions))) + (call-with-open-ports (open-file port 'rb) pnm:type-dimensions))) -(define (pnm:read-binary! array port) - (array-map! array (lambda () (read-byte port)))) +(define (pnm:read-bit-vector! array port) + (define dims (array-dimensions array)) + (let* ((height (car (array-dimensions array))) + (width (cadr (array-dimensions array))) + (wid8 (logand -8 width))) + (do ((jdx 0 (+ 1 jdx))) + ((>= jdx height)) + (let ((row (subarray array jdx))) + (do ((idx 0 (+ 8 idx))) + ((>= idx wid8) + (if (< idx width) + (let ((byt (read-byte port))) + (do ((idx idx (+ 1 idx)) + (bdx 7 (+ -1 bdx))) + ((>= idx width)) + (array-set! row (logbit? bdx byt) idx))))) + (let ((byt (read-byte port))) + (array-set! row (logbit? 7 byt) (+ 0 idx)) + (array-set! row (logbit? 6 byt) (+ 1 idx)) + (array-set! row (logbit? 5 byt) (+ 2 idx)) + (array-set! row (logbit? 4 byt) (+ 3 idx)) + (array-set! row (logbit? 3 byt) (+ 4 idx)) + (array-set! row (logbit? 2 byt) (+ 5 idx)) + (array-set! row (logbit? 1 byt) (+ 6 idx)) + (array-set! row (logbit? 0 byt) (+ 7 idx))))))) + (if (eof-object? (peek-char port)) + array + (do ((chr (read-char port) (read-char port)) + (cnt 0 (+ 1 cnt))) + ((eof-object? chr) (slib:error cnt 'bytes 'remain 'in port))))) +;;@args path array +;; +;;Reads the @dfn{portable bitmap graphics} file named by @var{path} into +;;@var{array}. @var{array} must be the correct size and type for +;;@var{path}. @var{array} is returned. +;; +;;@args path +;; +;;@code{pnm:image-file->array} creates and returns an array with the +;;@dfn{portable bitmap graphics} file named by @var{path} read into it. (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))) + (call-with-open-ports + (open-file path 'rb) + (lambda (port) + (apply (lambda (type width height max-pixel) + (define (read-binary) + (array-map! array (lambda () (read-byte port))) + (if (eof-object? (peek-char port)) array + (slib:error type 'not 'at 'file 'end))) + (define (read-text) + (array-map! array (lambda () (read port))) + (if (not (eof-object? (read port))) + (slib:warn type 'not 'at 'file 'end)) + array) + (define (read-pbm) + (array-map! array (lambda () (pnm:read-pbm-char port))) + (if (not (eof-object? (read port))) + (slib:warn type 'not 'at 'file 'end)) + array) + (case type + ((pbm) + (or array + (set! array (create-array (At1) height width))) + (read-pbm)) + ((pgm) + (or array + (set! array (create-array + ((if (<= max-pixel 256) Au8 Au16)) + height width))) + (read-text)) + ((ppm) + (or array + (set! array (create-array + ((if (<= max-pixel 256) Au8 Au16)) + height width 3))) + (read-text)) + ((pbm-raw) + (or array + (set! array (create-array (At1) height width))) + (pnm:read-bit-vector! array port)) + ((pgm-raw) + (or array + (set! array (create-array (Au8) height width))) + (read-binary)) + ((ppm-raw) + (or array + (set! array (create-array (Au8) height width 3))) + (read-binary)))) + (pnm:type-dimensions port))))) ;; ARRAY is required to be zero-based. -(define (pnm:array-write type array maxval port) + +;;@args type array maxval path comment @dots{} +;; +;;Writes the contents of @2 to a @1 image file named @4. The file +;;will have pixel values between 0 and @3, which must be compatible +;;with @1. For @samp{pbm} files, @3 must be @samp{1}. +;;@var{comment}s are included in the file header. +(define (pnm:array-write type array maxval port . comments) (define (write-header type height width maxval) (let ((magic (case type @@ -131,9 +209,13 @@ ((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)))) + (else (slib:error 'pnm:array-write "bad type" type))))) + (display magic port) (newline port) + (for-each (lambda (str) + (display "#" port) (display str port) (newline port)) + comments) + (display width port) (display " " port) (display height port) + (cond (maxval (newline port) (display maxval port))))) (define (write-pixels type array maxval) (let* ((shp (array-dimensions array)) (height (car shp)) @@ -141,15 +223,14 @@ (case type ((pbm-raw) (newline port) - (if (array? array #t) - (uniform-array-write array port) - (error 'pnm:array-write "expected bit-array" array))) + (if (not (boolean? (array-ref array 0 0))) + (slib:error 'pnm:array-write "expected bit-array" array)) + (uniform-array-write array port)) ((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)) + ;;(uniform-array-write array port) + (array-for-each (lambda (byt) (write-byte byt port)) array) + ) ((pbm) (do ((i 0 (+ i 1))) ((>= i height)) @@ -187,16 +268,16 @@ (or (and (eqv? 2 rnk) (integer? (car shp)) (integer? (cadr shp))) - (error 'pnm:array-write "bad shape" type array)) + (slib:error 'pnm:array-write "bad shape" type array)) (or (eqv? 1 maxval) - (error 'pnm:array-write "maxval supplied not 1" type)) + (slib: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)) + (slib:error 'pnm:array-write "bad shape" type array)) (write-header type (car shp) (cadr shp) maxval) (write-pixels type array maxval)) ((ppm ppm-raw) @@ -204,10 +285,10 @@ (integer? (car shp)) (integer? (cadr shp)) (eqv? 3 (caddr shp))) - (error 'pnm:array-write "bad shape" type array)) + (slib: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))))) + (else (slib:error 'pnm:array-write type 'unrecognized 'type)))) + (call-with-open-ports + (open-file port 'wb) + (lambda (port) (pnm:array-write type array maxval port))))) |