3 (defun read-pgm (filename)
4 (declare (string filename
)
5 (values (simple-array (unsigned-byte 8) 2) &optional
))
6 (with-open-file (s filename
)
7 (unless (equal (symbol-name (read s
)) "P5")
12 (pos (file-position s
))
15 :element-type
'(unsigned-byte 8)))
18 :element-type
'(unsigned-byte 8)
20 (declare ((simple-array (unsigned-byte 8) (* *)) data
)
21 ((array (unsigned-byte 8) (*)) data-1d
)
22 ((integer 0 65535) grays w h
))
24 (error "image has wrong bitdepth"))
25 (with-open-file (s filename
26 :element-type
'(unsigned-byte 8))
28 (read-sequence data-1d s
))
31 (defun write-pgm (filename img
)
32 (declare (simple-string filename
)
33 ((array (unsigned-byte 8) 2) img
)
34 (values null
&optional
))
35 (destructuring-bind (h w
)
36 (array-dimensions img
)
37 (declare ((integer 0 65535) w h
))
38 (with-open-file (s filename
41 :if-does-not-exist
:create
)
43 (format s
"P5~%~D ~D~%255~%" w h
))
44 (with-open-file (s filename
45 :element-type
'(unsigned-byte 8)
48 (let ((data-1d (make-array
50 :element-type
'(unsigned-byte 8)
52 (write-sequence data-1d s
)))
55 (defun read-stack (fn)
57 (values (simple-array (unsigned-byte 8) 3) &optional
))
58 (let* ((files (directory fn
))
59 (slices (length files
))
60 (a (read-pgm (first files
))))
61 (destructuring-bind (h w
)
63 (let* ((result (make-array (list slices h w
)
64 :element-type
'(unsigned-byte 8))))
66 (let* ((a (read-pgm (elt files k
))))
69 (setf (aref result k j i
)
73 (defun save-stack-ub8 (fn vol
)
75 ((simple-array (unsigned-byte 8) 3) vol
)
76 (values null
&optional
))
77 (ensure-directories-exist (if (eq (1- (length fn
))
78 (position #\
/ fn
:from-end t
))
80 (format nil
"~a/" fn
)))
81 (destructuring-bind (z y x
)
82 (array-dimensions vol
)
83 (let ((b (make-array (list y x
)
84 :element-type
'(unsigned-byte 8))))
86 (do-region ((j i
) (y x
))
89 (write-pgm (format nil
"~a/~3,'0d.pgm" fn k
) b
))))