1: 
(declare (fixnum))
2: 
3: 
;;; make-pgm takes two objects, an exact integer giving the maximum grey scale
4: 
;;; and an Array that returns exact integer values between 0 and greys inclusive.
5: 
6: 
(define pgm-greys car)
7: 
(define pgm-pixels cdr)
8: 
(define make-pgm cons)
9: 
10: 
(define (read-pgm file)
11: 
12: 
  (define (read-pgm-object port)
13: 
    (skip-white-space port)
14: 
    (let ((o (read port)))
15: 
      (read-char port) ; to skip the newline or next whitespace
16: 
      (if (eof-object? o)
17: 
	  (error "reached end of pgm file")
18: 
	  o)))
19: 
20: 
  (define (skip-to-end-of-line port)
21: 
    (let loop ((ch (read-char port)))
22: 
      (if (not (eq? ch #\newline))
23: 
	  (loop (read-char port)))))
24: 
25: 
  (define (white-space? ch)
26: 
    (case ch 
27: 
      ((#\newline #\space #\tab) #t)
28: 
      (else #f)))
29: 
30: 
  (define (skip-white-space port)
31: 
    (let ((ch (peek-char port)))
32: 
      (cond ((white-space? ch) (read-char port) (skip-white-space port))
33: 
	    ((eq? ch #\#) (skip-to-end-of-line port)(skip-white-space port))
34: 
	    (else #f))))
35: 
36: 
  (call-with-input-file
37: 
      file
38: 
    (lambda (port)
39: 
      (let* ((header (read-pgm-object port))
40: 
	     (columns (read-pgm-object port))
41: 
	     (rows (read-pgm-object port))
42: 
	     (greys (read-pgm-object port)))
43: 
	(make-pgm greys
44: 
		  (Array->Fixed-array generic-array-manipulators
45: 
				      (build-Array (build-Interval '#(0 0)
46: 
								   (vector rows columns))
47: 
						   (cond ((or (eq? header 'p5)                                     ;; pgm binary
48: 
							      (eq? header 'P5))
49: 
							  (if (< greys 256)
50: 
							      (lambda (i j)                                        ;; one byte/pixel
51: 
								(char->integer (read-char port)))
52: 
							      (lambda (i j)                                        ;; two bytes/pixel, little-endian
53: 
								(let* ((first-byte (char->integer (read-char port)))
54: 
								       (second-byte (char->integer (read-char port))))
55: 
								  (+ (##fixnum.arithmetic-shift-left second-byte 8) first-byte)))))
56: 
							 ((or (eq? header 'p2)                                     ;; pgm ascii
57: 
							      (eq? header 'P2))
58: 
							  (lambda (i j)
59: 
							    (read port)))
60: 
							 (else
61: 
							  (error "read-pgm: not a pgm file"))))))))))
62: 
63: 
(define (write-pgm pgm-data file #!optional force-ascii)
64: 
  (call-with-output-file
65: 
      file
66: 
    (lambda (port)
67: 
      (let* ((greys (pgm-greys pgm-data))
68: 
	     (pgm-array (pgm-pixels pgm-data))
69: 
	     (array-domain (Array-domain pgm-array))
70: 
	     (rows (Interval-upper-bound array-domain 0))
71: 
	     (columns (Interval-upper-bound array-domain 1)))
72: 
	(if force-ascii
73: 
	    (display "P2" port)
74: 
	    (display "P5" port))
75: 
	(newline port)
76: 
	(display columns port) (display " " port)
77: 
	(display rows port) (newline port)
78: 
	(display greys port) (newline port)
79: 
	(Array-for-each (if force-ascii
80: 
			    (let ((next-pixel-in-line 1))
81: 
			      (lambda (p)
82: 
				(write p port)
83: 
				(if (zero? (bitwise-and next-pixel-in-line 15))
84: 
				    (begin
85: 
				      (newline port)
86: 
				      (set! next-pixel-in-line 1))
87: 
				    (begin
88: 
				      (display " " port)
89: 
				      (set! next-pixel-in-line (+ 1 next-pixel-in-line))))))
90: 
			    (if (< greys 256)
91: 
				(lambda (p)
92: .02% 
				  (write-char (integer->char p) port))
93: 
				(lambda (p)
94: 
				  (write-char (integer->char (bitwise-and p 255)) port)
95: 
				  (write-char (integer->char (##fixnum.arithmetic-shift-right p 8)) port))))
96: 
			pgm-array)))))
97: 
98: 
;;; convert pgm files to and from f64 arrays
99: 
100: 
(define (pgm->f64 pgm)
101: 
  (Array-map f64-array-manipulators
102: 
	     (lambda (p)
103: 
	       (##flonum.<-fixnum p))
104: 
	     (pgm-pixels pgm)))
105: 
106: 
(define (f64->pgm greys array)
107: 
  (make-pgm greys
108: 
	    (Array-map generic-array-manipulators
109: 
		       (lambda (g)
110: .02% 
			 (max 0 (min greys (##flonum.->fixnum (FLOAT (round g))))))
111: 
		       array)))
112: 
113: 
(define (pgm-concatenate-left-to-right pgm . pgms)
114: 
115: 
  (define (every? proc l)
116: 
    (or (null? l)
117: 
	(and (proc (car l))
118: 
	     (every? proc (cdr l)))))
119: 
120: 
  (let ((array (pgm-pixels pgm))
121: 
	(arrays (map pgm-pixels pgms)))
122: 
    (let ((domain (Array-domain array))
123: 
	  (domains (map Array-domain arrays))
124: 
	  (grey-level (pgm-greys pgm))
125: 
	  (grey-levels (map pgm-greys pgms)))
126: 
      (if (and (every? (lambda (grey)
127: 
			 (= grey-level grey))
128: 
		       grey-levels)
129: 
	       (every? (lambda (d)
130: 
			 (= (Interval-upper-bound d 0)
131: 
			    (Interval-upper-bound domain 0)))
132: 
		       domains))
133: 
	  (let* ((arrays (cons array arrays))
134: 
		 (domains (cons domain domains))
135: 
		 (domain-columns (map (lambda (d)
136: 
					(Interval-upper-bound d 1))
137: 
				      domains))
138: 
		 (accessors (map Array-accessor arrays)))
139: 
	    (make-pgm grey-level
140: 
		      (build-Array (build-Interval '#(0 0)
141: 
						   (vector
142: 
						    (Interval-upper-bound domain 0)
143: 
						    (apply + domain-columns)))
144: 
				   (lambda (i j)
145: 
				     (let loop ((j j)
146: 
						(accessors accessors)
147: 
						(domain-columns domain-columns))
148: 
				       (if (< j (car domain-columns))
149: 
					   ((car accessors) i j)
150: 
					   (loop (- j (car domain-columns))
151: 
						 (cdr accessors)
152: 
						 (cdr domain-columns))))))))
153: 
	  (error "can't concatenate pgm files")))))
154: 
155: 
(define (pgm-concatenate-top-to-bottom pgm . pgms)
156: 
157: 
  (define (every? proc l)
158: 
    (or (null? l)
159: 
	(and (proc (car l))
160: 
	     (every? (cdr l)))))
161: 
162: 
  (let ((array (pgm-pixels pgm))
163: 
	(arrays (map pgm-pixels pgms)))
164: 
    (let ((domain (Array-domain array))
165: 
	  (domains (map Array-domain arrays))
166: 
	  (grey-level (pgm-greys pgm))
167: 
	  (grey-levels (pgm-greys pgms)))
168: 
      (if (and (every? (lambda (grey)
169: 
			 (= grey-level grey))
170: 
		       grey-levels)
171: 
	       (every? (lambda (d)
172: 
			 (= (Interval-upper-bound d 1)
173: 
			    (Interval-upper-bound domain 1)))
174: 
		       domains))
175: 
	  (let* ((arrays (cons array arrays))
176: 
		 (domains (cons domain domains))
177: 
		 (domain-rows (map (lambda (d)
178: 
				     (Interval-upper-bound d 0))
179: 
				   domains))
180: 
		 (accessors (map Array-accessor arrays)))
181: 
	    (make-pgm grey-level
182: 
		      (build-Array (build-Interval '#(0 0)
183: 
						   
184: 
						   (vector (apply + domain-rows)
185: 
							   (Interval-upper-bound domain 1)))
186: 
				   (lambda (i j)
187: 
				     (let loop ((i i)
188: 
						(accessors accessors)
189: 
						(domain-rows domain-rows))
190: 
				       (if (< i (car domain-rows))
191: 
					   ((car accessors) i j)
192: 
					   (loop (- i (car domain-rows))
193: 
						 (cdr accessors)
194: 
						 (cdr domain-rows))))))))
195: 
	  (error "can't concatenate pgm files")))))
196: 
197: 
(declare (generic))