vol-pgm.lisp

   1 (in-package :vol)
   2
   3 (defun read-pgm (filename)
   4   (declare ((or pathname 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")
   8       (error "no PGM file"))
   9     (let* ((w (read s))
  10            (h (read s))
  11            (grays (read s))
  12            (pos (file-position s))
  13            (data (make-array
  14                   (list h w)
  15                   :element-type '(unsigned-byte 8)))
  16            (data-1d (make-array
  17                      (* h w)
  18                      :element-type '(unsigned-byte 8)
  19                      :displaced-to data)))
  20       (declare ((simple-array (unsigned-byte 8) (* *)) data)
  21                ((array (unsigned-byte 8) (*)) data-1d)
  22                ((integer 0 65535) grays w h))
  23       (unless (= grays 255)
  24         (error "image has wrong bitdepth"))
  25       (with-open-file (s filename
  26                          :element-type '(unsigned-byte 8))
  27         (file-position s pos)
  28         (read-sequence data-1d s))
  29       data)))
  30
  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
  39                        :direction :output
  40                        :if-exists :supersede
  41                        :if-does-not-exist :create)
  42       (declare (stream s))
  43       (format s "P5~%~D ~D~%255~%" w h))
  44     (with-open-file (s filename
  45                        :element-type '(unsigned-byte 8)
  46                        :direction :output
  47                        :if-exists :append)
  48       (let ((data-1d (make-array
  49                       (* h w)
  50                       :element-type '(unsigned-byte 8)
  51                       :displaced-to img)))
  52         (write-sequence data-1d s)))
  53     nil))
  54
  55 (defun read-stack (fn)
  56   (declare (string 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)
  62         (array-dimensions a)
  63       (let* ((result (make-array (list slices h w)
  64                                  :element-type '(unsigned-byte 8))))
  65         (dotimes (k slices)
  66           (let* ((a (read-pgm (elt files k))))
  67             (dotimes (j h)
  68               (dotimes (i w)
  69                 (setf (aref result k j i)
  70                       (aref a j i))))))
  71         result))))
  72
  73 (defun save-stack-ub8 (fn vol)
  74   (declare (string fn)
  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))
  79                                 fn
  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))))
  85       (dotimes (k z)
  86         (do-region ((j i) (y x))
  87           (setf (aref b j i)
  88                 (aref vol k j i)))
  89         (write-pgm (format nil "~a/~3,'0d.pgm" fn k) b))))
  90   nil)