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.
8 (end (alexandria:required-argument
) :type vec
))
10 (def-generator (extract-bbox (rank type
))
11 `(defun ,name
(a bbox
)
12 (declare ((simple-array ,long-type
,rank
) a
)
14 (values (simple-array ,long-type
,rank
) &optional
))
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
)))))
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
)))))
51 (defmacro def-extract-box-functions
(ranks types
)
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
)
59 (push `((simple-array ,(get-long-type type
) ,rank
)
60 (,(format-symbol "~a-~a-~a" name rank type
) a bbox
))
62 (store-new-function name
)
67 (t (error "The given type can't be handled with a generic ~a function." ',name
)))))))
69 (def-extract-box-functions (2 3) (ub8 sf df csf cdf
))
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
)
77 (values (simple-array ,long-type
,rank
) &optional
))
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
)))
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
)))
111 (def-replace-bbox-rank-type 2 ub8
)
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
))))
120 (defmacro def-replace-bbox-functions
(ranks types
)
121 (let* ((specifics 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
))
132 (store-new-function name
)
134 (defun ,name
(a b bbox
)
137 (t (error "The given type can't be handled with a generic ~a function." ',name
)))))))
139 (def-replace-bbox-functions (2 3) (ub8 sf df csf cdf
))
144 (def-generator (find-bbox (rank type
))
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
))
152 (2 `(destructuring-bind (y x
)
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
)))
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
)))
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
))))
170 (do-region ((i j
) (x y
))
171 (let ((ii (- (1- x
) i
))) (unless (= 0 (aref a j ii
))
172 (return-from right ii
))))
176 (when (<= l r
) ;; otherwise all pixels are zero
177 (make-bbox :start
(make-vec (* 1d0 l
) (* 1d0
(top)))
178 :end
(make-vec (* 1d0 r
) (* 1d0
(bottom)))))))))
179 (3 `(destructuring-bind (z y x
) (array-dimensions a
)
181 (do-region ((k j i
) (z y x
)) (unless (= 0 (aref a k j i
))
182 (return-from front k
)))
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
))))
190 (do-region ((j k i
) (y z x
)) (unless (= 0 (aref a k j i
))
191 (return-from top j
)))
194 (do-region ((i k j
) (x z y
)) (unless (= 0 (aref a k j i
))
195 (return-from left i
)))
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
))))
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
))))
209 (when (<= l r
) ;; otherwise all pixels are zero
210 (make-bbox :start
(make-vec (* 1d0 l
) (* 1d0
(top)) (* 1d0
(front)))
211 :end
(make-vec (* 1d0 r
) (* 1d0
(bottom)) (* 1d0
(back))))))))))))
213 (def-find-bbox-rank-type 2 ub8
)
215 (defmacro def-find-bbox-functions
(ranks types
)
216 (let* ((specifics 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
)
227 (store-new-function name
)
232 (t (error "The given type can't be handled with a generic ~a function." ',name
)))))))
234 (def-find-bbox-functions (2 3) (ub8 sf df csf cdf
))
237 (let* ((a (make-array (list 5 5)
238 :element-type
'(unsigned-byte 8)
239 :initial-contents
'((0 0 0 0 0)
244 (empty (make-array (list 5 5)
245 :element-type
'(unsigned-byte 8)))
247 (ex (extract-bbox a box
)))
248 (list box ex
(replace-bbox empty ex box
)))
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)
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
)))