[lisplab-cvs] r166 - in trunk: . src/matrix src/test
Jørn Inge Vestgården
jivestgarden at common-lisp.net
Mon May 17 09:23:34 UTC 2010
Author: jivestgarden
Date: Mon May 17 05:23:33 2010
New Revision: 166
Log:
New matrix creation read macro and printers
Modified:
trunk/example.lisp
trunk/src/matrix/level1-dge.lisp
trunk/src/matrix/level1-ge.lisp
trunk/src/matrix/level1-interface.lisp
trunk/src/matrix/level1-matrix.lisp
trunk/src/matrix/level1-zge.lisp
trunk/src/matrix/level2-constructors.lisp
trunk/src/test/test-methods.lisp
Modified: trunk/example.lisp
==============================================================================
--- trunk/example.lisp (original)
+++ trunk/example.lisp Mon May 17 05:23:33 2010
@@ -12,7 +12,6 @@
(dnew 0 3 5)
; same as
(mnew '(:d :ge :any) 0 3 5)
-
(mnew 'matrix-zge 0 3 5)
; same as
(znew 0 3 5)
@@ -24,9 +23,18 @@
(zrow 2 %i 1)
(zcol 2 %i 1)
+ ;; Read macro
+ #md((1 2) (-1 4))
+ #mz((1 2) (-1 4))
+ #mm((1 2) (-1 4))
+
;; Setting of individual elements
- (dmat (0 4 -2) (1 3 -5) (-2 4 0))
- (zmat (0 #C(0 2) -2) (1 3 -5) (-2 %i 0))
+ (dmat '((0 4 -2)
+ (1 3 -5)
+ (-2 4 0)))
+ (zmat '((0 #c(0 2) -2)
+ (1 3 -5)
+ (-2 #c(0 1) 0)))
;; Setting of structure
(funmat '(4 4) (lambda (i j)
@@ -35,12 +43,15 @@
(if (< i j) 1 0.5)))
;; From another matrix
- (copy (dmat (1 4) (-2 3)))
- (mcreate (dmat (1 4) (-2 3)))
+ (copy #md((1 4) (-2 3)))
+
+ (mcreate #md((1 4) (-2 3)))
(convert '((3 2 4) (1 4 2)) 'matrix-dge)
(convert (funmat '(3 3) (lambda (i j) (random 1.0))) 'matrix-dge)
(mmap '(:z :ge :any) #'random (mnew '(:d :ge :any) 1 3 3))
- (.+ 3 (dmat (2 3) (-2 9)))))
+ (.+ 3 #md((2 3) (-2 9)))
+
+ ))
(mapcar (lambda (x) (mref x 0 0)) *test-matrices*)
@@ -48,17 +59,25 @@
;; Arithmetics
-(let ((a (dmat (0 4 -2) (1 3 -5) (-2 4 0)))
- (b (zmat (0 #C(0 2) -2) (1 3 -5) (-2 %i 0))))
+(let ((a #md((0 4 -2)
+ (1 3 -5)
+ (-2 4 0)))
+ (b #mz((0 (.* 2 %i) -2)
+ (1 3 -5)
+ (-2 %i 0))))
(.+ (.* 3 a) b))
;; Infix arithmetics
-(let ((a (dmat (0 4 -2) (1 3 -5) (-2 4 0)))
- (b (zmat (0 #C(0 2) -2) (1 3 -5) (-2 %i 0))))
+(let ((a #md((0 4 -2)
+ (1 3 -5)
+ (-2 4 0)))
+ (b #mz((0 #c(0 2) -2)
+ (1 3 -5)
+ (-2 %i 0))))
(w/infix 3 .* a .+ b))
;; Matrix inversion
-(minv (dmat (0 4 -2) (1 3 -5) (-2 4 0)))
+(minv #md((0 4 -2) (1 3 -5) (-2 4 0)))
Modified: trunk/src/matrix/level1-dge.lisp
==============================================================================
--- trunk/src/matrix/level1-dge.lisp (original)
+++ trunk/src/matrix/level1-dge.lisp Mon May 17 05:23:33 2010
@@ -68,6 +68,26 @@
;;; All leve1 methods spcialized for dge
+(defmethod print-object ((matrix matrix-base-dge) stream)
+ (if (not *lisplab-print-size*)
+ (call-next-method)
+ (progn
+ (format stream "~&#md(" )
+ (print-matrix-contents matrix
+ :stream stream
+ :pr (if *lisplab-element-printer*
+ *lisplab-element-printer*
+ (lambda (x stream) (format stream "~10,4g" x)))
+ :rmax (if (eq *lisplab-print-size* t)
+ (rows matrix)
+ *lisplab-print-size*)
+ :cmax (if (eq *lisplab-print-size* t)
+ (cols matrix)
+ *lisplab-print-size*)
+ :indent 4
+ :braket-p t)
+ (format stream ")" ))))
+
(defmethod mref ((matrix matrix-base-dge) row col)
(ref-blas-real-store (slot-value matrix 'matrix-store) row col (slot-value matrix 'rows)))
Modified: trunk/src/matrix/level1-ge.lisp
==============================================================================
--- trunk/src/matrix/level1-ge.lisp (original)
+++ trunk/src/matrix/level1-ge.lisp Mon May 17 05:23:33 2010
@@ -43,6 +43,26 @@
;;; Level methods specialized for untyped, general matrices
+(defmethod print-object ((matrix matrix-ge) stream)
+ (if (not *lisplab-print-size*)
+ (call-next-method)
+ (progn
+ (format stream "~&#mm(" )
+ (print-matrix-contents matrix
+ :stream stream
+ :pr (if *lisplab-element-printer*
+ *lisplab-element-printer*
+ (lambda (x stream) (format stream "~a" x)))
+ :rmax (if (eq *lisplab-print-size* t)
+ (rows matrix)
+ *lisplab-print-size*)
+ :cmax (if (eq *lisplab-print-size* t)
+ (cols matrix)
+ *lisplab-print-size*)
+ :indent 4
+ :braket-p t)
+ (format stream ")" ))))
+
(defmethod mref ((matrix matrix-ge) row col)
(aref (slot-value matrix 'matrix-store)
(column-major-idx row col (slot-value matrix 'rows))))
Modified: trunk/src/matrix/level1-interface.lisp
==============================================================================
--- trunk/src/matrix/level1-interface.lisp (original)
+++ trunk/src/matrix/level1-interface.lisp Mon May 17 05:23:33 2010
@@ -20,7 +20,12 @@
(in-package :lisplab)
-(defvar *lisplab-print-size* 10 "Suggested number of rows and columns printed to standard output. Not all matrices, such as ordinary lisp arrays, will care about the value.")
+(defvar *lisplab-print-size* 5
+ "Suggested number of rows and columns printed to standard output.
+Not all matrices will care about the value.")
+
+(defvar *lisplab-element-printer* nil
+ "The function used to print matrix elements. For is same as princ and prin1.")
(defgeneric make-matrix-instance (type dim value)
(:documentation "Creates a new matrix instance"))
Modified: trunk/src/matrix/level1-matrix.lisp
==============================================================================
--- trunk/src/matrix/level1-matrix.lisp (original)
+++ trunk/src/matrix/level1-matrix.lisp Mon May 17 05:23:33 2010
@@ -37,19 +37,71 @@
(1 (cols matrix)))
(list (rows matrix) (cols matrix))))
+(defun print-matrix-contents (m
+ &key
+ (stream *standard-output*)
+ (pr #'princ)
+ (rmax (rows m))
+ (cmax (cols m))
+ (indent 0)
+ (braket-p nil))
+ "Utility function that prints the matrix elements in a human-friendly way."
+ ;; TODO move among other utility functions?
+ (let ((rows (min (rows m) rmax))
+ (cols (min (cols m) cmax))
+ (indfmt (if (zerop indent)
+ ""
+ (format nil "~~~aT" indent))))
+ (dotimes (i rows)
+ (when (> i 0)
+ (format stream indfmt))
+ (when braket-p (princ "(" stream))
+ (dotimes (j cols)
+ (funcall pr (mref m i j) stream)
+ (when (< j (1- cols))
+ (princ " " stream)))
+ (when (< cols (cols m))
+ (format stream " ..."))
+ (when braket-p (princ ")" stream))
+ (when (< i (1- rows))
+ (princ #\newline stream)))
+ (when (< rows (rows m))
+ (format stream indfmt)
+ (format stream "~& ..."))))
+
+(defmethod print-object ((matrix matrix-base) stream)
+ "Prints matrix as an unreadable object. The number of printed
+rows and columns is limited by *lisplab-print-size*
+and format is given by *lisplab-element-printer*."
+ (print-unreadable-object (matrix stream :type t :identity t)
+ (format stream " ~ax~a" (rows matrix) (cols matrix))
+ (when *lisplab-print-size*
+ (format stream "~&")
+ (print-matrix-contents matrix
+ :stream stream
+ :pr (if *lisplab-element-printer*
+ *lisplab-element-printer*
+ #'princ)
+ :rmax (if (eq *lisplab-print-size* t)
+ (rows matrix)
+ *lisplab-print-size*)
+ :cmax (if (eq *lisplab-print-size* t)
+ (cols matrix)
+ *lisplab-print-size*)
+ :indent 0)
+ (format stream "~%"))))
+
+#+todo-remove
(defmethod print-object ((matrix matrix-base) stream)
"Prints matrix as an unreadable object. The number of printed
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*))
- (fmt (if (eql (element-type matrix) 'double-float)
- "~0,4g "
- "~a ")))
+ (cols (min (cols matrix) *lisplab-print-size*)))
(format stream " ~ax~a~&" (rows matrix) (cols matrix))
(dotimes (i rows)
(dotimes (j cols)
- (format stream fmt (mref matrix i j)))
+ (format stream "~a " (mref matrix i j)))
(when (< cols (cols matrix))
(format stream "..."))
(princ #\Newline stream))
Modified: trunk/src/matrix/level1-zge.lisp
==============================================================================
--- trunk/src/matrix/level1-zge.lisp (original)
+++ trunk/src/matrix/level1-zge.lisp Mon May 17 05:23:33 2010
@@ -67,6 +67,27 @@
;;; Level1 methods specialized for zge
+(defmethod print-object ((matrix matrix-base-zge) stream)
+ (if (not *lisplab-print-size*)
+ (call-next-method)
+ (progn
+ (format stream "~&#mz(" )
+ (print-matrix-contents matrix
+ :stream stream
+ :pr (if *lisplab-element-printer*
+ *lisplab-element-printer*
+ (lambda (x stream)
+ (format stream "#c(~8,2g ~8,2g)" (realpart x) (imagpart x))))
+ :rmax (if (eq *lisplab-print-size* t)
+ (rows matrix)
+ *lisplab-print-size*)
+ :cmax (if (eq *lisplab-print-size* t)
+ (cols matrix)
+ *lisplab-print-size*)
+ :indent 4
+ :braket-p t)
+ (format stream ")" ))))
+
(defmethod mref ((matrix matrix-base-zge) row col)
(ref-blas-complex-store (slot-value matrix 'matrix-store)
row col (slot-value matrix 'rows)))
Modified: trunk/src/matrix/level2-constructors.lisp
==============================================================================
--- trunk/src/matrix/level2-constructors.lisp (original)
+++ trunk/src/matrix/level2-constructors.lisp Mon May 17 05:23:33 2010
@@ -19,9 +19,30 @@
;;; TODO: needs constructors for diagonal matrices.
+;;; TODO: specialize convert for standard-class.
+
+
(in-package :lisplab)
+
+;;; Creates matrices with general structure, e.g., #md((1 2) (3 4))
+
+;;; TODO: error check is important here!
+
+(set-dispatch-macro-character #\# #\M
+ (lambda (stream c1 c2)
+ (let* ((s1 (make-string 1)))
+ (setf (aref s1 0) (read-char stream))
+ (setf s1 (string-capitalize s1))
+ (let ((type (cond ((string= s1 "D") :d)
+ ((string= s1 "Z") :z)
+ (t :any)))
+ (cont (read stream t nil t)))
+ (list 'mmat
+ (list 'list type :ge :any)
+ (cons 'list (mapcar (lambda (x) (cons 'list x)) cont)))))))
+
(defmethod mcreate ((m number) &optional (val 0) dim)
(declare (ignore dim))
;; This is not about matrices at all, but is usefull
@@ -80,7 +101,8 @@
;; Should it be moved to some other file?
;; TODO some better way ... some more general guessing routine
;; like guess-best-element-type
- (if (consp (car x))
+ (mmat type x)
+ #+todo-remove (if (consp (car x))
(let* ((cols (length (car x)))
(rows (length x))
(m (make-matrix-instance type (list rows cols) 0)))
@@ -96,13 +118,16 @@
rows)
value))
-(defmacro mmat (type &body args)
- "Creates a matrix."
- `(convert
- ,(cons 'list (mapcar (lambda (x)
- (cons 'list x))
- args))
- ,type))
+(defun mmat (type x)
+ "Creates a matrix from the list of lists. For a macro use #mm((..) (..) ..) instead."
+ (unless (consp (car x))
+ ;; It is a list. Create a column vector.
+ (setf x (mapcar #'list x)))
+ (let* ((cols (length (car x)))
+ (rows (length x))
+ (m (make-matrix-instance type (list rows cols) 0)))
+ (fill-matrix-with-list m x)
+ m))
(defun mcol (type &rest args)
"Creates a column matrix."
@@ -118,9 +143,9 @@
"Creates a double matrix with random element between 0 and 1."
(mmap t #'random (dnew 1d0 rows cols)))
-(defmacro dmat (&body args)
- "Creates a matrix-dge matrix."
- `(mmat 'matrix-dge , at args))
+(defun dmat (args)
+ "Creates a matrix-dge from the list of lists. For macro: use #md((..) (..) ..) instead."
+ (mmat 'matrix-dge args))
(defun dcol (&rest args)
"Creates a matrix-dge column matrix."
@@ -179,9 +204,9 @@
;;; Constructors for matrix-zge
-(defmacro zmat (&body args)
- "Creates a matrix-dge matrix."
- `(mmat 'matrix-zge , at args))
+(defun zmat (args)
+ "Creates a matrix-zge from the list of lists. For macro: use #mz((..) (..) ..) instead."
+ (mmat 'matrix-zge args))
(defun zcol (&rest args)
"Creates a matrix-zge column matrix."
Modified: trunk/src/test/test-methods.lisp
==============================================================================
--- trunk/src/test/test-methods.lisp (original)
+++ trunk/src/test/test-methods.lisp Mon May 17 05:23:33 2010
@@ -22,9 +22,9 @@
(let* ((a 1)
(b 1d0)
(c %i)
- (x (dmat (1 2) (3 4)))
- (y (zmat (1 2) (3 4)))
- (w (mmat 'matrix-ge (1 2) (3 4)))
+ (x #md((1 2) (3 4)))
+ (y #md((1 2) (3 4)))
+ (w #mm((1 2) (3 4)))
(args (list a b c x y w)))
(mapc (lambda (fun)
(mapc (lambda (x)
@@ -64,10 +64,10 @@
(defun test-level3-fft ()
- (let ((a (dmat (1 2) (3 4)))
- (b (zmat (1 2) (3 5)))
- (c (dmat (1 2 -1) (3 4 9) (1 1 1)))
- (d (zmat (1 2 2.1) (3 5 %i) (-%i -%i -%i))))
+ (let ((a #md((1 2) (3 4)))
+ (b #mz((1 2) (3 5)))
+ (c #md((1 2 -1) (3 4 9) (1 1 1)))
+ (d #mz((1 2 2.1) (3 5 %i) (-%i -%i -%i))))
(simple-non-nil-check #'fft1 (list a))
(simple-non-nil-check #'fft1 (list b))
(simple-non-nil-check #'fft2 (list a))
@@ -95,11 +95,11 @@
'done))
(defun test-level3-linalg ()
- (let* ((a (dmat (1 2) (3 4)))
- (b (zmat (1 2) (3 5)))
- (c (dmat (1 2 -1) (3 4 9) (1 1 1)))
- (d (zmat (1 2 2.1) (3 5 %i) (-%i %i -%i)))
- (x (mmat 'matrix-ge (1 2 2.1) (3 5 %i) (-%i %i -%i)))
+ (let* ((a #md((1 2) (3 4)))
+ (b #mz((1 2) (3 5)))
+ (c #md((1 2 -1) (3 4 9) (1 1 1)))
+ (d #mz((1 2 2.1) (3 5 %i) (-%i %i -%i)))
+ (x #mm((1 2 2.1) (3 5 %i) (-%i %i -%i)))
(args (list a b c d x)))
(mapc (lambda (x) (simple-non-nil-check #'mtp (list x))) args)
(mapc (lambda (x) (simple-non-nil-check #'mct (list x))) args)
More information about the lisplab-cvs
mailing list