[lisplab-cvs] r161 - trunk/src/matrix

[Jørn Inge Vestgården]

Author: jivestgarden
Date: Thu May 13 12:02:30 2010
New Revision: 161

Log:
first draft on container

Added:
   trunk/src/matrix/level1-container.lisp
Modified:
   trunk/src/matrix/level1-matrix.lisp

Added: trunk/src/matrix/level1-container.lisp
==============================================================================
--- (empty file)
+++ trunk/src/matrix/level1-container.lisp	Thu May 13 12:02:30 2010
@@ -0,0 +1,82 @@
+;;; Lisplab, level1-container.lisp
+;;; Container matrices that contains one matrix and passes all operations to this. 
+;;; This should be the default matrix. 
+
+;;; Copyright (C) 2010 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.
+
+;;; TODO: this will only get useful if also implemented on level 2, including 
+;;;       high level optimizations. This is a lot of work... 
+
+(in-package :lisplab)
+
+(defclass matrix (matrix-base) 
+  ((matrix-content :initarg :content
+		   :initform nil
+		   :accessor matrix-content
+		   :type matrix-base))
+  (:documentation "A meta-matrix that contains wraps another matrix.")) 
+
+(defmethod make-matrix-class ((a (eql :any)) (b (eql :any)) (c (eql :any)))
+  (find-class 'matrix))
+
+(defmethod initialize-instance :after ((m matrix) &key dim (value 0))
+  (with-slots (matrix-content) m
+    (unless matrix-content 
+      (setf matrix-content 
+	    (make-matrix-instance (typecase value 
+				    (real 'matrix-dge)
+				    (complex 'matrix-zge)
+				    (t 'matrix-ge))
+				  dim 
+				value)))))
+			  
+
+;;; Level methods specialized for untyped, general matrices
+
+(defmethod element-type ((m matrix))
+  (element-type (slot-value m 'matrix-content)))
+
+(defmethod size ((m matrix))
+  (size (slot-value m 'matrix-content)))
+
+(defmethod rows ((m matrix))
+  (rows (slot-value m 'matrix-content)))
+
+(defmethod cols ((m matrix))
+  (cols (slot-value m 'matrix-content)))
+
+(defmethod dim  ((m matrix) &optional direction)
+  (dim (slot-value m 'matrix-content) direction))
+
+(defmethod mref ((matrix matrix) row col)
+  (mref (slot-value matrix 'matrix-content) row col))
+
+(defmethod (setf mref) (value (matrix  matrix) row col)
+  (with-slots (matrix-content) matrix
+    (unless (subtypep (type-of value) (element-type matrix-content))
+      (setf matrix-content (convert matrix 'matrix-ge))) ;; could do something more clever here
+    (setf (mref matrix-content row col) value)))
+
+(defmethod vref ((matrix matrix) idx)
+  (vref (slot-value matrix 'matrix-content) idx))
+
+(defmethod (setf vref) (value (matrix  matrix) idx)
+  (with-slots (matrix-content) matrix
+    (unless (subtypep (type-of value) (element-type matrix-content))
+      (setf matrix-content (convert matrix 'matrix-ge))) ;; could do something more clever here
+    (setf (vref matrix-content idx) value)))
+

Modified: trunk/src/matrix/level1-matrix.lisp
==============================================================================
--- trunk/src/matrix/level1-matrix.lisp	(original)
+++ trunk/src/matrix/level1-matrix.lisp	Thu May 13 12:02:30 2010
@@ -42,11 +42,14 @@
 rows and columns is limited by *lisplab-print-size*."
   (print-unreadable-object (matrix stream :type t :identity t)
     (let ((rows (min (rows matrix) *lisplab-print-size*))
-	  (cols (min (cols matrix) *lisplab-print-size*)))
+	  (cols (min (cols matrix) *lisplab-print-size*))
+	  (fmt (if (eql (element-type matrix) 'double-float)
+		   "~0,4g "
+		   "~a ")))
       (format stream " ~ax~a~&" (rows matrix) (cols matrix)) 
       (dotimes (i rows)
 	(dotimes (j cols)
-	  (format stream "~a " (mref matrix i j)))
+	  (format stream fmt (mref matrix i j)))
 	(when (< cols (cols matrix))
 	  (format stream "..."))
 	(princ #\Newline stream))