summaryrefslogtreecommitdiffstats
path: root/pnm.scm
diff options
context:
space:
mode:
authorThomas Bushnell, BSG <tb@debian.org>2005-11-02 14:55:21 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:32 -0800
commit34c54a22ff7818bb8b38ef4d9c87dbbcb221ba73 (patch)
tree1189d06a81277bcf8539b0260a69a19f6038effb /pnm.scm
parent611b3db17894e5fdc0db3d49eaf6743d27b44233 (diff)
parent5145dd3aa0c02c9fc496d1432fc4410674206e1d (diff)
downloadslib-34c54a22ff7818bb8b38ef4d9c87dbbcb221ba73.tar.gz
slib-34c54a22ff7818bb8b38ef4d9c87dbbcb221ba73.zip
Import Debian changes 3a2-1debian/3a2-1
slib (3a2-1) unstable; urgency=low * New upstream release. * Acknowledge NMU. (Closes: #281809) * Makefile: Don't hack Makefile; use rules instead. * debian/rules: Set on make invocations: prefix, htmldir, TEXI2HTML. * debian/rules (clean): Clean more stuff here. * Makefile: Comment out old rule for $(htmldir)slib_toc.html. Instead, specify directly that the texi2html invocation produces that file. * debian/rules (binary-indep): Find web files in slib subdir. * debian/control (Build-Depends-Indep): Go back to using scm.
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))