From f5da337985fd924dcf80bb4060bc9274c6956b29 Mon Sep 17 00:00:00 2001
From: mk <martin@chuck.(none)>
Date: Sat, 14 Aug 2010 16:11:16 +0100
Subject: [PATCH] operators .. generic functions .* .+ ...

---
 vol-operators.lisp | 130 ++++++++++++-----------------------------------------
 1 file changed, 29 insertions(+), 101 deletions(-)

diff --git a/vol-operators.lisp b/vol-operators.lisp
index 319ae3a..1421e37 100644
--- a/vol-operators.lisp
+++ b/vol-operators.lisp
@@ -46,6 +46,8 @@
 #+nil
 (def-point-wise-op-rank-type * 1 sf)
 #+nil
+(def-point-wise-op-rank-type * 1 cdf)
+#+nil
 (.*-1-sf
  (make-array 3
 	     :element-type 'single-float
@@ -55,113 +57,39 @@
 	     :initial-contents '(2s0 2s0 3s0)))
 
 (defmacro def-point-wise-functions (ops ranks types)
-  (let ((result nil))
+  (let ((specific-funcs nil)
+	(generic-funcs nil))
     (loop for rank in ranks do
-	(loop for type in types do
-	     (loop for op in ops do
-		  (push `(def-point-wise-op ,op ,rank ,type)
-			result))))
-    `(progn ,@result)))
+	 (loop for type in types do
+	      (loop for op in ops do
+		   (push `(def-point-wise-op-rank-type ,op ,rank ,type)
+			 specific-funcs))))
+    (loop for op in ops do
+	 (let ((cases nil))
+	   (loop for rank in ranks do
+		(loop for type in types do
+		     (push `((simple-array ,(get-long-type type) ,rank)
+			     (,(format-symbol  ".~a-~a-~a" op rank type) 
+			       a b b-start))
+			   cases)))
+	   (push `(defun .* (a b &optional (b-start (make-vec-i)))
+		    (etypecase a
+		      ,@cases
+		      (t (error "The given type can't be handled with a generic
+		 point-wise function."))))  
+		 generic-funcs)))
+    `(progn ,@specific-funcs
+	    ,@generic-funcs)))
 
 (def-point-wise-functions (+ - * /) (1 2 3) (ub8 sf df csf cdf))
 
-(defun .*2 (vola volb)
-  (declare ((simple-array (complex my-float) 2) vola volb)
-	   (values (simple-array (complex my-float) 2) &optional))
-  (let ((result (make-array (array-dimensions vola)
-			    :element-type (array-element-type vola))))
-   (destructuring-bind (y x)
-       (array-dimensions vola)
-     (do-rectangle (j i 0 y 0 x)
-       (setf (aref result j i)
-	     (* (aref vola j i)
-		(aref volb j i)))))
-   result))
-
-(defun .+2 (vola volb)
-  (declare ((simple-array (complex my-float) 2) vola volb)
-	   (values (simple-array (complex my-float) 2) &optional))
-  (let ((result (make-array (array-dimensions vola)
-			    :element-type (array-element-type vola))))
-   (destructuring-bind (y x)
-       (array-dimensions vola)
-     (do-rectangle (j i 0 y 0 x)
-       (setf (aref result j i)
-	     (+ (aref vola j i)
-		(aref volb j i)))))
-   result))
-
-(defun .* (vola volb &optional volb-start)
-  "Elementwise multiplication of VOLA and VOLB. Both volumes must have
-the same dimensions or VOLB must be smaller in all dimensions. In the
-latter case a vec-i has to be supplied in VOLB-START to define the
-relative position of VOLB inside VOLA."
-  (declare ((simple-array (complex my-float) 3) vola volb)
-	   ((or null vec-i) volb-start)
-	   (values (simple-array (complex my-float) 3) &optional))
-  (let ((result (make-array (array-dimensions volb)
-			    :element-type '(complex my-float))))
-   (destructuring-bind (z y x)
-       (array-dimensions vola)
-     (destructuring-bind (zz yy xx)
-	 (array-dimensions volb)
-       (if volb-start
-	   ;; fill the result with volb multiplied by the
-	   ;; corresponding values from the bigger vola
-	   (let ((sx (vec-i-x volb-start))
-		 (sy (vec-i-y volb-start))
-		 (sz (vec-i-z volb-start)))
-	     (unless (and (<= zz (+ z sz))
-			  (<= yy (+ y sy))
-			  (<= xx (+ x sx)))
-	       (error "VOLB isn't contained in VOLA when shifted by VOLB-START. ~a" 
-		      (list zz (+ z sz))))
-	     (do-box (k j i 0 zz 0 yy 0 xx)
-	       (setf (aref result k j i)
-		     (* (aref volb k j i)
-			(aref vola (+ k sz) (+ j sy) (+ i sx))))))
-	   (progn 
-	     (unless (and (= z zz) (= y yy) (= x xx))
-	       (error "volumes don't have the same size, maybe you can supply a start vector."))
-	     (do-box (k j i 0 z 0 y 0 x)
-	       (setf (aref result k j i)
-		     (* (aref vola k j i)
-			(aref volb k j i))))))))
-   result))
+#+nil
+(.* (make-array 3 :element-type 'single-float
+		:initial-contents '(1s0 2s0 3s0))
+    (make-array 3 :element-type 'single-float
+		:initial-contents '(2s0 2s0 3s0)))
 
-(defun .+ (vola volb &optional (volb-start (make-vec-i)))
-  (declare ((simple-array (complex my-float) 3) vola volb)
-	   (vec-i volb-start)
-	   (values (simple-array (complex my-float) 3) &optional))
-  (let ((result (make-array (array-dimensions volb)
-			    :element-type '(complex my-float))))
-    (destructuring-bind (z y x)
-	(array-dimensions volb)
-      (let ((sx (vec-i-x volb-start))
-	    (sy (vec-i-y volb-start))
-	    (sz (vec-i-z volb-start)))
-	(do-box (k j i 0 z 0 y 0 x)
-	  (setf (aref result k j i)
-		(+ (aref vola (+ k sz) (+ j sy) (+ i sx))
-		   (aref volb k j i))))))
-    result))
 
-(defun .- (vola volb &optional (volb-start (make-vec-i)))
-  (declare ((simple-array (complex my-float) 3) vola volb)
-	   (vec-i volb-start)
-	   (values (simple-array (complex my-float) 3) &optional))
-  (let ((result (make-array (array-dimensions volb)
-			    :element-type '(complex my-float))))
-    (destructuring-bind (z y x)
-	(array-dimensions volb)
-      (let ((sx (vec-i-x volb-start))
-	    (sy (vec-i-y volb-start))
-	    (sz (vec-i-z volb-start)))
-	(do-box (k j i 0 z 0 y 0 x)
-	  (setf (aref result k j i)
-		(- (aref vola (+ k sz) (+ j sy) (+ i sx))
-		   (aref volb k j i))))))
-    result))
 
 (declaim (ftype (function (my-float (simple-array (complex my-float) 3))
 			  (values (simple-array (complex my-float) 3) &optional))
-- 
2.11.4.GIT