summaryrefslogtreecommitdiffstats
path: root/pnm.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commit87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (patch)
tree1eb4f87abd38bea56e08335d939e8171d5e7bfc7 /pnm.scm
parentbd9733926076885e3417b74de76e4c9c7bc56254 (diff)
downloadslib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.tar.gz
slib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.zip
Import Upstream version 2d2upstream/2d2
Diffstat (limited to 'pnm.scm')
-rw-r--r--pnm.scm213
1 files changed, 213 insertions, 0 deletions
diff --git a/pnm.scm b/pnm.scm
new file mode 100644
index 0000000..c4a0e66
--- /dev/null
+++ b/pnm.scm
@@ -0,0 +1,213 @@
+;;; "pnm.scm" Read PNM image files.
+; Copyright 2000 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
+;granted, subject to the following restrictions and understandings.
+;
+;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
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'scanf)
+(require 'printf)
+(require 'array)
+(require 'array-for-each)
+(require 'byte)
+(require 'line-i/o)
+
+(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)))
+
+(define (pnm:type-dimensions port)
+ (if (input-port? port)
+ (let* ((c1 (read-char port))
+ (c2 (read-char port)))
+ (cond
+ ((and (eqv? #\P c1)
+ (char? c2)
+ (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))
+ (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)))
+ (else #f))))
+ (and (char-whitespace? (read-char port)) ret)))
+ (else #f)))
+ (call-with-input-file port pnm:type-dimensions)))
+
+(define (pnm:read-binary! array port)
+ (array-map! array (lambda () (read-byte port))))
+
+(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)))
+
+;; ARRAY is required to be zero-based.
+(define (pnm:array-write type array maxval port)
+ (define (write-header type height width maxval)
+ (let ((magic
+ (case type
+ ((pbm) "P1")
+ ((pgm) "P2")
+ ((ppm) "P3")
+ ((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))))
+ (define (write-pixels type array maxval)
+ (let* ((shp (array-dimensions array))
+ (height (car shp))
+ (width (cadr shp)))
+ (case type
+ ((pbm-raw)
+ (newline port)
+ (if (array? array #t)
+ (uniform-array-write array port)
+ (error 'pnm:array-write "expected bit-array" array)))
+ ((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))
+ ((pbm)
+ (do ((i 0 (+ i 1)))
+ ((>= i height))
+ (do ((j 0 (+ j 1)))
+ ((>= j width))
+ (display (if (zero? (remainder j 35)) #\newline #\space) port)
+ (display (if (array-ref array i j) #\1 #\0) port)))
+ (newline port))
+ ((pgm)
+ (do ((i 0 (+ i 1)))
+ ((>= i height))
+ (do ((j 0 (+ j 1)))
+ ((>= j width))
+ (display (if (zero? (remainder j 17)) #\newline #\space) port)
+ (display (array-ref array i j) port)))
+ (newline port))
+ ((ppm)
+ (do ((i 0 (+ i 1)))
+ ((>= i height))
+ (do ((j 0 (+ j 1)))
+ ((>= j width))
+ (display (if (zero? (remainder j 5)) #\newline " ") port)
+ (display (array-ref array i j 0) port)
+ (display #\space port)
+ (display (array-ref array i j 1) port)
+ (display #\space port)
+ (display (array-ref array i j 2) port)))
+ (newline port)))))
+
+ (if (output-port? port)
+ (let ((rnk (array-rank array))
+ (shp (array-dimensions array)))
+ (case type
+ ((pbm pbm-raw)
+ (or (and (eqv? 2 rnk)
+ (integer? (car shp))
+ (integer? (cadr shp)))
+ (error 'pnm:array-write "bad shape" type array))
+ (or (eqv? 1 maxval)
+ (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))
+ (write-header type (car shp) (cadr shp) maxval)
+ (write-pixels type array maxval))
+ ((ppm ppm-raw)
+ (or (and (eqv? 3 rnk)
+ (integer? (car shp))
+ (integer? (cadr shp))
+ (eqv? 3 (caddr shp)))
+ (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)))))