vol-bbox.lisp

   1 (in-package :vol)
   2
   3 ;; bbox contains float values but is also used to represent pixel
   4 ;; positions. In that case start is the first sample that is non-zero
   5 ;; and end is the last non-zero pixel.
   6 (defstruct bbox
   7   (start (v) :type vec)
   8   (end (alexandria:required-argument) :type vec))
   9
  10 (def-generator (extract-bbox (rank type))
  11   `(defun ,name (a bbox)
  12      (declare ((simple-array ,long-type ,rank) a)
  13               (bbox bbox)
  14               (values (simple-array ,long-type ,rank) &optional))
  15      ,(ecase
  16        rank
  17        (2 `(destructuring-bind (y x) (array-dimensions a)
  18              (with-slots (start end) bbox
  19                (unless (and (< (vec-x end) x) (< (vec-y end) y))
  20                  (error "bbox is bigger than array"))
  21                (let* ((sx (floor (vec-x start)))
  22                       (sy (floor (vec-y start)))
  23                       (widths (v+ (v- end start) (v 1d0 1d0)))
  24                       (res (make-array (list (floor (vec-y widths))
  25                                              (floor (vec-x widths)))
  26                                        :element-type ',long-type)))
  27                  (destructuring-bind (yy xx)
  28                      (array-dimensions res)
  29                    (do-region ((j i) (yy xx))
  30                      (setf (aref res j i) (aref a (+ j sy) (+ i sx)))))
  31                  res))))
  32        (3 `(destructuring-bind (z y x) (array-dimensions a)
  33              (with-slots (start end) bbox
  34                (unless (and (< (vec-x end) x) (< (vec-y end) y) (< (vec-z end) z))
  35                  (error "bbox is bigger than array"))
  36                (let* ((sx (floor (vec-x start)))
  37                       (sy (floor (vec-y start)))
  38                       (sz (floor (vec-z start)))
  39                       (widths (v+ (v- end start) (v 1d0 1d0 1d0)))
  40                       (res (make-array (list (floor (vec-z widths))
  41                                              (floor (vec-y widths))
  42                                              (floor (vec-x widths)))
  43                                        :element-type ',long-type)))
  44                  (destructuring-bind (zz yy xx)
  45                      (array-dimensions res)
  46                    (do-region ((k j i) (zz yy xx))
  47                      (setf (aref res k j i)
  48                            (aref a (+ k sz) (+ j sy) (+ i sx)))))
  49                  res)))))))
  50
  51 (defmacro def-extract-box-functions (ranks types)
  52   (let ((specifics nil)
  53         (cases nil)
  54         (name (format-symbol "extract-bbox")))
  55     (loop for rank in ranks do
  56          (loop for type in types do
  57               (push `(def-extract-bbox-rank-type ,rank ,type)
  58                     specifics)
  59               (push `((simple-array ,(get-long-type type) ,rank)
  60                       (,(format-symbol "~a-~a-~a" name rank type) a bbox))
  61                     cases)))
  62     (store-new-function name)
  63     `(progn ,@specifics
  64             (defun ,name (a bbox)
  65                (etypecase a
  66                  ,@cases
  67                  (t (error "The given type can't be handled with a generic ~a function." ',name)))))))
  68
  69 (def-extract-box-functions (2 3) (ub8 sf df csf cdf))
  70
  71 (def-generator (replace-bbox (rank type))
  72   `(defun ,name (a b bbox)
  73      "A beeing a big array, and B a smaller one with BBOX giving its
  74 coordinates relative to A, replace the contents of A with B."
  75      (declare ((simple-array ,long-type ,rank) a b)
  76               (bbox bbox)
  77               (values (simple-array ,long-type ,rank) &optional))
  78      ,(ecase
  79        rank
  80        (2 `(destructuring-bind (y x) (array-dimensions a)
  81              (destructuring-bind (yy xx) (array-dimensions b)
  82                (with-slots (start end) bbox
  83                  (unless (and (< (vec-x end) x) (< (vec-y end) y))
  84                    (error "bbox is bigger than array"))
  85                  (let* ((widths (v+ (v- end start) (v 1d0 1d0))))
  86                    (unless (and (= (floor (vec-x widths)) xx)
  87                                 (= (floor (vec-y widths)) yy))
  88                      (error "size of BBOX isn't the same as size of small array B"))
  89                    (let ((sx (floor (vec-x start)))
  90                          (sy (floor (vec-y start))))
  91                      (do-region ((j i) (yy xx))
  92                        (setf (aref a (+ sy j) (+ sx i)) (aref b j i)))
  93                      a))))))
  94        (3 `(destructuring-bind (z y x) (array-dimensions a)
  95              (destructuring-bind (zz yy xx) (array-dimensions b)
  96                (with-slots (start end) bbox
  97                  (unless (and (< (vec-x end) x) (< (vec-y end) y) (< (vec-z end) z))
  98                    (error "bbox is bigger than array"))
  99                  (let ((widths (v+ (v- end start) (v 1d0 1d0 1d0))))
 100                    (unless (and (= (floor (vec-x widths)) xx)
 101                                 (= (floor (vec-y widths)) yy)
 102                                 (= (floor (vec-z widths)) zz))
 103                      (error "size of BBOX isn't the same as size of small array B"))
 104                    (let ((sx (floor (vec-x start)))
 105                          (sy (floor (vec-y start)))
 106                          (sz (floor (vec-z start))))
 107                      (do-region ((k j i) (zz yy xx))
 108                        (setf (aref a (+ sz k) (+ sy j) (+ sx i)) (aref b k j i)))
 109                      a)))))))))
 110 #+nil
 111 (def-replace-bbox-rank-type 2 ub8)
 112 #+nil
 113 (let* ((a (make-array (list 3 3) :element-type '(unsigned-byte 8)))
 114        (b (make-array (list 2 2) :element-type '(unsigned-byte 8)))
 115        (b1 (sb-ext:array-storage-vector b)))
 116   (dotimes (i (length b1))
 117     (setf (aref b1 i) i))
 118   (replace-bbox-2-ub8 a b (make-bbox :start (v) :end (v 1d0 1d0))))
 119
 120 (defmacro def-replace-bbox-functions (ranks types)
 121   (let* ((specifics nil)
 122          (cases nil)
 123          (name (format-symbol "replace-bbox")))
 124     (loop for rank in ranks do
 125          (loop for type in types do
 126               (let ((def-name (format-symbol "def-~a-rank-type" name))
 127                     (specific-name (format-symbol "~a-~a-~a" name rank type)))
 128                 (push `(,def-name ,rank ,type) specifics)
 129                 (push `((simple-array ,(get-long-type type) ,rank)
 130                         (,specific-name a b bbox))
 131                       cases))))
 132     (store-new-function name)
 133     `(progn ,@specifics
 134             (defun ,name (a b bbox)
 135                (etypecase a
 136                  ,@cases
 137                  (t (error "The given type can't be handled with a generic ~a function." ',name)))))))
 138
 139 (def-replace-bbox-functions (2 3) (ub8 sf df csf cdf))
 140
 141
 142
 143
 144 (def-generator (find-bbox (rank type))
 145   `(defun ,name (a)
 146      "A beeing a big array, and B a smaller one with BBOX giving its
 147 coordinates relative to A, replace the contents of A with B."
 148      (declare ((simple-array ,long-type ,rank) a)
 149               (values (or null bbox) &optional))
 150      ,(ecase
 151        rank
 152        (2 `(destructuring-bind (y x)
 153                (array-dimensions a)
 154              (labels ((top ()
 155                         ;; Note: the order of the loops is important
 156                         (do-region ((j i) (y x))
 157                           (unless (= 0 (aref a j i)) (return-from top j)))
 158                         (1- y))
 159                       (left () ;; search from left side for first non-zero
 160                         (do-region ((i j) (x y)) (unless (= 0 (aref a j i))
 161                             (return-from left i)))
 162                         (1- x))
 163                       (bottom ()
 164                         (do-region ((j i) (y x))
 165                           ;; invert j so that it starts search from bottom
 166                           (let ((jj (- (1- y) j))) (unless (= 0 (aref a jj i))
 167                                                      (return-from bottom jj))))
 168                         0)
 169                       (right ()
 170                         (do-region ((i j) (x y))
 171                           (let ((ii (- (1- x) i))) (unless (= 0 (aref a j ii))
 172                                                      (return-from right ii))))
 173                         0))
 174                (let ((l (left))
 175                      (r (right)))
 176                  (when (<= l r) ;; otherwise all pixels are zero
 177                    (make-bbox :start (v (* 1d0 l) (* 1d0 (top)))
 178                               :end (v (* 1d0 r) (* 1d0 (bottom)))))))))
 179        (3 `(destructuring-bind (z y x) (array-dimensions a)
 180              (labels ((front ()
 181                         (do-region ((k j i) (z y x)) (unless (= 0 (aref a k j i))
 182                                                        (return-from front k)))
 183                         (1- z))
 184                       (back ()
 185                         (do-region ((k j i) (z y x))
 186                           (let ((kk (- (1- z) k))) (unless (= 0 (aref a kk j i))
 187                                                      (return-from back kk))))
 188                         0)
 189                       (top ()
 190                         (do-region ((j k i) (y z x)) (unless (= 0 (aref a k j i))
 191                                                        (return-from top j)))
 192                         (1- y))
 193                       (left ()
 194                         (do-region ((i k j) (x z y)) (unless (= 0 (aref a k j i))
 195                                                        (return-from left i)))
 196                         (1- x))
 197                       (bottom ()
 198                         (do-region ((j k i) (y z x))
 199                           (let ((jj (- (1- y) j))) (unless (= 0 (aref a k jj i))
 200                                                      (return-from bottom jj))))
 201                         0)
 202                       (right ()
 203                         (do-region ((i k j) (x z y))
 204                           (let ((ii (- (1- x) i))) (unless (= 0 (aref a k j ii))
 205                                                      (return-from right ii))))
 206                         0))
 207                (let ((l (left))
 208                      (r (right)))
 209                  (when (<= l r) ;; otherwise all pixels are zero
 210                    (make-bbox :start (v (* 1d0 l) (* 1d0 (top)) (* 1d0 (front)))
 211                               :end (v (* 1d0 r) (* 1d0 (bottom)) (* 1d0 (back))))))))))))
 212 #+nil
 213 (def-find-bbox-rank-type 2 ub8)
 214
 215 (defmacro def-find-bbox-functions (ranks types)
 216   (let* ((specifics nil)
 217          (cases nil)
 218          (name (format-symbol "find-bbox")))
 219     (loop for rank in ranks do
 220          (loop for type in types do
 221               (let ((def-name (format-symbol "def-~a-rank-type" name))
 222                     (specific-name (format-symbol "~a-~a-~a" name rank type)))
 223                 (push `(,def-name ,rank ,type) specifics)
 224                 (push `((simple-array ,(get-long-type type) ,rank)
 225                         (,specific-name a))
 226                       cases))))
 227     (store-new-function name)
 228     `(progn ,@specifics
 229             (defun ,name (a)
 230                (etypecase a
 231                  ,@cases
 232                  (t (error "The given type can't be handled with a generic ~a function." ',name)))))))
 233
 234 (def-find-bbox-functions (2 3) (ub8 sf df csf cdf))
 235
 236 #+nil
 237 (let* ((a (make-array (list 5 5)
 238                       :element-type '(unsigned-byte 8)
 239                       :initial-contents '((0 0 0 0 0)
 240                                           (0 1 0 0 0)
 241                                           (0 0 0 1 0)
 242                                           (0 0 0 0 0)
 243                                           (0 0 0 0 0))))
 244        (empty (make-array (list 5 5)
 245                           :element-type '(unsigned-byte 8)))
 246        (box (find-bbox a))
 247        (ex (extract-bbox a box)))
 248   (list box ex (replace-bbox empty ex box)))
 249
 250 #+nil
 251 (let* ((empty (make-array (list 4 4 4) :element-type '(unsigned-byte 8)))
 252        (a (make-array (list 4 4 4)
 253                       :element-type '(unsigned-byte 8)
 254                       :initial-contents
 255                       '(((0 0 0 0)
 256                          (0 0 0 0)
 257                          (0 0 0 0)
 258                          (0 0 0 0))
 259                         ((0 0 0 0)
 260                          (0 1 0 0)
 261                          (0 0 1 0)
 262                          (0 0 0 0))
 263                         ((0 0 0 0)
 264                          (0 0 0 0)
 265                          (0 0 0 0)
 266                          (0 0 0 0))
 267                         ((0 0 0 0)
 268                          (0 0 0 0)
 269                          (0 0 0 0)
 270                          (0 0 0 0)))))
 271        (box (find-bbox-3-ub8 a))
 272        (ex (extract-bbox-3-ub8 a box)))
 273   (list box ex q(replace-bbox-3-ub8 empty ex box)))