[lisplab-cvs] r18 - src/matrix system
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Mon May 11 19:04:12 UTC 2009
Author: jivestgarden
Date: Mon May 11 15:04:11 2009
New Revision: 18
Log:
added operator defaults for arrays
Added:
src/matrix/level2-array-functions.lisp
Modified:
src/matrix/level2-generic.lisp
system/lisplab.asd
Added: src/matrix/level2-array-functions.lisp
==============================================================================
--- (empty file)
+++ src/matrix/level2-array-functions.lisp Mon May 11 15:04:11 2009
@@ -0,0 +1,288 @@
+;;; Lisplab, level2-array-functions.lisp
+;;; Level2, algbra functions on arrays
+;;; TOOD: Make fast methods also for integers.
+
+
+;;; Copyright (C) 2009 Joern Inge Vestgaarden
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License along
+;;; with this program; if not, write to the Free Software Foundation, Inc.,
+;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+(in-package :lisplab)
+
+(defmacro define-array-binary-operator (new old)
+ (let ((a (gensym))
+ (b (gensym))
+ (c (gensym))
+ (i (gensym)))
+ `(progn
+
+ ;; two array
+ (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 ((,c (copy ,a)))
+ (declare ((simple-array double-float) ,b ,c))
+ (dotimes (,i (min (size ,c) (size ,a)))
+ (setf (row-major-aref ,c ,i)
+ (,old (row-major-aref ,c ,i) (row-major-aref ,b ,i))))
+ ,c)
+ (let ((,c (create ,a t)))
+ (dotimes (,i (min (size ,c) (size ,a)))
+ (setf (vref ,c ,i)
+ (,new (vref ,c ,i) (vref ,b ,i))))
+ ,c)))
+
+ ;; array and number
+ (defmethod ,new ((,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)
+ (,old (row-major-aref ,c ,i) ,b)))
+ ,c)
+ (let ((,c (create ,a t)))
+ (dotimes (,i (size ,c))
+ (setf (vref ,c ,i)
+ (,new (vref ,c ,i) ,b)))
+ ,c)))
+
+ ;; number and array
+ (defmethod ,new ((,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)
+ (,old ,b (row-major-aref ,c ,i))))
+ ,c)
+ (let ((,c (create ,b t)))
+ (dotimes (,i (size ,c))
+ (setf (vref ,c ,i)
+ (,new ,b (vref ,c ,i))))
+ ,c))))))
+
+(define-array-binary-operator .add +)
+(define-array-binary-operator .sub -)
+(define-array-binary-operator .mul *)
+(define-array-binary-operator .div /)
+(define-array-binary-operator .expt expt)
+
+
+
+
+
+
+
+
+
+
+#|
+
+#+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 May 11 15:04:11 2009
@@ -29,72 +29,6 @@
(setf (mref a i i) (vref v i)))
a))
-(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)
-
(defmethod msum (m)
"Sums all elements of m."
(let ((sum 0))
@@ -140,37 +74,6 @@
(setf (vref a i) val))
val)
-(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)
-
(defmethod mmap (type f a &rest args)
(let ((b (new type (dim a) )))
(cond ((not args)
Modified: system/lisplab.asd
==============================================================================
--- system/lisplab.asd (original)
+++ system/lisplab.asd Mon May 11 15:04:11 2009
@@ -41,6 +41,7 @@
(:file "level1-funmat")
(:file "level2-interface")
+ (:file "level2-array-functions")
(:file "level2-generic")
(:file "level2-funmat")
(:file "level2-blas")
More information about the lisplab-cvs
mailing list