diff options
Diffstat (limited to 'pnm.scm')
| -rw-r--r-- | pnm.scm | 88 |
1 files changed, 65 insertions, 23 deletions
@@ -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)) |