summaryrefslogtreecommitdiffstats
path: root/pnm.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /pnm.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'pnm.scm')
-rw-r--r--pnm.scm277
1 files changed, 179 insertions, 98 deletions
diff --git a/pnm.scm b/pnm.scm
index c4a0e66..96961f7 100644
--- a/pnm.scm
+++ b/pnm.scm
@@ -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)))))