[lisplab-cvs] r63 - in src: core matrix
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Mon Jul 20 19:30:11 UTC 2009
Author: jivestgarden
Date: Mon Jul 20 15:30:10 2009
New Revision: 63
Log:
More ordinary functions
Modified:
src/core/level0-functions.lisp
src/core/level0-interface.lisp
src/matrix/level2-array-functions.lisp
src/matrix/level2-generic.lisp
src/matrix/level2-interface.lisp
src/matrix/level2-matrix-dge.lisp
src/matrix/level2-matrix-zge.lisp
Modified: src/core/level0-functions.lisp
==============================================================================
--- src/core/level0-functions.lisp (original)
+++ src/core/level0-functions.lisp Mon Jul 20 15:30:10 2009
@@ -56,6 +56,12 @@
"Generlized expt. Reduces the arguments with .expt."
(reduce #'.expt args))
+(defmethod .max ((a number) (b number))
+ (max a b))
+
+(defmethod .min ((a number) (b number))
+ (min a b))
+
(defmethod .abs ((a number))
(abs a))
@@ -100,8 +106,6 @@
(defmethod .sub ((a number) (b number))
(- a b))
-
-
(defmethod .expt ((a number) (b number))
(expt a b))
@@ -126,6 +130,21 @@
(defmethod .tan ((x real))
(tan (to-df x)))
+(defmethod .asin ((x real))
+ (asin (to-df x)))
+
+(defmethod .acos ((x number))
+ (acos x))
+
+(defmethod .acos ((x real))
+ (acos (to-df x)))
+
+(defmethod .atan ((x number))
+ (atan x))
+
+(defmethod .atan ((x real))
+ (atan (to-df x)))
+
(defmethod .log ((x number) &optional (base nil))
(if base
(log x base)
@@ -142,6 +161,19 @@
(defmethod .exp ((x real))
(exp (to-df x)))
+(defmethod .sqr ((x number))
+ (* x x))
+
+(defmethod .sqr ((x real))
+ (let ((x (to-df x)))
+ (* x x)))
+
+(defmethod .sqrt ((x number))
+ (sqrt x))
+
+(defmethod .sqrt ((x real))
+ (sqrt (to-df x)))
+
(defmethod .sinh ((x number))
(sinh x))
@@ -160,6 +192,24 @@
(defmethod .tanh ((x real))
(tanh (to-df x)))
+(defmethod .asinh ((x number))
+ (asinh x))
+
+(defmethod .asinh ((x real))
+ (asinh (to-df x)))
+
+(defmethod .acosh ((x number))
+ (acosh x))
+
+(defmethod .acosh ((x real))
+ (acosh (to-df x)))
+
+(defmethod .atanh ((x number))
+ (atanh x))
+
+(defmethod .atanh ((x real))
+ (atanh (to-df x)))
+
Modified: src/core/level0-interface.lisp
==============================================================================
--- src/core/level0-interface.lisp (original)
+++ src/core/level0-interface.lisp Mon Jul 20 15:30:10 2009
@@ -23,6 +23,7 @@
(export '(copy convert
scalar?
vector? matrix?
+ .max .min
.abs .imagpart .realpart
.= ./= .< .<= .> .>=
.add .add!
@@ -30,11 +31,13 @@
.div .div!
.sub .sub!
.expt .expt!
-
.conj
.sin .cos .tan
+ .asin .acos .atan
.sinh .cosh .tanh
+ .asinh .acosh .atanh
.log .exp
+ .sqr .sqrt
.Ai
.besj .besy .besi .besk .besh1 .besh2
.erf .erfc
@@ -56,6 +59,13 @@
(defgeneric convert (x type)
(:documentation "Converts the object to the specified type. Non-destructive."))
+
+(defgeneric .max (a b)
+ (:documentation "Generialized max."))
+
+(defgeneric .min (a b)
+ (:documentation "Generialized min."))
+
(defgeneric .abs (a)
(:documentation "Generialized abs."))
@@ -118,6 +128,7 @@
;;; Ordinary functions
+
(defgeneric .sin (x)
(:documentation "Sine function : sin(x)."))
@@ -127,12 +138,27 @@
(defgeneric .tan (x)
(:documentation "Tangent function : tan(x)."))
+(defgeneric .asin (x)
+ (:documentation "Inverse sine function : asin(x)."))
+
+(defgeneric .acos (x)
+ (:documentation "Inverse cosine function : acos(x)."))
+
+(defgeneric .atan (x)
+ (:documentation "Inverse tangent function : atan(x)."))
+
(defgeneric .log (x &optional base)
(:documentation "Logarithm function"))
(defgeneric .exp (x)
(:documentation "Exponential function : exp(x)."))
+(defgeneric .sqr (x)
+ (:documentation "Square."))
+
+(defgeneric .sqrt (x)
+ (:documentation "Square root."))
+
(defgeneric .sinh (x)
(:documentation "Hyperbolic sine function : sinh(x)."))
@@ -142,6 +168,15 @@
(defgeneric .tanh (x)
(:documentation "Hyperbolic tangent function : tanh(x)."))
+(defgeneric .asinh (x)
+ (:documentation "Inverse hyperbolic sine function : asinh(x)."))
+
+(defgeneric .acosh (x)
+ (:documentation "Inverse hyperbolic cosine function : acosh(x)."))
+
+(defgeneric .atanh (x)
+ (:documentation "Inverse hyperbolic tangent function : atanh(x)."))
+
;;; Special functions
Modified: src/matrix/level2-array-functions.lisp
==============================================================================
--- src/matrix/level2-array-functions.lisp (original)
+++ src/matrix/level2-array-functions.lisp Mon Jul 20 15:30:10 2009
@@ -153,6 +153,16 @@
(defmethod .tan ((x array))
(each-array-element-df-to-df x (.tan x)))
+(defmethod .asin ((x array))
+ (each-array-element-df-to-df x (.asin x)))
+
+(defmethod .acos ((x array))
+ (each-array-element-df-to-df x (.acos x)))
+
+(defmethod .atan ((x array))
+ (each-array-element-df-to-df x (.atan x)))
+
+
;;; Hyperbolic functions
(defmethod .sinh ((x array))
@@ -164,6 +174,17 @@
(defmethod .tanh ((x array))
(each-array-element-df-to-df x (.tanh x)))
+(defmethod .asinh ((x array))
+ (each-array-element-df-to-df x (.asinh x)))
+
+(defmethod .acosh ((x array))
+ (each-array-element-df-to-df x (.acosh x)))
+
+(defmethod .atanh ((x array))
+ (each-array-element-df-to-df x (.atanh x)))
+
+;;; Log and exponent
+
(defmethod .log ((x array) &optional base)
(each-array-element-df-to-df x (.log x base)))
@@ -192,243 +213,3 @@
(defmethod .besh2 (n (x array))
(each-array-element-df-to-complex-df x (.besh2 n x)))
-
-
-
-#|
-
-
-
-(defmacro define-array-binary-bool-operator (new old)
- (let ((a (gensym))
- (b (gensym))
- (i (gensym)))
- `(progn
-
- ;; two arrays
- (defmethod ,new ((,a array) (,b array))
- (if (and (eql (element-type ,a) 'double-float)
- (subtypep (type-of ,a) 'simple-array)
- (eql (element-type ,b) 'double-float)
- (subtypep (type-of ,b) 'simple-array))
- (let ()
- (declare (type (simple-array double-float) ,a ,b))
- (dotimes (,i (min (size ,a) (size ,b)) t)
- (unless (,old (row-major-aref ,a ,i)
- (row-major-aref ,b ,i))
- (return-from ,new nil))))
- (dotimes (,i (min (size ,a) (size ,b)) t)
- (unless (,new (vref ,a ,i)
- (vref ,b ,i))
- (return-from ,new nil)))))
-
- ;; array and number
- (defmethod ,new ((,a array) (,b number))
- (if (and (eql (element-type ,a) 'double-float)
- (subtypep (type-of ,a) 'simple-array)
- (eql (element-type ,b) 'double-float)
- (subtypep (type-of ,b) 'simple-array))
- (let ()
- (declare (type (simple-array double-float) ,a ,b))
- (dotimes (,i (min (size ,a) (size ,b)) t)
- (unless (,old (row-major-aref ,a ,i)
- (row-major-aref ,b ,i))
- (return-from ,new nil))))
- (dotimes (,i (min (size ,a) (size ,b)) t)
- (unless (,new (vref ,a ,i)
- (vref ,b ,i))
- (return-from ,new nil)))))
-
- ;; number and array
- (defmethod ,new ((,a number) (,b array))))))
-
-(define-array-binary-bool-operator .< <)
-
-
-#+nil (defun combine-types (a b)
- (typecase a
- (double-float
- (typecase b
- ((complex double-float) '(complex double-float))
- (complex 'complex)
- (t 'double-float)))
- ((complex double-float)
- (typecase b
- ((complex double-float) '(complex double-float))
- (complex 'complex)
- (t '(complex double-float))))
- (t t)))
-
-
-(defmethod .add ((a array) (b array))
- (if (and (eql (element-type a) 'double-float)
- (subtypep (type-of a) 'simple-array)
- (eql (element-type b) 'double-float)
- (subtypep (type-of b) 'simple-array))
- (let ((c (copy a)))
- (declare ((simple-array double-float) b c))
- (dotimes (i (min (size c) (size a)))
- (setf (row-major-aref c i)
- (+ (row-major-aref c i) (row-major-aref a i))))
- c)
- (let ((c (create a t)))
- (dotimes (i (min (size c) (size a)))
- (setf (vref c i)
- (.+ (vref c i) (vref a i))))
- c)))
-
-(defmethod .add ((a array) (b number))
- (if (and (eql (element-type a) 'double-float)
- (subtypep (type-of a) 'simple-array)
- (realp b))
- (let ((b (coerce b 'double-float))
- (c (copy a)))
- (declare ((simple-array double-float) c))
- (dotimes (i (size c))
- (setf (row-major-aref c i)
- (+ (row-major-aref c i) b)))
- c)
- (let ((c (create a t)))
- (dotimes (i (size c))
- (setf (vref c i)
- (.+ (vref c i) b)))
- c)))
-
-(defmethod .add ((a number) (b array))
- (if (and (eql (element-type b) 'double-float)
- (subtypep (type-of b) 'simple-array)
- (realp a))
- (let ((b (coerce a 'double-float))
- (c (copy b)))
- (declare ((simple-array double-float) c))
- (dotimes (i (size c))
- (setf (row-major-aref c i)
- (+ b (row-major-aref c i))))
- c)
- (let ((c (create a t)))
- (dotimes (i (min (size c) (size a)))
- (setf (vref c i)
- (.+ b (vref c i))))
- c)))
-
-
-
-
-
-(defmethod .add ((a array) (b number))
- (if (and (eql (element-type a) 'double-float)
- (subtypep (type-of a) 'simple-array)
- (realp
- (subtypep (type-of b) 'simple-array))
- (let ((c (copy a)))
- (declare ((simple-array double-float) a c))
- (dotimes (i (min (size c) (size a)))
- (incf (row-major-aref c i) (row-major-aref a i))))
- (let ((c (copy a)))
- (dotimes (i (min (size c) (size a)))
- (setf (vref c i)
- (.+ (vref c i) (vref a i))))
- c)))
-
-
-
-
-(defmethod .= (a b &optional (acc LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT ))
- (cond ((scalar? b)
- (dotimes (i (size a))
- (when (>= (abs (- (vref a i) b)) acc)
- (return-from .= nil)))
- t)
- ((scalar? a)
- (dotimes (i (size b))
- (when (>= (abs (- a (vref b i))) acc)
- (return-from .= nil)))
- t)
- ((= (size a) (size b))
- (dotimes (i (size a))
- (when (>= (abs (- (vref a i) (vref b i))) acc)
- (return-from .= nil)))
- t)
- (t nil)))
-
-(defmacro def-bin-bool-op-default (op)
- "Makes a non-specialized binary method with op which applies op on all elements
-and returns true if it holds for all elements, nil otherwise."
- (let ((a (gensym))
- (b (gensym))
- (i (gensym)))
- `(defmethod ,op (,a ,b)
- (cond ((scalar? ,b)
- (dotimes (,i (size ,a))
- (unless (,op (vref ,a ,i) ,b)
- (return-from ,op nil)))
- t)
- ((scalar? ,a)
- (dotimes (,i (size ,b))
- (unless(,op ,a (vref ,b ,i))
- (return-from ,op nil)))
- t)
- ((= (size ,a) (size ,b))
- (dotimes (,i (size ,a))
- (unless (,op (vref ,a ,i) (vref ,b ,i))
- (return-from ,op nil)))
- t)
- (t nil)))))
-
-(def-bin-bool-op-default .<)
-
-(def-bin-bool-op-default .<=)
-
-(def-bin-bool-op-default .>)
-
-(def-bin-bool-op-default .>=)
-
-(defmacro def-function-default (fun)
- (let ((a (gensym))
- (b (gensym))
- (i (gensym)))
- `(defmethod ,fun (,a)
- (let ((,b (copy ,a)))
- (dotimes (,i (size ,b))
- (setf (vref ,b ,i) (,fun (vref ,b ,i))))
- ,b))))
-
-(def-function-default .imagpart)
-
-(def-function-default .realpart)
-
-(def-function-default .abs)
-
-(defmacro def-bin-op-default (new)
- (let ((i (gensym "i"))
- (a (gensym "a"))
- (b (gensym "b")))
- `(defmethod ,new (,a ,b)
- (cond ((scalar? ,a)
- (let ((,b (copy ,b)))
- (dotimes (,i (size ,b))
- (setf (vref ,b ,i) (,new ,a (vref ,b ,i))))
- ,b))
- ((scalar? ,b)
- (let ((,a (copy ,a)))
- (dotimes (,i (size ,a))
- (setf (vref ,a ,i) (,new (vref ,a ,i) ,b)))
- ,a))
- (t
- (let ((,a (copy ,a)))
- (dotimes (,i (size ,a))
- (setf (vref ,a ,i) (,new (vref ,a ,i) (vref ,b ,i))))
- ,a))))))
-
-(def-bin-op-default .add)
-
-(def-bin-op-default .mul)
-
-(def-bin-op-default .sub)
-
-(def-bin-op-default .div)
-
-(def-bin-op-default .expt)
-
-
-|#
\ No newline at end of file
Modified: src/matrix/level2-generic.lisp
==============================================================================
--- src/matrix/level2-generic.lisp (original)
+++ src/matrix/level2-generic.lisp Mon Jul 20 15:30:10 2009
@@ -47,6 +47,26 @@
(setf (mref b i j) (funcall converter (mref a i j))))
b))
+(defmethod sub-matrix (m rr cc)
+ (unless (cddr rr)
+ (setf rr (cons (car rr) (cons 1 (cdr rr)))))
+ (unless (cddr cc)
+ (setf cc (cons (car cc) (cons 1 (cdr cc)))))
+ (destructuring-bind (r0 r-step r1) rr
+ (destructuring-bind (c0 c-step c1) cc
+ (when (>= r1 (rows m))
+ (setf r1 (1- (rows m))))
+ (when (>= c1 (cols m))
+ (setf c1 (1- (cols m))))
+ (let* ((rows (1+ (floor (- r1 r0) r-step)))
+ (cols (1+ (floor (- c1 c0) c-step)))
+ (m1 (mcreate m 0 (list rows cols))))
+ (dotimes (i rows)
+ (dotimes (j cols)
+ (setf (mref m1 i j)
+ (mref m (+ r0 (* r-step i)) (+ c0 (* c-step j))))))
+ m1))))
+
(defmethod .some (pred (a matrix-base) &rest args)
(dotimes (i (size a))
(when (apply pred (mapcar (lambda (x) (vref x i)) (cons a args)))
@@ -292,12 +312,21 @@
(defmethod .tanh ((x matrix-ge))
(each-element-function-matrix-ge x (.tanh x)))
+;;; Logarithms and exponents
+
(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)))
+(defmethod .sqr ((x matrix-ge))
+ (each-element-function-matrix-ge x (.sqr x)))
+
+(defmethod .sqrt ((x matrix-ge))
+ (each-element-function-matrix-ge x (.sqrt x)))
+
+
;;; Bessel functions
(defmethod .besj (n (x matrix-ge))
Modified: src/matrix/level2-interface.lisp
==============================================================================
--- src/matrix/level2-interface.lisp (original)
+++ src/matrix/level2-interface.lisp Mon Jul 20 15:30:10 2009
@@ -40,6 +40,7 @@
view-vector-as-matrix
view-transpose
msum mmin mmax mabsmin mabsmax
+ sub-matrix ; To level3 ?
circ-shift
pad-shift))
@@ -49,6 +50,10 @@
(defgeneric .every (pred a &rest matrices)
(:documentation "Generalizes every."))
+(defgeneric sub-matrix (m rr cc)
+ (:documentation "Copies a sub matrix of m. The format of rr = (start stop) or rr = (start step stop)
+and the same for the coulumns."))
+
(defgeneric copy-contents (a b &optional converter)
(:documentation "Copies all elements from a to b."))
Modified: src/matrix/level2-matrix-dge.lisp
==============================================================================
--- src/matrix/level2-matrix-dge.lisp (original)
+++ src/matrix/level2-matrix-dge.lisp Mon Jul 20 15:30:10 2009
@@ -40,6 +40,16 @@
(matrix-store a) (mapcar #'matrix-store args))
b))
+(defmethod msum ((m matrix-base-dge))
+ (let ((sum 0.0)
+ (m0 (matrix-store m)))
+ (declare (type double-float sum)
+ (type type-blas-store m0))
+ (dotimes (i (length m0))
+ (incf sum (aref m0 i)))
+ sum))
+
+
(defmethod .imagpart ((a matrix-base-dge))
(mcreate a 0))
@@ -114,6 +124,10 @@
(def-binary-op-matrix-base-dge .expt expt)
+(def-binary-op-matrix-base-dge .max max)
+
+(def-binary-op-matrix-base-dge .min min)
+
(defmacro each-matrix-element-df-to-df (x form)
"Applies a form on each element of an matrix-dge. The form must
make real output for real arguments"
@@ -155,6 +169,15 @@
(defmethod .tan ((x matrix-base-dge))
(each-matrix-element-df-to-df x (tan x)))
+(defmethod .asin ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (asin x)))
+
+(defmethod .acos ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (acos x)))
+
+(defmethod .atan ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (atan x)))
+
;;; Hyperbolic functions
(defmethod .sinh ((x matrix-base-dge))
@@ -166,6 +189,17 @@
(defmethod .tanh ((x matrix-base-dge))
(each-matrix-element-df-to-df x (tanh x)))
+(defmethod .asinh ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (asinh x)))
+
+(defmethod .acosh ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (acosh x)))
+
+(defmethod .atanh ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (atanh x)))
+
+;;; Logarithm and exponent
+
(defmethod .log ((x matrix-base-dge) &optional base)
(if base
(each-matrix-element-df-to-df x (log x base))
@@ -174,6 +208,12 @@
(defmethod .exp ((x matrix-base-dge))
(each-matrix-element-df-to-df x (exp x)))
+(defmethod .sqr ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (* x x)))
+
+(defmethod .sqrt ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (sqrt x)))
+
;;; Bessel functions
(defmethod .besj (n (x matrix-base-dge))
@@ -192,4 +232,16 @@
(each-matrix-element-df-to-complex-df x (.besh1 n x)))
(defmethod .besh2 (n (x matrix-base-dge))
- (each-matrix-element-df-to-complex-df x (.besh2 n x)))
\ No newline at end of file
+ (each-matrix-element-df-to-complex-df x (.besh2 n x)))
+
+;;; Other spacial functions
+
+(defmethod .erf ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (.erf x)))
+
+(defmethod .erfc ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (.erfc x)))
+
+(defmethod .gamma ((x matrix-base-dge))
+ (each-matrix-element-df-to-df x (.gamma x)))
+
Modified: src/matrix/level2-matrix-zge.lisp
==============================================================================
--- src/matrix/level2-matrix-zge.lisp (original)
+++ src/matrix/level2-matrix-zge.lisp Mon Jul 20 15:30:10 2009
@@ -32,6 +32,17 @@
:rows (rows matrix)
:cols (cols matrix)))
+(defmethod msum ((m matrix-base-zge))
+ (let ((sum-r 0.0)
+ (sum-i 0.0)
+ (m0 (matrix-store m)))
+ (declare (type double-float sum-r sum-i)
+ (type type-blas-store m0))
+ (loop for i from 0 below (length m0) by 2 do
+ (incf sum-r (aref m0 i))
+ (incf sum-i (aref m0 (1+ i))))
+ (complex sum-r sum-i)))
+
(defmethod .imagpart ((a matrix-base-zge))
(let* ((description (create-matrix-description a :et :d))
(b (make-matrix-instance description (dim a) 0)))
@@ -161,6 +172,15 @@
(defmethod .tan ((x matrix-base-zge))
(each-element-function-matrix-base-zge x (tan x)))
+(defmethod .asin ((x matrix-base-zge))
+ (each-element-function-matrix-base-zge x (asin x)))
+
+(defmethod .acos ((x matrix-base-zge))
+ (each-element-function-matrix-base-zge x (acos x)))
+
+(defmethod .atan ((x matrix-base-zge))
+ (each-element-function-matrix-base-zge x (atan x)))
+
;;; Hyperbolic functions
(defmethod .sinh ((x matrix-base-zge))
@@ -172,6 +192,17 @@
(defmethod .tanh ((x matrix-base-zge))
(each-element-function-matrix-base-zge x (tanh x)))
+(defmethod .asinh ((x matrix-base-zge))
+ (each-element-function-matrix-base-zge x (asinh x)))
+
+(defmethod .acosh ((x matrix-base-zge))
+ (each-element-function-matrix-base-zge x (acosh x)))
+
+(defmethod .atanh ((x matrix-base-zge))
+ (each-element-function-matrix-base-zge x (atanh x)))
+
+;;; Logarithm and exponent
+
(defmethod .log ((x matrix-base-zge) &optional base)
(if base
(each-element-function-matrix-base-zge x (log x base))
@@ -180,6 +211,12 @@
(defmethod .exp ((x matrix-base-zge))
(each-element-function-matrix-base-zge x (exp x)))
+(defmethod .sqr ((x matrix-base-zge))
+ (each-element-function-matrix-base-zge x (* x x)))
+
+(defmethod .sqrt ((x matrix-base-zge))
+ (each-element-function-matrix-base-zge x (sqrt x)))
+
;;; Bessel functions
(defmethod .besj (n (x matrix-base-zge))
More information about the lisplab-cvs
mailing list