From 9d2e73ad919b6cbfd0e9470d4b69e45021bf675f Mon Sep 17 00:00:00 2001 From: mk Date: Sun, 15 Aug 2010 13:54:06 +0100 Subject: [PATCH] bbox .. find-bbox transformed into macro, bbox compiles now --- vol-bbox.lisp | 230 ++++++++++++++++++++++++---------------------------------- 1 file changed, 95 insertions(+), 135 deletions(-) diff --git a/vol-bbox.lisp b/vol-bbox.lisp index d2577a8..196b3aa 100644 --- a/vol-bbox.lisp +++ b/vol-bbox.lisp @@ -144,47 +144,97 @@ coordinates relative to A, replace the contents of A with B." +(def-generator (find-bbox (rank type)) + `(defun ,name (a) + "A beeing a big array, and B a smaller one with BBOX giving its +coordinates relative to A, replace the contents of A with B." + (declare ((simple-array ,long-type ,rank) a) + (values (or null bbox) &optional)) + ,(ecase + rank + (2 `(destructuring-bind (y x) + (array-dimensions a) + (labels ((top () + ;; Note: the order of the loops is important + (do-region ((j i) (y x)) + (unless (= 0 (aref a j i)) (return-from top j))) + (1- y)) + (left () ;; search from left side for first non-zero + (do-region ((i j) (x y)) (unless (= 0 (aref a j i)) + (return-from left i))) + (1- x)) + (bottom () + (do-region ((j i) (y x)) + ;; invert j so that it starts search from bottom + (let ((jj (- (1- y) j))) (unless (= 0 (aref a jj i)) + (return-from bottom jj)))) + 0) + (right () + (do-region ((i j) (x y)) + (let ((ii (- (1- x) i))) (unless (= 0 (aref a j ii)) + (return-from right ii)))) + 0)) + (let ((l (left)) + (r (right))) + (when (<= l r) ;; otherwise all pixels are zero + (make-bbox :start (v (* 1d0 l) (* 1d0 (top))) + :end (v (* 1d0 r) (* 1d0 (bottom))))))))) + (3 `(destructuring-bind (z y x) (array-dimensions a) + (labels ((front () + (do-region ((k j i) (z y x)) (unless (= 0 (aref a k j i)) + (return-from front k))) + (1- z)) + (back () + (do-region ((k j i) (z y x)) + (let ((kk (- (1- z) k))) (unless (= 0 (aref a kk j i)) + (return-from back kk)))) + 0) + (top () + (do-region ((j k i) (y z x)) (unless (= 0 (aref a k j i)) + (return-from top j))) + (1- y)) + (left () + (do-region ((i k j) (x z y)) (unless (= 0 (aref a k j i)) + (return-from left i))) + (1- x)) + (bottom () + (do-region ((j k i) (y z x)) + (let ((jj (- (1- y) j))) (unless (= 0 (aref a k jj i)) + (return-from bottom jj)))) + 0) + (right () + (do-region ((i k j) (x z y)) + (let ((ii (- (1- x) i))) (unless (= 0 (aref a k j ii)) + (return-from right ii)))) + 0)) + (let ((l (left)) + (r (right))) + (when (<= l r) ;; otherwise all pixels are zero + (make-bbox :start (v (* 1d0 l) (* 1d0 (top)) (* 1d0 (front))) + :end (v (* 1d0 r) (* 1d0 (bottom)) (* 1d0 (back)))))))))))) +#+nil +(def-find-bbox-rank-type 2 ub8) +(defmacro def-find-bbox-functions (ranks types) + (let* ((specifics nil) + (cases nil) + (name (format-symbol "find-bbox"))) + (loop for rank in ranks do + (loop for type in types do + (let ((def-name (format-symbol "def-~a-rank-type" name)) + (specific-name (format-symbol "~a-~a-~a" name rank type))) + (push `(,def-name ,rank ,type) specifics) + (push `((simple-array ,(get-long-type type) ,rank) + (,specific-name a)) + cases)))) + (store-new-function name) + `(progn ,@specifics + (defun ,name (a) + (etypecase a + ,@cases + (t (error "The given type can't be handled with a generic ~a function." ',name))))))) - - - -(defun find-bbox2-ub8 (a) - "Return the rectangle containing non-zero pixels. Returns nil if all -pixels are zero." - (declare ((simple-array (unsigned-byte 8) 2) a) - (values (or null bbox) &optional)) - (destructuring-bind (y x) - (array-dimensions a) - (labels ((top () - ;; Note: the order of the loops of do-rectangle is important - (do-rectangle (j i 0 y 0 x) - (unless (= 0 (aref a j i)) - (return-from top j))) - (1- y)) - (left () ;; search from left side for first non-zero - (do-rectangle (i j 0 x 0 y) - (unless (= 0 (aref a j i)) - (return-from left i))) - (1- x)) - (bottom () - (do-rectangle (j i 0 y 0 x) - ;; invert j so that it starts search from bottom - (let ((jj (- (1- y) j))) - (unless (= 0 (aref a jj i)) - (return-from bottom jj)))) - 0) - (right () - (do-rectangle (i j 0 x 0 y) - (let ((ii (- (1- x) i))) - (unless (= 0 (aref a j ii)) - (return-from right ii)))) - 0)) - (let ((l (left)) - (r (right))) - (when (<= l r) ;; otherwise all pixels are zero - (make-bbox :start (v (* one l) (* one (top))) - :end (v (* one r) (* one (bottom))))))))) +(def-find-bbox-functions (2 3) (ub8 sf df csf cdf)) #+nil (let* ((a (make-array (list 5 5) @@ -196,99 +246,9 @@ pixels are zero." (0 0 0 0 0)))) (empty (make-array (list 5 5) :element-type '(unsigned-byte 8))) - (box (find-bbox2-ub8 a)) - (ex (extract-bbox2-ub8 a box))) - (replace-bbox2-ub8 empty ex box)) - -(defun find-bbox3-ub8 (a) - "Return the box containing non-zero pixels. Returns nil if all -pixels are zero." - (declare ((simple-array (unsigned-byte 8) 3) a) - (values (or null bbox) &optional)) - (destructuring-bind (z y x) - (array-dimensions a) - (labels ((front () - (do-box (k j i 0 z 0 y 0 x) - (unless (= 0 (aref a k j i)) - (return-from front k))) - (1- z)) - (back () - (do-box (k j i 0 z 0 y 0 x) - (let ((kk (- (1- z) k))) - (unless (= 0 (aref a kk j i)) - (return-from back kk)))) - 0) - (top () - (do-box (j k i 0 y 0 z 0 x) - (unless (= 0 (aref a k j i)) - (return-from top j))) - (1- y)) - (left () - (do-box (i k j 0 x 0 z 0 y) - (unless (= 0 (aref a k j i)) - (return-from left i))) - (1- x)) - (bottom () - (do-box (j k i 0 y 0 z 0 x) - (let ((jj (- (1- y) j))) - (unless (= 0 (aref a k jj i)) - (return-from bottom jj)))) - 0) - (right () - (do-box (i k j 0 x 0 z 0 y) - (let ((ii (- (1- x) i))) - (unless (= 0 (aref a k j ii)) - (return-from right ii)))) - 0)) - (let ((l (left)) - (r (right))) - (when (<= l r) ;; otherwise all pixels are zero - (make-bbox :start (v (* one l) (* one (top)) (* one (front))) - :end (v (* one r) (* one (bottom)) (* one (back))))))))) - -(defmacro def-extract-bbox3 () - `(progn - ,@(loop for i in '((df my-float) - (cdf (complex my-float)) - (ub8 (unsigned-byte 8))) collect - (destructuring-bind (short long) - i - `(defun ,(intern (format nil "EXTRACT-BBOX3-~a" short)) (a bbox) - (declare ((simple-array ,long 3) a) - (bbox bbox) - (values (simple-array ,long 3) &optional)) - (destructuring-bind (z y x) - (array-dimensions a) - (with-slots (start end) - bbox - (unless (and (< (vec-x end) x) - (< (vec-y end) y) - (< (vec-z end) z)) - (error "bbox is bigger than array")) - (let* ((sx (floor (vec-x start))) - (sy (floor (vec-y start))) - (sz (floor (vec-z start))) - (widths (v+ (v- end start) (v one one one))) - (res (make-array (list (floor (vec-z widths)) - (floor (vec-y widths)) - (floor (vec-x widths))) - :element-type ',long))) - (destructuring-bind (zz yy xx) - (array-dimensions res) - (do-box (k j i 0 zz 0 yy 0 xx) - (setf (aref res k j i) - (aref a (+ k sz) (+ j sy) (+ i sx))))) - res)))))))) -(def-extract-bbox3) - - -(defun replace-bbox3-ub8 (a b bbox) - "A beeing a big array, and B a smaller one with BBOX giving its -coordinates relative to A, replace the contents of A with B." - (declare ((simple-array (unsigned-byte 8) 3) a b) - (bbox bbox) - (values (simple-array (unsigned-byte 8) 3) &optional)) - ) + (box (find-bbox a)) + (ex (extract-bbox a box))) + (list box ex (replace-bbox empty ex box))) #+nil (let* ((empty (make-array (list 4 4 4) :element-type '(unsigned-byte 8))) @@ -311,6 +271,6 @@ coordinates relative to A, replace the contents of A with B." (0 0 0 0) (0 0 0 0) (0 0 0 0))))) - (box (find-bbox3-ub8 a)) - (ex (extract-bbox3-ub8 a box))) - (replace-bbox3-ub8 empty ex box)) + (box (find-bbox-3-ub8 a)) + (ex (extract-bbox-3-ub8 a box))) + (list box ex q(replace-bbox-3-ub8 empty ex box))) -- 2.11.4.GIT