summaryrefslogtreecommitdiffstats
path: root/pnm.scm
diff options
context:
space:
mode:
Diffstat (limited to 'pnm.scm')
-rw-r--r--pnm.scm88
1 files changed, 65 insertions, 23 deletions
diff --git a/pnm.scm b/pnm.scm
index 96961f7..2bfa4ae 100644
--- a/pnm.scm
+++ b/pnm.scm
@@ -40,6 +40,21 @@
(loop (read-char port))
(slib:error chr 'unexpected 'character))))))
+;; Comments beginning with "#" and ending with newline are permitted in
+;; the header of a pnm file.
+(define (pnm:read-value port)
+ (let loop ()
+ (let ((chr (peek-char port)))
+ (cond ((eof-object? chr)
+ (slib:error 'unexpected 'eof port))
+ ((char-whitespace? chr)
+ (read-char port)
+ (loop))
+ ((char=? chr #\#)
+ (read-line port)
+ (loop))
+ (else (read port))))))
+
;;@args path
;;The string @1 must name a @dfn{portable bitmap graphics} file.
;;@0 returns a list of 4 items:
@@ -84,22 +99,44 @@
(char-numeric? c2)
(char-whitespace? (peek-char port)))
(let* ((format (string->symbol (string #\p c2)))
- (width (read port))
- (height (read port))
+ (width (pnm:read-value port))
+ (height (pnm:read-value port))
(ret
(case format
((p1) (list 'pbm width height 1))
((p4) (list 'pbm-raw width height 1))
- ((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)))
+ ((p2) (list 'pgm width height (pnm:read-value port)))
+ ((p5) (list 'pgm-raw width height (pnm:read-value port)))
+ ((p3) (list 'ppm width height (pnm:read-value port)))
+ ((p6) (list 'ppm-raw width height (pnm:read-value port)))
(else #f))))
(and (char-whitespace? (read-char port)) ret)))
(else #f)))
(call-with-open-ports (open-file port 'rb) pnm:type-dimensions)))
-(define (pnm:read-bit-vector! array port)
+(define (pnm:write-bits 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)
+ (do ((idx idx (+ 1 idx))
+ (bdx 7 (+ -1 bdx))
+ (bts 0 (+ bts (ash (if (array-ref row idx) 1 0) bdx))))
+ ((>= idx width)
+ (write-byte bts port)))))
+ (do ((idx idx (+ 1 idx))
+ (bdx 7 (+ -1 bdx))
+ (bts 0 (+ bts bts (if (array-ref row idx) 1 0))))
+ ((negative? bdx)
+ (write-byte bts port))))))))
+
+(define (pnm:read-bits! array port)
(define dims (array-dimensions array))
(let* ((height (car (array-dimensions array)))
(width (cadr (array-dimensions array)))
@@ -147,7 +184,11 @@
(lambda (port)
(apply (lambda (type width height max-pixel)
(define (read-binary)
- (array-map! array (lambda () (read-byte port)))
+ (array-map! array
+ (if (<= max-pixel 256)
+ (lambda () (read-byte port))
+ (lambda () (define hib (read-byte port))
+ (+ (* 256 hib) (read-byte port)))))
(if (eof-object? (peek-char port)) array
(slib:error type 'not 'at 'file 'end)))
(define (read-text)
@@ -163,36 +204,34 @@
(case type
((pbm)
(or array
- (set! array (create-array (At1) height width)))
+ (set! array (make-array (A:bool) height width)))
(read-pbm))
((pgm)
(or array
- (set! array (create-array
- ((if (<= max-pixel 256) Au8 Au16))
+ (set! array (make-array
+ ((if (<= max-pixel 256) A:fixN8b A:fixN16b))
height width)))
(read-text))
((ppm)
(or array
- (set! array (create-array
- ((if (<= max-pixel 256) Au8 Au16))
+ (set! array (make-array
+ ((if (<= max-pixel 256) A:fixN8b A:fixN16b))
height width 3)))
(read-text))
((pbm-raw)
(or array
- (set! array (create-array (At1) height width)))
- (pnm:read-bit-vector! array port))
+ (set! array (make-array (A:bool) height width)))
+ (pnm:read-bits! array port))
((pgm-raw)
(or array
- (set! array (create-array (Au8) height width)))
+ (set! array (make-array (A:fixN8b) height width)))
(read-binary))
((ppm-raw)
(or array
- (set! array (create-array (Au8) height width 3)))
+ (set! array (make-array (A:fixN8b) height width 3)))
(read-binary))))
(pnm:type-dimensions port)))))
-;; ARRAY is required to be zero-based.
-
;;@args type array maxval path comment @dots{}
;;
;;Writes the contents of @2 to a @1 image file named @4. The file
@@ -225,12 +264,15 @@
(newline port)
(if (not (boolean? (array-ref array 0 0)))
(slib:error 'pnm:array-write "expected bit-array" array))
- (uniform-array-write array port))
+ (pnm:write-bits array port))
((pgm-raw ppm-raw)
(newline port)
- ;;(uniform-array-write array port)
- (array-for-each (lambda (byt) (write-byte byt port)) array)
- )
+ (array-for-each (if (<= maxval 256)
+ (lambda (byt) (write-byte byt port))
+ (lambda (byt)
+ (write-byte (quotient byt 256) port)
+ (write-byte (modulo byt 256) port)))
+ array))
((pbm)
(do ((i 0 (+ i 1)))
((>= i height))