vol-bbox.lisp

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