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 @@ ,@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) + ,@body)) + +(defmacro with-matrix-row ((v m row) &body body) + `(let ((,v (get-row ,m ,row))) + (unwind-protect + ,@body + (free ,v)))) + +(defmacro with-matrix-col ((v m col) &body body) + `(let ((,v (get-col ,m ,col))) + (unwind-protect + ,@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)