vol/macros.lisp

   1 ;; macros to handle volumes
   2
   3 (in-package :vol)
   4
   5 (defmacro with-arrays (arrays &body body)
   6   "Provides a corresponding accessor for each array as a local macro,
   7 so that (ARRAY ...) corresponds to (AREF ARRAY ...)."
   8   `(macrolet ,(mapcar (lambda (array)
   9                         `(,array (&rest indices) `(aref ,',array ,@indices)))
  10                       arrays)
  11      ,@body))
  12
  13 (defmacro with-linear-arrays (arrays &body body)
  14   "Exposes the linear array for each of the supplied arrays. When a
  15 and b are multidimensional arrays you can use (with-arrays (a
  16 b) (setf (a1 0) (b1 324))) to access their storage vectors."
  17   (let* ((arrays1 (mapcar #'(lambda (x)
  18                               (unless (symbolp x)
  19                                (error "only symbols are allowed in with1."))
  20                               (intern (format nil "~a1" x)))
  21                           arrays)))
  22    `(let (,@(mapcar #'(lambda (x y) `(,x (sb-ext:array-storage-vector ,y)))
  23                     arrays1 arrays))
  24       (with-arrays ,arrays1
  25         ,@body))))
  26
  27 (defmacro do-region ((indices end &optional (start '(0 0 0))) &body body)
  28   "Write intertwined loops to traverse a vector, an image or a volume."
  29   (unless (and (= (length indices)
  30                   (length end)))
  31     (error "Number of indices and interval-ends are not equal."))
  32   (labels ((rec (ind end start acc) ;; several loops
  33              (if (null end)
  34                  acc
  35                  (rec (cdr ind) (cdr end) (cdr start)
  36                       `((loop for ,(car ind) from ,(car start)
  37                            below ,(car end) do ,@acc))))))
  38     (first (rec (reverse indices) ;; first index is outermost loop
  39                 (reverse end)
  40                 (reverse start) body))))
  41 #+nil
  42 (let ((sum 0))
  43   (do-region ((k j i) (4 4 5))
  44     (incf sum (+ k j i)))
  45   sum)
  46
  47
  48 (defmacro with-slice ((slice-array array slice-nr) &body body)
  49   "Returns SLICE-NRth slice of ARRAY as the 2D SLICE-ARRAY."
  50   (alexandria:with-gensyms (x y z)
  51     `(destructuring-bind (,z ,y ,x)
  52          (array-dimensions ,array)
  53        (when (or (< ,slice-nr 0) (<= ,z ,slice-nr))
  54          (error "slice-nr=~d out of range [0,~d]" ,slice-nr (1- ,z)))
  55        (let* ((,slice-array (make-array (list ,y ,x)
  56                                         :element-type '(unsigned-byte 8)
  57                                         :displaced-to ,array
  58                                         :displaced-index-offset (* ,slice-nr ,x ,y))))
  59          ,@body))))