[lisplab-cvs] r41 - src/matrix
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Sun May 24 08:56:15 UTC 2009
Author: jivestgarden
Date: Sun May 24 04:56:13 2009
New Revision: 41
Log:
fixed the standard operators and functions
Modified:
src/matrix/level2-generic.lisp
src/matrix/level2-matrix-dge.lisp
src/matrix/level2-matrix-zge.lisp
Modified: src/matrix/level2-generic.lisp
==============================================================================
--- src/matrix/level2-generic.lisp (original)
+++ src/matrix/level2-generic.lisp Sun May 24 04:56:13 2009
@@ -244,10 +244,103 @@
(def-matrix-base-boolean-operator .>=)
-
+;; Specialize operators for matrix-ge. It is dangerous to spezialize for matrix-base
+;; since the output type depends on the kind of operator. It is possible to
+;; make it better by separating between complex and real number and matrices, but
+;; I'm too laza to do it.
+(defmacro def-binary-op-matrix-ge (op)
+ (let ((a (gensym "a"))
+ (b (gensym "b"))
+ (len (gensym "len"))
+ (i (gensym "i")))
+ `(progn
+ (defmethod ,op ((,a matrix-ge) ,b)
+ (let* ((,a (copy ,a))
+ (,len (size ,a)))
+ (dotimes (,i ,len)
+ (setf (vref ,a ,i) (,op (vref ,a ,i) ,b)))
+ ,a))
+ (defmethod ,op (,a (,b matrix-ge))
+ (let* ((,b (copy ,b))
+ (,len (size ,b)))
+ (dotimes (,i ,len)
+ (setf (vref ,b ,i) (,op ,a (vref ,b ,i))))
+ ,b))
+ (defmethod ,op ((,a matrix-ge) (,b matrix-ge))
+ (let* ((,a (copy ,a))
+ (,len (size ,a)))
+ (dotimes (,i ,len)
+ (setf (vref ,a ,i) (,op (vref ,a ,i) (vref ,b ,i))))
+ ,a)))))
+
+(def-binary-op-matrix-ge .add)
+
+(def-binary-op-matrix-ge .mul)
+
+(def-binary-op-matrix-ge .sub)
+
+(def-binary-op-matrix-ge .div)
+
+(def-binary-op-matrix-ge .expt)
+
+(defmacro each-element-function-matrix-ge (x form)
+ "Applies a form on each element of an matrix-ge."
+ (let ((i (gensym))
+ (y (gensym)))
+ `(let* ((,y (copy ,x)))
+ (dotimes (,i (size ,y))
+ (let ((,x (vref ,y ,i)))
+ (setf (vref ,y ,i)
+ ,form)))
+ ,y)))
+
+;;; Trignometric functions
+
+(defmethod .sin ((x matrix-ge))
+ (each-element-function-matrix-ge x (.sin x)))
+
+(defmethod .cos ((x matrix-ge))
+ (each-element-function-matrix-ge x (.cos x)))
+
+(defmethod .tan ((x matrix-ge))
+ (each-element-function-matrix-ge x (.tan x)))
+
+;;; Hyperbolic functions
+
+(defmethod .sinh ((x matrix-ge))
+ (each-element-function-matrix-ge x (.sinh x)))
+
+(defmethod .cosh ((x matrix-ge))
+ (each-element-function-matrix-ge x (.cosh x)))
+
+(defmethod .tanh ((x matrix-ge))
+ (each-element-function-matrix-ge x (.tanh x)))
+
+(defmethod .log ((x matrix-ge) &optional base)
+ (each-element-function-matrix-ge x (.log x base)))
+
+(defmethod .exp ((x matrix-ge))
+ (each-element-function-matrix-ge x (.exp x)))
+
+;;; Bessel functions
+
+(defmethod .besj (n (x matrix-ge))
+ (each-element-function-matrix-ge x (.besj n x)))
+
+(defmethod .besy (n (x matrix-ge))
+ (each-element-function-matrix-ge x (.besy n x)))
+
+(defmethod .besi (n (x matrix-ge))
+ (each-element-function-matrix-ge x (.besi n x)))
+(defmethod .besk (n (x matrix-ge))
+ (each-element-function-matrix-ge x (.besk n x)))
+(defmethod .besh1 (n (x matrix-ge))
+ (each-element-function-matrix-ge x (.besh1 n x)))
+(defmethod .besh2 (n (x matrix-ge))
+ (each-element-function-matrix-ge x (.besh2 n x)))
;;; TRASH
Modified: src/matrix/level2-matrix-dge.lisp
==============================================================================
--- src/matrix/level2-matrix-dge.lisp (original)
+++ src/matrix/level2-matrix-dge.lisp Sun May 24 04:56:13 2009
@@ -70,7 +70,7 @@
(store2 (gensym "store2"))
(i (gensym "i")))
`(progn
- (defmethod ,new ((,a matrix-lisp-dge) ,b)
+ (defmethod ,new ((,a matrix-lisp-dge) (,b real))
(let* ((,a (copy ,a))
(,store (matrix-store ,a))
(,b (coerce ,b 'double-float))
@@ -81,7 +81,7 @@
(dotimes (,i ,len)
(setf (aref ,store ,i) (,old (aref ,store ,i) ,b)))
,a))
- (defmethod ,new (,a (,b matrix-lisp-dge))
+ (defmethod ,new ((,a real) (,b matrix-lisp-dge))
(let* ((,b (copy ,b))
(,store (matrix-store ,b))
(,a (coerce ,a 'double-float))
@@ -135,14 +135,13 @@
make complex output for real arguments. TODO optimize? Probably no need. The
Hankel functions are slow anyway."
(let ((i (gensym))
- (a (gensym))
(b (gensym))
- (spec-a (gensym)))
- `(let* ((spec-a (find-matrix-description ,a))
- (,b (convert ,a (cons :z (cdr ,spec-a) ))))
- (dotimes (,i (size ,a))
- (let ((,x (mref ,a ,i)))
- (setf (mref ,b ,i) ,form)))
+ (spec-b (gensym)))
+ `(let* ((,spec-b (create-matrix-description ,x :et :z))
+ (,b (convert ,x ,spec-b) ))
+ (dotimes (,i (size ,x))
+ (let ((,x (vref ,x ,i)))
+ (setf (vref ,b ,i) ,form)))
,b)))
;;; Trignometric functions
@@ -159,19 +158,21 @@
;;; Hyperbolic functions
(defmethod .sinh ((x matrix-lisp-dge))
- (each-matrix-element-df-to-df x (.sinh x)))
+ (each-matrix-element-df-to-df x (sinh x)))
(defmethod .cosh ((x matrix-lisp-dge))
- (each-matrix-element-df-to-df x (.cosh x)))
+ (each-matrix-element-df-to-df x (cosh x)))
(defmethod .tanh ((x matrix-lisp-dge))
- (each-matrix-element-df-to-df x (.tanh x)))
+ (each-matrix-element-df-to-df x (tanh x)))
(defmethod .log ((x matrix-lisp-dge) &optional base)
- (each-matrix-element-df-to-df x (.log x base)))
+ (if base
+ (each-matrix-element-df-to-df x (log x base))
+ (each-matrix-element-df-to-df x (log x))))
(defmethod .exp ((x matrix-lisp-dge))
- (each-matrix-element-df-to-df x (.exp x)))
+ (each-matrix-element-df-to-df x (exp x)))
;;; Bessel functions
@@ -185,4 +186,10 @@
(each-matrix-element-df-to-df x (.besi n x)))
(defmethod .besk (n (x matrix-lisp-dge))
- (each-matrix-element-df-to-df x (.besk n x)))
\ No newline at end of file
+ (each-matrix-element-df-to-df x (.besk n x)))
+
+(defmethod .besh1 (n (x matrix-lisp-dge))
+ (each-matrix-element-df-to-complex-df x (.besh1 n x)))
+
+(defmethod .besh2 (n (x matrix-lisp-dge))
+ (each-matrix-element-df-to-complex-df x (.besh2 n x)))
\ No newline at end of file
Modified: src/matrix/level2-matrix-zge.lisp
==============================================================================
--- src/matrix/level2-matrix-zge.lisp (original)
+++ src/matrix/level2-matrix-zge.lisp Sun May 24 04:56:13 2009
@@ -51,7 +51,7 @@
b))
(defmacro def-binary-op-blas-complex (new old)
- ;;; TODO speed up for real numbers
+ ;;; TODO speed up for real numbers. Is it worth the work?
(let ((a (gensym "a"))
(b (gensym "b"))
(len (gensym "len"))
@@ -59,7 +59,7 @@
(store2 (gensym "store2"))
(i (gensym "i")))
`(progn
- (defmethod ,new ((,a matrix-zge) ,b)
+ (defmethod ,new ((,a matrix-zge) (,b number))
(let* ((,a (copy ,a))
(,store (matrix-store ,a))
(,b (coerce ,b '(complex double-float)))
@@ -71,7 +71,7 @@
(setf (ref-blas-complex-store ,store ,i 0 ,len)
(,old (ref-blas-complex-store ,store ,i 0 ,len) ,b)))
,a))
- (defmethod ,new (,a (,b matrix-zge))
+ (defmethod ,new ((,a number) (,b matrix-zge))
(let* ((,b (copy ,b))
(,store (matrix-store ,b))
(,a (coerce ,a '(complex double-float)))
@@ -91,6 +91,7 @@
(declare (type type-blas-store ,store)
(type type-blas-store ,store2)
(type type-blas-idx ,len))
+
(dotimes (,i ,len)
(setf (ref-blas-complex-store ,store ,i 0 ,len)
(,old (ref-blas-complex-store ,store ,i 0 ,len)
@@ -133,3 +134,65 @@
(def-binary-op-blas-complex .expt expt)
+(defmacro each-element-function-matrix-zge (x form)
+ "Applies a form on each element of an matrix-zge."
+ (let ((i (gensym))
+ (y (gensym)))
+ `(let* ((,y (copy ,x)))
+ (declare (type matrix-zge ,y))
+ (dotimes (,i (size ,y))
+ (let ((,x (vref ,y ,i)))
+ (declare (type (complex double-float) ,x))
+ (setf (vref ,y ,i)
+ ,form)))
+ ,y)))
+
+;;; Trignometric functions
+
+(defmethod .sin ((x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (sin x)))
+
+(defmethod .cos ((x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (cos x)))
+
+(defmethod .tan ((x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (tan x)))
+
+;;; Hyperbolic functions
+
+(defmethod .sinh ((x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (sinh x)))
+
+(defmethod .cosh ((x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (cosh x)))
+
+(defmethod .tanh ((x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (tanh x)))
+
+(defmethod .log ((x matrix-lisp-zge) &optional base)
+ (if base
+ (each-element-function-matrix-zge x (log x base))
+ (each-element-function-matrix-zge x (log x))))
+
+(defmethod .exp ((x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (exp x)))
+
+;;; Bessel functions
+
+(defmethod .besj (n (x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (.besj n x)))
+
+(defmethod .besy (n (x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (.besy n x)))
+
+(defmethod .besi (n (x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (.besi n x)))
+
+(defmethod .besk (n (x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (.besk n x)))
+
+(defmethod .besh1 (n (x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (.besh1 n x)))
+
+(defmethod .besh2 (n (x matrix-lisp-zge))
+ (each-element-function-matrix-zge x (.besh2 n x)))
More information about the lisplab-cvs
mailing list