[cl-gsl-cvs] CVS update: cl-gsl/matrix.lisp
cl-gsl-cvs at common-lisp.net
cl-gsl-cvs at common-lisp.net
Thu Apr 28 02:39:40 UTC 2005
Update of /project/cl-gsl/cvsroot/cl-gsl
In directory common-lisp.net:/tmp/cvs-serv21385
Modified Files:
matrix.lisp
Log Message:
Added functions that require vectors as well as matricies.
Date: Thu Apr 28 04:39:39 2005
Author: edenny
Index: cl-gsl/matrix.lisp
diff -u cl-gsl/matrix.lisp:1.3 cl-gsl/matrix.lisp:1.4
--- cl-gsl/matrix.lisp:1.3 Fri Apr 22 04:37:26 2005
+++ cl-gsl/matrix.lisp Thu Apr 28 04:39:39 2005
@@ -36,6 +36,7 @@
(let ((type-ptr)
(type-val)
(type-val-ptr)
+ (type-vec-ptr)
(type-string)
(is-real (or (eq typ 'double-float)
(eq typ 'single-float)
@@ -44,26 +45,31 @@
(cond
((eq typ 'double-float)
(setq type-ptr 'gsl-matrix-ptr)
+ (setq type-vec-ptr 'gsl-vector-ptr)
(setq type-val :double)
(setq type-val-ptr '(* :double))
(setq type-string "matrix"))
((eq typ 'single-float)
(setq type-ptr 'gsl-matrix-float-ptr)
+ (setq type-vec-ptr 'gsl-vector-float-ptr)
(setq type-val :float)
(setq type-val-ptr '(* :float))
(setq type-string "matrix_float"))
((eq typ 'integer)
(setq type-ptr 'gsl-matrix-int-ptr)
+ (setq type-vec-ptr 'gsl-vector-int-ptr)
(setq type-val :int)
(setq type-val-ptr '(* :int))
(setq type-string "matrix_int"))
((equal typ '(complex (double-float)))
(setq type-ptr 'gsl-matrix-complex-ptr)
+ (setq type-vec-ptr 'gsl-vector-complex-ptr)
(setq type-val 'gsl-complex)
(setq type-val-ptr '(* gsl-complex))
(setq type-string "matrix_complex"))
((equal typ '(complex (single-float)))
(setq type-ptr 'gsl-matrix-complex-float-ptr)
+ (setq type-vec-ptr 'gsl-vector-complex-float-ptr)
(setq type-val 'gsl-complex-float)
(setq type-val-ptr '(* gsl-complex-float))
(setq type-string "matrix_complex_float"))
@@ -140,6 +146,58 @@
(m2 ,type-ptr))
:int)
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_get_row")
+ ((v ,type-vec-ptr)
+ (m ,type-ptr)
+ (row size-t))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_get_col")
+ ((v ,type-vec-ptr)
+ (m ,type-ptr)
+ (col size-t))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_set_row")
+ ((m ,type-ptr)
+ (row size-t)
+ (v ,type-vec-ptr))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_set_col")
+ ((m ,type-ptr)
+ (col size-t)
+ (v ,type-vec-ptr))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_swap_rows")
+ ((m ,type-ptr)
+ (row1 size-t)
+ (row2 size-t))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_swap_columns")
+ ((m ,type-ptr)
+ (col1 size-t)
+ (col2 size-t))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_swap_rowcol")
+ ((m ,type-ptr)
+ (row size-t)
+ (col size-t))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_transpose")
+ ((m ,type-ptr))
+ :int)
+
+ (defun-foreign ,(concatenate 'string
+ "gsl_" type-string "_transpose_memcpy")
+ ((m-dest ,type-ptr)
+ (m-source ,type-ptr))
+ :int)
+
,(when is-real
`(progn
(defun-foreign ,(concatenate 'string "gsl_" type-string "_add")
@@ -178,24 +236,25 @@
:int)
(defun-foreign ,(concatenate 'string "gsl_" type-string "_max")
- ((vec ,type-ptr))
+ ((m ,type-ptr))
,type-val)
(defun-foreign ,(concatenate 'string "gsl_" type-string "_min")
- ((vec ,type-ptr))
+ ((m ,type-ptr))
,type-val)
(defun-foreign ,(concatenate 'string
"gsl_" type-string "_max_index")
- ((vec ,type-ptr)
+ ((m ,type-ptr)
(i-ptr size-t-ptr)
(j-ptr size-t-ptr))
:void)
+
(defun-foreign ,(concatenate 'string
"gsl_" type-string "_min_index")
- ((vec ,type-ptr)
+ ((m ,type-ptr)
(i-ptr size-t-ptr)
(j-ptr size-t-ptr))
:void)
@@ -339,6 +398,78 @@
(1/0->t/nil (,(kmrcl:concat-symbol "gsl-matrix-" func-string
"isnull") (ptr o))))
+ (defmethod get-row ((o ,class-object) row)
+ (assert (and (typep row 'integer) (>= row 0) (< row (size-rows o))))
+ (let* ((vec (make-vector (size-rows o) :element-type (element-type o)))
+ (status (,(kmrcl:concat-symbol "gsl-matrix-" func-string
+ "get-row")
+ (ptr vec) (ptr o) row)))
+ (values vec status)))
+
+ (defmethod get-col ((o ,class-object) col)
+ (assert (and (typep col 'integer) (>= col 0) (< col (size-cols o))))
+ (let* ((vec (make-vector (size-cols o) :element-type (element-type o)))
+ (status (,(kmrcl:concat-symbol "gsl-matrix-" func-string
+ "get-col")
+ (ptr vec) (ptr o) col)))
+ (values vec status)))
+
+ (defmethod set-row ((o ,class-object) row vec)
+ (assert (and (typep row 'integer) (>= row 0) (< row (size-rows o))))
+ (assert (= (size vec) (size-rows o)))
+ (let* ((status (,(kmrcl:concat-symbol "gsl-matrix-" func-string
+ "set-row")
+ (ptr o) row (ptr vec))))
+ (values o status)))
+
+ (defmethod set-col ((o ,class-object) col vec)
+ (assert (and (typep col 'integer) (>= col 0) (< col (size-cols o))))
+ (assert (= (size vec) (size-cols o)))
+ (let* ((status (,(kmrcl:concat-symbol "gsl-matrix-" func-string
+ "set-col")
+ (ptr o) col (ptr vec))))
+ (values o status)))
+
+ (defmethod swap-rows ((o ,class-object) row1 row2)
+ (assert (and (typep row1 'integer) (>= row1 0) (< row1 (size-rows o))))
+ (assert (and (typep row2 'integer) (>= row2 0) (< row2 (size-rows o))))
+ (let* ((status (,(kmrcl:concat-symbol "gsl-matrix-" func-string
+ "swap-rows")
+ (ptr o) row1 row2)))
+ (values o status)))
+
+ (defmethod swap-cols ((o ,class-object) col1 col2)
+ (assert (and (typep col1 'integer) (>= col1 0) (< col1 (size-cols o))))
+ (assert (and (typep col2 'integer) (>= col2 0) (< col2 (size-cols o))))
+ (let* ((status (,(kmrcl:concat-symbol "gsl-matrix-" func-string
+ "swap-columns")
+ (ptr o) col1 col2)))
+ (values o status)))
+
+ (defmethod swap-rowcol ((o ,class-object) row col)
+ (assert (= (size-rows o) (size-cols o)))
+ (assert (and (typep row 'integer) (>= row 0) (< row (size-rows o))))
+ (assert (and (typep col 'integer) (>= col 0) (< col (size-cols o))))
+ (let* ((status (,(kmrcl:concat-symbol "gsl-matrix-" func-string
+ "swap-rowcol")
+ (ptr o) row col)))
+ (values o status)))
+
+ (defmethod transpose ((o ,class-object))
+ (assert (= (size-rows o) (size-cols o)))
+ (let* ((status (,(kmrcl:concat-symbol "gsl-matrix-" func-string
+ "transpose")
+ (ptr o))))
+ (values o status)))
+
+ (defmethod copy-transpose ((o-dest ,class-object) (o-src, class-object))
+ (assert (and (= (size-rows o-dest) (size-rows o-src))
+ (= (size-cols o-dest) (size-cols o-src))))
+ (let* ((status (,(kmrcl:concat-symbol "gsl-matrix-" func-string
+ "transpose-memcpy")
+ (ptr o-dest) (ptr o-src))))
+ (values o-src status)))
+
,(when is-real
`(progn
(defmethod add ((o1 ,class-object) (o2 ,class-object))
@@ -519,6 +650,24 @@
, at body
(free ,m-dest))))
+(defmacro with-copy-transpose ((m-dest m-src) &body body)
+ `(gsl-array:with-matrix
+ (,m-dest (size-rows ,m-src) (size-cols ,m-src)
+ :element-type (element-type ,m-src))
+ (copy-transpose ,m-dest ,m-src)
+ , at body))
+
+(defmacro with-matrix-row ((v m row) &body body)
+ `(let ((,v (get-row ,m ,row)))
+ (unwind-protect
+ , at body
+ (free ,v))))
+
+(defmacro with-matrix-col ((v m col) &body body)
+ `(let ((,v (get-col ,m ,col)))
+ (unwind-protect
+ , at body
+ (free ,v))))
(defun gsl-matrix->lisp-array (m)
(let ((a (make-array (list (size-rows m) (size-cols m))
@@ -527,23 +676,3 @@
(dotimes (j (size-cols m))
(setf (aref a i j) (get-element m i j))))
a))
-
-
-
-;; Function: int gsl_matrix_get_row (gsl_vector * v, const gsl_matrix * m, size_t i)
-
-;; Function: int gsl_matrix_get_col (gsl_vector * v, const gsl_matrix * m, size_t j)
-
-;; Function: int gsl_matrix_set_row (gsl_matrix * m, size_t i, const gsl_vector * v)
-
-;; Function: int gsl_matrix_set_col (gsl_matrix * m, size_t j, const gsl_vector * v)
-
-;; Function: int gsl_matrix_swap_rows (gsl_matrix * m, size_t i, size_t j)
-
-;; Function: int gsl_matrix_swap_columns (gsl_matrix * m, size_t i, size_t j)
-
-;; Function: int gsl_matrix_swap_rowcol (gsl_matrix * m, size_t i, size_t j)
-
-;; Function: int gsl_matrix_transpose_memcpy (gsl_matrix * dest, const gsl_matrix * src)
-
-;; Function: int gsl_matrix_transpose (gsl_matrix * m)
More information about the Cl-gsl-cvs
mailing list