[lisplab-cvs] r20 - src/matrix system
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Sat May 16 08:54:55 UTC 2009
Author: jivestgarden
Date: Sat May 16 04:54:55 2009
New Revision: 20
Log:
started a new object model for matrices
Added:
src/matrix/level1-classes.lisp
src/matrix/level1-matrix.lisp
src/matrix/level1-util.lisp
Modified:
Makefile
src/matrix/level1-blas-complex.lisp
src/matrix/level1-blas-real.lisp
src/matrix/level1-blas.lisp
system/lisplab.asd
Modified: Makefile
==============================================================================
--- Makefile (original)
+++ Makefile Sat May 16 04:54:55 2009
@@ -1,6 +1,6 @@
first:
- echo "Plase specify target."
+ echo "Please specify target."
touch:
touch system/lisplab.asd
Modified: src/matrix/level1-blas-complex.lisp
==============================================================================
--- src/matrix/level1-blas-complex.lisp (original)
+++ src/matrix/level1-blas-complex.lisp Sat May 16 04:54:55 2009
@@ -24,46 +24,6 @@
(defclass blas-complex (blas) ())
-(declaim (ftype (function
- (type-blas-store
- type-blas-idx
- type-blas-idx
- type-blas-idx)
- (complex double-float))
- ref-blas-complex-store))
-
-(declaim (ftype (function
- ((complex double-float)
- type-blas-store
- type-blas-idx
- type-blas-idx
- type-blas-idx
- )
- (complex double-float))
- (setf ref-blas-complex-store)))
-
-(declaim (inline ref-blas-complex-store (setf ref-blas-complex-store)))
-
-(defun ref-blas-complex-store (store row col rows)
- "Accessor for the complet blas store"
- (let ((idx (truly-the type-blas-idx
- (* 2 (column-major-idx (truly-the type-blas-idx row)
- (truly-the type-blas-idx col)
- rows)))))
- (declare (type-blas-idx idx))
- (complex (aref store idx)
- (aref store (1+ idx)))))
-
-(defun (setf ref-blas-complex-store) (value store row col rows)
- (let ((idx (truly-the type-blas-idx
- (* 2 (column-major-idx (truly-the type-blas-idx row)
- (truly-the type-blas-idx col)
- rows)))))
- (declare (type-blas-idx idx))
- (setf (aref store idx) (realpart value)
- (aref store (1+ idx)) (imagpart value))
- value))
-
(defmethod new ((class (eql 'blas-complex)) dim &optional type value)
(declare (ignore type))
(unless (consp dim) (setf dim (list dim 1)))
Modified: src/matrix/level1-blas-real.lisp
==============================================================================
--- src/matrix/level1-blas-real.lisp (original)
+++ src/matrix/level1-blas-real.lisp Sat May 16 04:54:55 2009
@@ -24,47 +24,6 @@
(defclass blas-real (blas) ())
-(declaim (ftype (function
- (type-blas-store
- type-blas-idx
- type-blas-idx
- type-blas-idx)
- double-float)
- ref-blas-real-store))
-
-(declaim (ftype (function
- (double-float
- type-blas-store
- type-blas-idx
- type-blas-idx
- type-blas-idx
- )
- double-float)
- (setf ref-blas-real-store)))
-
-(declaim (inline ref-blas-real-store (setf ref-blas-real-store)))
-
-(defun ref-blas-real-store (store row col rows)
- "Accessor for the real blas store"
- (aref (truly-the type-blas-store store)
- (truly-the type-blas-idx
- (column-major-idx (truly-the type-blas-idx row)
- (truly-the type-blas-idx col)
- rows))))
-
-(defun (setf ref-blas-real-store) (value store row col rows)
- (setf (aref (truly-the type-blas-store store)
- (truly-the type-blas-idx
- (column-major-idx (truly-the type-blas-idx row)
- (truly-the type-blas-idx col)
- rows)))
- value))
-
-(defun allocate-real-store (size &optional (initial-element 0.0))
- (make-array size :element-type 'double-float
- :initial-element
- (coerce initial-element 'double-float)))
-
(defmethod new ((class (eql 'blas-real)) dim &optional type value)
(if (and type (subtypep type 'complex))
(new 'blas-complex dim type value)
Modified: src/matrix/level1-blas.lisp
==============================================================================
--- src/matrix/level1-blas.lisp (original)
+++ src/matrix/level1-blas.lisp Sat May 16 04:54:55 2009
@@ -19,23 +19,6 @@
(in-package :lisplab)
-(deftype type-blas-store ()
- '(simple-array double-float (*)))
-
-(deftype type-blas-idx ()
- '(MOD 536870911))
-
-(declaim (ftype (function
- (type-blas-idx
- type-blas-idx
- type-blas-idx)
- type-blas-idx)
- column-major-idx))
-
-(declaim (inline column-major-idx))
-(defun column-major-idx (i j rows)
- (truly-the type-blas-idx (+ i (truly-the type-blas-idx (* j rows)))))
-
(defclass blas ()
((store
:initarg :store
@@ -98,3 +81,9 @@
(0 (rows matrix))
(1 (cols matrix)))
(list (rows matrix) (cols matrix))))
+
+
+
+
+
+
Added: src/matrix/level1-classes.lisp
==============================================================================
--- (empty file)
+++ src/matrix/level1-classes.lisp Sat May 16 04:54:55 2009
@@ -0,0 +1,149 @@
+;;; Lisplab, level1-classes.lisp
+;;; Level1, matrix classes
+;;;
+
+;;; 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)
+
+(defclass matrix-base () ())
+
+;;; The matrix element tells the element type of the matrix
+
+(defclass matrix-element-base ()
+ ((element-type
+ :allocation :class
+ :initform t
+ :reader element-type)))
+
+(defclass matrix-element-complex-double-float (matrix-element-base)
+ ((element-type
+ :allocation :class
+ :initform '(complex double-float)
+ :reader element-type)))
+
+(defclass matrix-element-double-float (matrix-element-complex-double-float)
+ ((element-type
+ :allocation :class
+ :initform 'double-float
+ :reader element-type)))
+
+;;; A way to solve conflicts if there is one foreign and one local implementation
+
+(defclass matrix-implementation-base () ())
+
+(defclass matrix-implementation-lisp (matrix-implementation-base) ())
+
+(defclass matrix-implementation-blas (matrix-implementation-lisp) ())
+
+;;; The matrix structure tells the structure of the matrix
+
+(defclass matrix-structure-base (matrix-base) ())
+
+(defclass matrix-structure-general (matrix-structure-base)
+ ((rows
+ :initarg :rows
+ :initform 0
+ :reader rows
+ :type type-blas-idx
+ :documentation "Number of rows in the matrix")
+ (cols
+ :initarg :cols
+ :initform 0
+ :reader cols
+ :type type-blas-idx
+ :documentation "Number of columns in the matrix")
+ (size
+ :reader size
+ :type type-blas-idx)))
+
+(defclass matrix-structure-diagonal (matrix-structure-base)
+ ((size
+ :initarg :size
+ :initform 0
+ :accessor size
+ :type type-blas-idx)))
+
+
+;;; The actual classes ment for instantiation
+
+
+;;; Double float general matrices
+
+(defclass matrix-base-dge
+ (matrix-structure-general matrix-element-double-float matrix-implementation-base)
+ ((matrix-store
+ :initarg :store
+ :initform nil
+ :reader matrix-store
+ :type type-blas-store)))
+
+(defmethod initialize-instance :after ((m matrix-base-dge) &key (value 0))
+ (with-slots (rows cols size matrix-store) m
+ (setf size (* rows cols))
+ (unless matrix-store
+ (setf matrix-store (allocate-real-store size value)))))
+
+(defclass matrix-lisp-dge (matrix-implementation-lisp matrix-base-dge) ())
+
+(defclass matrix-dge (matrix-implementation-blas matrix-lisp-dge) ())
+
+(defclass matrix-dge (matrix-blas-dge) ()
+ (:documentation "General matrix with double float elements."))
+
+;;; Complex double float general matrices
+
+(defclass matrix-base-zge
+ (matrix-structure-general matrix-element-complex-double-float matrix-implementation-base)
+ ((matrix-store
+ :initarg :store
+ :initform nil
+ :accessor matrix-store
+ :type type-blas-store)))
+
+(defmethod initialize-instance :after ((m matrix-base-zge) &key (value 0))
+ (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)))))
+
+(defclass matrix-lisp-zge (matrix-implementation-lisp matrix-base-zge) ())
+
+(defclass matrix-blas-zge (matrix-implementation-blas matrix-lisp-zge) ())
+
+(defclass matrix-zge (matrix-blas-zge) ()
+ (:documentation "General matrix with complex double float elements."))
+
+;;; Double float diagonal matrices
+
+(defclass matrix-base-ddi
+ (matrix-structure-diagonal matrix-element-double-float matrix-implementation-base)
+ ())
+
+;;; Complex double float diagonal matrices
+
+(defclass matrix-base-zdi
+ (matrix-structure-diagonal matrix-element-complex-double-float matrix-implementation-base)
+ ())
+
+
+
+
+
+
+
Added: src/matrix/level1-matrix.lisp
==============================================================================
--- (empty file)
+++ src/matrix/level1-matrix.lisp Sat May 16 04:54:55 2009
@@ -0,0 +1,90 @@
+;;; Lisplab, level1-matrix.lisp
+;;; Level1, matrix basic methods
+;;;
+
+;;; 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)
+
+;;; Generic methods
+
+(defmethod dim ((matrix matrix-base) &optional direction)
+ (if direction
+ (ecase direction
+ (0 (rows matrix))
+ (1 (cols matrix)))
+ (list (rows matrix) (cols matrix))))
+
+(defmethod print-object ((matrix matrix-base) stream)
+ (print-unreadable-object (matrix stream :type t :identity t)
+ (let ((rows (min (rows matrix) *lisplab-print-size*))
+ (cols (min (cols matrix) *lisplab-print-size*)))
+ (format stream " ~Ax~A~&" (rows matrix) (cols matrix))
+ (dotimes (i rows)
+ (dotimes (j cols)
+ (format stream "~S " (mref matrix i j)))
+ (when (< cols (cols matrix))
+ (format stream "..."))
+ (princ #\Newline stream))
+ (when (< rows (rows matrix))
+ (format stream "...~%")))))
+
+;;; Spcialized for blas-dge
+
+(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)
+ (truly-the type-blas-idx col)
+ (rows matrix)))))
+
+(defmethod (setf mref) (value (matrix matrix-base-dge) row col)
+ (setf (aref (the type-blas-store (matrix-store matrix))
+ (column-major-idx (truly-the type-blas-idx row)
+ (truly-the type-blas-idx col)
+ (rows matrix)))
+ (truly-the double-float (coerce value 'double-float))))
+
+(defmethod vref ((matrix matrix-base-dge) idx)
+ (aref (the type-blas-store (matrix-store matrix)) idx))
+
+(defmethod (setf vref) (value (matrix matrix-base-dge) idx)
+ (setf (aref (the type-blas-store (matrix-store matrix)) idx)
+ (the double-float (coerce value 'double-float))))
+
+;;; Spcialized for blas-zge
+
+(defmethod mref ((matrix matrix-base-zge) row col)
+ (ref-blas-complex-store (matrix-store matrix)
+ (column-major-idx row col (rows matrix))
+ 0 1))
+
+(defmethod (setf mref) (value (matrix matrix-base-zge) row col)
+ (setf (ref-blas-complex-store (matrix-store matrix)
+ (column-major-idx row col (rows matrix))
+ 0 1)
+ (coerce value '(complex double-float)))
+ value)
+
+(defmethod vref ((matrix matrix-base-zge) i)
+ (ref-blas-complex-store (store matrix) i 0 1))
+
+(defmethod (setf vref) (value (matrix matrix-base-zge) i)
+ (setf (ref-blas-complex-store (matrix-store matrix) i 0 1)
+ (coerce value '(complex double-float)))
+ value)
+
+
Added: src/matrix/level1-util.lisp
==============================================================================
--- (empty file)
+++ src/matrix/level1-util.lisp Sat May 16 04:54:55 2009
@@ -0,0 +1,120 @@
+;;; Lisplab, level1-util.lisp
+;;; Level1, utility functions for matrix defenitions
+;;;
+
+;;; 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)
+
+(deftype type-blas-store ()
+ '(simple-array double-float (*)))
+
+(deftype type-blas-idx ()
+ '(MOD 536870911))
+
+(declaim (ftype (function
+ (type-blas-idx
+ type-blas-idx
+ type-blas-idx)
+ type-blas-idx)
+ column-major-idx))
+
+(declaim (inline column-major-idx))
+(defun column-major-idx (i j rows)
+ (truly-the type-blas-idx (+ i (truly-the type-blas-idx (* j rows)))))
+
+(declaim (ftype (function
+ (type-blas-store
+ type-blas-idx
+ type-blas-idx
+ type-blas-idx)
+ double-float)
+ ref-blas-real-store))
+
+(declaim (ftype (function
+ (double-float
+ type-blas-store
+ type-blas-idx
+ type-blas-idx
+ type-blas-idx
+ )
+ double-float)
+ (setf ref-blas-real-store)))
+
+(declaim (inline ref-blas-real-store (setf ref-blas-real-store)))
+
+(defun ref-blas-real-store (store row col rows)
+ "Accessor for the real blas store"
+ (aref (truly-the type-blas-store store)
+ (truly-the type-blas-idx
+ (column-major-idx (truly-the type-blas-idx row)
+ (truly-the type-blas-idx col)
+ rows))))
+
+(defun (setf ref-blas-real-store) (value store row col rows)
+ (setf (aref (truly-the type-blas-store store)
+ (truly-the type-blas-idx
+ (column-major-idx (truly-the type-blas-idx row)
+ (truly-the type-blas-idx col)
+ rows)))
+ value))
+
+(defun allocate-real-store (size &optional (initial-element 0.0))
+ (make-array size :element-type 'double-float
+ :initial-element
+ (coerce initial-element 'double-float)))
+
+
+(declaim (ftype (function
+ (type-blas-store
+ type-blas-idx
+ type-blas-idx
+ type-blas-idx)
+ (complex double-float))
+ ref-blas-complex-store))
+
+(declaim (ftype (function
+ ((complex double-float)
+ type-blas-store
+ type-blas-idx
+ type-blas-idx
+ type-blas-idx
+ )
+ (complex double-float))
+ (setf ref-blas-complex-store)))
+
+(declaim (inline ref-blas-complex-store (setf ref-blas-complex-store)))
+
+(defun ref-blas-complex-store (store row col rows)
+ "Accessor for the complet blas store"
+ (let ((idx (truly-the type-blas-idx
+ (* 2 (column-major-idx (truly-the type-blas-idx row)
+ (truly-the type-blas-idx col)
+ rows)))))
+ (declare (type-blas-idx idx))
+ (complex (aref store idx)
+ (aref store (1+ idx)))))
+
+(defun (setf ref-blas-complex-store) (value store row col rows)
+ (let ((idx (truly-the type-blas-idx
+ (* 2 (column-major-idx (truly-the type-blas-idx row)
+ (truly-the type-blas-idx col)
+ rows)))))
+ (declare (type-blas-idx idx))
+ (setf (aref store idx) (realpart value)
+ (aref store (1+ idx)) (imagpart value))
+ value))
\ No newline at end of file
Modified: system/lisplab.asd
==============================================================================
--- system/lisplab.asd (original)
+++ system/lisplab.asd Sat May 16 04:54:55 2009
@@ -32,6 +32,7 @@
:components
(
(:file "level1-interface")
+ (:file "level1-util")
(:file "level1-generic")
(:file "level1-array")
(:file "level1-list")
More information about the lisplab-cvs
mailing list