aboutsummaryrefslogtreecommitdiffstats
path: root/pnm.scm
blob: 2bfa4aea85e715ac7dcd4fd9400793acd10e54c8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
;;; "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
;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 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.
;
;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 'array)
(require 'subarray)
(require 'array-for-each)
(require 'line-i/o)
(require 'logical)
(require 'byte)

;;@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))))))

;; 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:
;;@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))
	     (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-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 (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: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)))
	 (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-open-ports
   (open-file path 'rb)
   (lambda (port)
     (apply (lambda (type width height max-pixel)
	      (define (read-binary)
		(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)
		(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 (make-array (A:bool) height width)))
		 (read-pbm))
		((pgm)
		 (or array
		     (set! array (make-array
				  ((if (<= max-pixel 256) A:fixN8b A:fixN16b))
				  height width)))
		 (read-text))
		((ppm)
		 (or array
		     (set! array (make-array
				  ((if (<= max-pixel 256) A:fixN8b A:fixN16b))
				  height width 3)))
		 (read-text))
		((pbm-raw)
		 (or array
		     (set! array (make-array (A:bool) height width)))
		 (pnm:read-bits! array port))
		((pgm-raw)
		 (or array
		     (set! array (make-array (A:fixN8b) height width)))
		 (read-binary))
		((ppm-raw)
		 (or array
		     (set! array (make-array (A:fixN8b) height width 3)))
		 (read-binary))))
	    (pnm:type-dimensions 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
	     ((pbm) "P1")
	     ((pgm) "P2")
	     ((ppm) "P3")
	     ((pbm-raw) "P4")
	     ((pgm-raw) "P5")
	     ((ppm-raw) "P6")
	     (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))
	   (width (cadr shp)))
      (case type
	((pbm-raw)
	 (newline port)
	 (if (not (boolean? (array-ref array 0 0)))
	     (slib:error 'pnm:array-write "expected bit-array" array))
	 (pnm:write-bits array port))
	((pgm-raw ppm-raw)
	 (newline port)
	 (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))
	   (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)))
	       (slib:error 'pnm:array-write "bad shape" type array))
	   (or (eqv? 1 maxval)
	       (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)))
	       (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)
	   (or (and (eqv? 3 rnk)
		    (integer? (car shp))
		    (integer? (cadr shp))
		    (eqv? 3 (caddr shp)))
	       (slib:error 'pnm:array-write "bad shape" type array))
	   (write-header type (car shp) (cadr shp) maxval)
	   (write-pixels type array maxval))
	  (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)))))