[lisplab-cvs] r24 - in src: core matrix
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Sat May 16 15:01:13 UTC 2009
Author: jivestgarden
Date: Sat May 16 11:01:12 2009
New Revision: 24
Log:
prepreared for new matrix object model
Added:
src/matrix/level1-constructors.lisp
src/matrix/level2-matrix-dge.lisp
Modified:
src/core/level0-basic.lisp
src/matrix/level1-blas-real.lisp
src/matrix/level1-classes.lisp
src/matrix/level1-generic.lisp
src/matrix/level1-interface.lisp
src/matrix/level1-matrix.lisp
src/matrix/level1-util.lisp
Modified: src/core/level0-basic.lisp
==============================================================================
--- src/core/level0-basic.lisp (original)
+++ src/core/level0-basic.lisp Sat May 16 11:01:12 2009
@@ -21,9 +21,9 @@
(in-package :lisplab)
-(export '(*lisplab-print-size* in-dir ))
+(export '(in-dir ))
-(setf *READ-DEFAULT-FLOAT-FORMAT* 'double-float)
+(setf *READ-DEFAULT-FLOAT-FORMAT* 'double-float) ; TODO make part of pacakge import?
(defmacro with-gensyms ((&rest names) . body)
`(let ,(loop for n in names collect `(,n (gensym)))
Modified: src/matrix/level1-blas-real.lisp
==============================================================================
--- src/matrix/level1-blas-real.lisp (original)
+++ src/matrix/level1-blas-real.lisp Sat May 16 11:01:12 2009
@@ -97,6 +97,3 @@
(defun rnew (value rows &optional (cols 1))
"Creates a new blas-real matrix"
(new 'blas-real (list rows cols) t value))
-
-
-
Modified: src/matrix/level1-classes.lisp
==============================================================================
--- src/matrix/level1-classes.lisp (original)
+++ src/matrix/level1-classes.lisp Sat May 16 11:01:12 2009
@@ -42,7 +42,7 @@
:initform 'double-float
:reader element-type)))
-;;; A way to solve conflicts if there is one foreign and one local implementation
+;;; A way to solve conflicts if there is one foreign and one native implementation
(defclass matrix-implementation-base () ())
@@ -119,8 +119,7 @@
(with-slots (rows cols size matrix-store) m
(setf size (* rows cols))
(unless matrix-store
- ;; Todo: fix initialization!
- (setf matrix-store (allocate-real-store (* 2 size) value)))))
+ (setf matrix-store (allocate-complex-store size value)))))
(defclass matrix-lisp-zge (matrix-implementation-lisp matrix-base-zge) ())
@@ -131,12 +130,16 @@
;;; Double float diagonal matrices
+;;; TODO
+
(defclass matrix-base-ddi
(matrix-structure-diagonal matrix-element-double-float matrix-implementation-base)
())
;;; Complex double float diagonal matrices
+;;; TODO
+
(defclass matrix-base-zdi
(matrix-structure-diagonal matrix-element-complex-double-float matrix-implementation-base)
())
Added: src/matrix/level1-constructors.lisp
==============================================================================
--- (empty file)
+++ src/matrix/level1-constructors.lisp Sat May 16 11:01:12 2009
@@ -0,0 +1,20 @@
+;;; Lisplab, level1-constructors.lisp
+;;;
+
+;;; 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)
\ No newline at end of file
Modified: src/matrix/level1-generic.lisp
==============================================================================
--- src/matrix/level1-generic.lisp (original)
+++ src/matrix/level1-generic.lisp Sat May 16 11:01:12 2009
@@ -19,6 +19,10 @@
(in-package :lisplab)
+(defmethod new (class dim &optional (element-type t) (value 0))
+ ;;; TODO get rid of this default that calls the new constructor
+ (mnew class dim element-type value))
+
(defmethod scalar? (x)
(numberp x))
Modified: src/matrix/level1-interface.lisp
==============================================================================
--- src/matrix/level1-interface.lisp (original)
+++ src/matrix/level1-interface.lisp Sat May 16 11:01:12 2009
@@ -20,8 +20,8 @@
(in-package :lisplab)
-(export '( *lisplab-print-size*
- vector? matrix? new ref mref vref
+(export '(*lisplab-print-size*
+ vector? matrix? new mnew ref mref vref
dim element-type create
size rank rows cols ))
@@ -34,7 +34,10 @@
(:documentation "A matrix is a object whose elements are accesible with mref."))
(defgeneric new (class dim &optional element-type value)
- (:documentation "Creates a new matrix filled with numeric arguments."))
+ (:documentation "Deprecated. Use mnew in stead. Creates a new matrix filled with numeric arguments."))
+
+(defgeneric mnew (class dim &optional element-type value)
+ (:documentation "General matrix constructor. Creates a new matrix filled with numeric arguments."))
(defgeneric ref (matrix &rest subscripts)
(:documentation "A general accessor."))
Modified: src/matrix/level1-matrix.lisp
==============================================================================
--- src/matrix/level1-matrix.lisp (original)
+++ src/matrix/level1-matrix.lisp Sat May 16 11:01:12 2009
@@ -45,6 +45,9 @@
;;; Spcialized for blas-dge
+(defmethod mnew ((class (eql 'matrix-dge)) dim &optional (element-type t) (value 0))
+ (make-matrix-new-instance class dim element-type value))
+
(defmethod mref ((matrix matrix-base-dge) row col)
(aref (the type-blas-store (matrix-store matrix))
(truly-the type-blas-idx (column-major-idx (truly-the type-blas-idx row)
Modified: src/matrix/level1-util.lisp
==============================================================================
--- src/matrix/level1-util.lisp (original)
+++ src/matrix/level1-util.lisp Sat May 16 11:01:12 2009
@@ -20,6 +20,17 @@
(in-package :lisplab)
+(defun make-matrix-new-instance (class dim &optional (element-type t) (value 0))
+ (declare (ignore element-type))
+ (unless (consp dim) (setf dim (list dim 1)))
+ (let ((rows (car dim))
+ (cols (if (cdr dim) (cadr dim) 1)))
+ (make-instance class
+ :value value
+ :rows rows
+ :cols cols)))
+
+
(deftype type-blas-store ()
'(simple-array double-float (*)))
@@ -117,4 +128,14 @@
(declare (type-blas-idx idx))
(setf (aref store idx) (realpart value)
(aref store (1+ idx)) (imagpart value))
- value))
\ No newline at end of file
+ value))
+
+(defun allocate-complex-store (size &optional (value 0.0))
+ (let* ((2size (* 2 size))
+ (rv (coerce (realpart value) 'double-float))
+ (iv (coerce (imagpart value) 'double-float))
+ (store (allocate-real-store 2size iv)))
+ (loop for i from 0 below 2size by 2 do
+ (setf (aref store i) rv))
+ store))
+
Added: src/matrix/level2-matrix-dge.lisp
==============================================================================
--- (empty file)
+++ src/matrix/level2-matrix-dge.lisp Sat May 16 11:01:12 2009
@@ -0,0 +1,99 @@
+;;; Lisplab, level2-matrix-dge.lisp
+;;; Optimizations for blas real matrices.
+
+;;; 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)
+
+(defmethod copy ((matrix matrix-base-dge))
+ (make-instance (class-name (class-of matrix))
+ :store (copy-seq (matrix-store matrix))
+ :rows (rows matrix)
+ :cols (cols matrix)))
+
+;; Maybe this should done general base on element type class?
+#+todo (defmethod convert ((a blas-real) 'blas-complex)
+ (let* ((b (cnew 0 (rows a) (cols a)))
+ (store-a (store a))
+ (store-b (store b)))
+ (declare (type type-blas-store store-a store-b))
+ (dotimes (i (the type-blas-idx (size a)))
+ (declare (type type-blas-idx i))
+ (setf (aref store-b (truly-the type-blas-idx (* i 2))) (aref store-a i)))
+ b))
+
+(defmacro def-binary-op-matrix-lisp-dge (new old)
+ (let ((a (gensym "a"))
+ (b (gensym "b"))
+ (len (gensym "len"))
+ (store (gensym "store"))
+ (store2 (gensym "store2"))
+ (i (gensym "i")))
+ `(progn
+ (defmethod ,new ((,a matrix-lisp-dge) ,b)
+ (let* ((,a (copy ,a))
+ (,store (matrix-store ,a))
+ (,b (coerce ,b 'double-float))
+ (,len (size ,a)))
+ (declare (type double-float ,b)
+ (type type-blas-store ,store)
+ (type type-blas-idx ,len))
+ (dotimes (,i ,len)
+ (setf (aref ,store ,i) (,old (aref ,store ,i) ,b)))
+ ,a))
+ (defmethod ,new (,a (,b matrix-lisp-dge))
+ (let* ((,b (copy ,b))
+ (,store (matrix-store ,b))
+ (,a (coerce ,a 'double-float))
+ (,len (size ,b)))
+ (declare (type double-float ,a)
+ (type type-blas-store ,store)
+ (type type-blas-idx ,len))
+ (dotimes (,i ,len)
+ (setf (aref ,store ,i) (,old ,a (aref ,store ,i))))
+ ,b))
+ (defmethod ,new ((,a matrix-lisp-dge) (,b matrix-lisp-dge))
+ (let* ((,a (copy ,a))
+ (,store (matrix-store ,a))
+ (,store2 (matrix-store ,b))
+ (,len (size ,a)))
+ (declare (type type-blas-store ,store)
+ (type type-blas-store ,store2)
+ (type type-blas-idx ,len))
+ (dotimes (,i ,len)
+ (setf (aref ,store ,i) (,old (aref ,store ,i) (aref ,store2 ,i))))
+ ,a)))))
+
+(def-binary-op-matrix-lisp-dge .add +)
+
+(def-binary-op-matrix-lisp-dge .mul *)
+
+(def-binary-op-matrix-lisp-dge .sub -)
+
+(def-binary-op-matrix-lisp-dge .div /)
+
+(def-binary-op-matrix-lisp-dge .expt expt)
+
+(defmethod .map (f (a matrix-lisp-dge) &rest args)
+ (let ((b (copy a)))
+ (apply #'map-into
+ (matrix-store b)
+ (lambda (&rest args)
+ (coerce (apply f args) 'double-float))
+ (matrix-store a) (mapcar #'store args))
+ b))
+
More information about the lisplab-cvs
mailing list