Update of /project/cl-gsl/cvsroot/cl-gsl In directory common-lisp.net:/tmp/cvs-serv22734

Modified Files: matrix.lisp Log Message: Initial checkin.

Date: Mon Apr 18 02:52:16 2005 Author: edenny

Index: cl-gsl/matrix.lisp diff -u cl-gsl/matrix.lisp:1.1.1.1 cl-gsl/matrix.lisp:1.2 --- cl-gsl/matrix.lisp:1.1.1.1 Wed Mar 2 02:04:53 2005 +++ cl-gsl/matrix.lisp Mon Apr 18 02:52:16 2005 @@ -17,363 +17,59 @@ ;;;; along with this program; if not, write to the Free Software ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

+(in-package #:cl-gsl-matrix)

-;; Function: gsl_block * gsl_block_alloc (size_t n) +(defmacro def-matrix-type-funcs% (typ) + (let ((type-ptr) + (type-val) + (type-val-ptr) + (type-string)) + (cond + ((eq typ 'double-float) + (setq type-ptr 'gsl-matrix-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-val :float) + (setq type-val-ptr '(* :float)) + (setq type-string "matrix_float")) + ((eq typ 'integer) + (setq type-ptr 'gsl-matrix-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-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-val 'gsl-complex-float) + (setq type-val-ptr '(* gsl-complex-float)) + (setq type-string "matrix_complex_float")) + (t + (error "no matching type."))) + + `(progn + (defun-foreign ,(concatenate 'string "gsl_" type-string "_alloc") + ((size-1 size-t) + (size-2 size-t)) + ,type-ptr) + + (defun-foreign ,(concatenate 'string "gsl_" type-string "_free") + ((m ,type-ptr)) + :void) + ))) + +(def-matrix-type-funcs% double-float) +(def-matrix-type-funcs% single-float) +(def-matrix-type-funcs% integer) +(def-matrix-type-funcs% (complex (double-float))) +(def-matrix-type-funcs% (complex (single-float)))

-;; Function: gsl_block * gsl_block_calloc (size_t n) - -;; Function: void gsl_block_free (gsl_block * b) - -;; Function: int gsl_block_fwrite (FILE * stream, const gsl_block * b) - -;; Function: int gsl_block_fread (FILE * stream, gsl_block * b) - -;; Function: int gsl_block_fprintf (FILE * stream, const gsl_block * b, const char * format) - -;; Function: int gsl_block_fscanf (FILE * stream, gsl_block * b) - -;; ---------------------------------------------------------------------- - -;; Function: gsl_vector * gsl_vector_calloc (size_t n) - -;; Function: double * gsl_vector_ptr (gsl_vector * v, size_t i) -;; Function: const double * gsl_vector_const_ptr (const gsl_vector * v, size_t i) - -;; ---------------------------------------------------------------------- - -(in-package #:cl-gsl-vector) - -(defun-foreign "gsl_vector_alloc" - ((size :unsigned-long)) - gsl-vector-ptr) - -(defun-foreign ("gsl_vector_free" free-vector) - ((v gsl-vector-ptr)) - :void) - -(defun-foreign ("gsl_vector_get" get-element) - ((v gsl-vector-ptr) - (i :unsigned-long)) - :double) - -(defun-foreign ("gsl_vector_set" set-element) - ((v gsl-vector-ptr) - (i :unsigned-long) - (x :double)) - :void) - -(defun-foreign ("gsl_vector_set_all" set-all) - ((v gsl-vector-ptr) - (x :double)) - :void) - -(defun-foreign ("gsl_vector_set_zero" set-zero) - ((v gsl-vector-ptr)) - :void) - -(defun-foreign ("gsl_vector_set_basis" set-basis) - ((v gsl-vector-ptr) - (i :unsigned-long)) - :void) - - -(defun make-vector (size &key element-type initial-element initial-contents) - ;; TODO: make dependent on element-type - (assert (and (typep size 'integer) (> size 0))) - (cond - ((and initial-element initial-contents) - (error "cannot define both initial-element and initial-contents keys")) - (initial-element - (let ((vec (gsl-vector-alloc size))) - (gsl-vector:set-all vec initial-element) - vec)) - (initial-contents - (let ((vec (gsl-vector-alloc size))) - (cond - ((listp initial-contents) - (do ((x initial-contents (cdr x)) - (i 0 (1+ i))) - ((= i size)) - (gsl-vector:set-element vec i (car x)))) - ((vectorp initial-contents) - (do ((i 0 (1+ i))) - ((= i size)) - (gsl-vector:set-element vec i (aref initial-contents i)))) - (t - (error "initial-contents must be either a list or a vector."))) - vec)) - (t - (gsl-vector-alloc size)))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "wrap_gsl_vector_fwrite" - ((fn :cstring) - (v gsl-vector-ptr)) - :int) - -(defun write-to-binary-file (file-name vec) - (let ((status)) - (with-cstring (c-file-name file-name) - (setq status (wrap-gsl-vector-fwrite c-file-name vec))) - status)) - -;; ---------------------------------------------------------------------- - -(defun-foreign "wrap_gsl_vector_fread" - ((fn :cstring) - (v gsl-vector-ptr)) - :int) - -(defun read-from-binary-file (file-name size) - (let ((vec (gsl-vector-alloc size)) - (status)) - (with-cstring (c-file-name file-name) - (setq status (wrap-gsl-vector-fread c-file-name vec))) - (values vec status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "wrap_gsl_vector_fprintf" - ((fn :cstring) - (v gsl-vector-ptr)) - :int) - -(defun write-to-file (file-name vec) - (let ((status)) - (with-cstring (c-file-name file-name) - (setq status (wrap-gsl-vector-fprintf c-file-name vec))) - status)) - -;; ---------------------------------------------------------------------- - -(defun-foreign "wrap_gsl_vector_fscanf" - ((fn :cstring) - (v gsl-vector-ptr)) - :int) - -(defun read-from-file (file-name size) - (let ((vec (gsl-vector-alloc size)) - (status)) - (with-cstring (c-file-name file-name) - (setq status (wrap-gsl-vector-fscanf c-file-name vec))) - (values vec status))) - -;; ---------------------------------------------------------------------- - -;; Function: gsl_vector_const_view gsl_vector_const_subvector (const gsl_vector * v, size_t offset, size_t n) - -(defun-foreign "gsl_vector_subvector" - ((v gsl-vector-ptr) - (offset :unsigned-long) - (n :unsigned-long)) - gsl-vector-view) - -(defun subvector (v offset n) - (let ((view (gsl-vector-subvector v offset n))) - (uffi:get-slot-pointer view 'gsl-vector-view 'vec))) - -;; ---------------------------------------------------------------------- - -;; Function: gsl_vector_const_view gsl_vector_const_subvector_with_stride (const gsl_vector * v, size_t offset, size_t stride, size_t n) - -(defun-foreign "gsl_vector_subvector_with_stride" - ((v gsl-vector-ptr) - (offset :unsigned-long) - (stride :unsigned-long) - (n :unsigned-long)) - gsl-vector-view) - -(defun subvector (v offset stride n) - (let ((view (gsl-vector-subvector-with-stride v offset stride n))) - (uffi:get-slot-pointer view 'gsl-vector-view 'vec))) - -;; ---------------------------------------------------------------------- - -;; Function: gsl_vector_view gsl_vector_complex_real (gsl_vector_complex *v) -;; Function: gsl_vector_const_view gsl_vector_complex_const_real (const gsl_vector_complex *v) - -;; Function: gsl_vector_view gsl_vector_complex_imag (gsl_vector_complex *v) -;; Function: gsl_vector_const_view gsl_vector_complex_const_imag (const gsl_vector_complex *v) - -;; Function: gsl_vector_view gsl_vector_view_array_with_stride (double * base, size_t stride, size_t n) -;; Function: gsl_vector_const_view gsl_vector_const_view_array_with_stride (const double * base, size_t stride, size_t n) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_memcpy" - ((v1 gsl-vector-ptr) - (v2 gsl-vector-ptr)) - :int) - -(defun copy (v-src) - (let* ((n (uffi:get-slot-value v-src 'gsl-vector 'size)) - (v-dest (gsl-vector-alloc n)) - (status)) - (setq status (gsl-vector-memcpy v-dest v-src)) - (values v-dest status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign ("gsl_vector_swap" swap) - ((v1 gsl-vector-ptr) - (v2 gsl-vector-ptr)) - :int) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_swap_elements" - ((v1 gsl-vector-ptr) - (i size-t) - (j size-t)) - :int) - -(defun swap-elements (v i j) - (let ((status (gsl-vector-swap-elements v i j))) - (values v status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_reverse" - ((v1 gsl-vector-ptr)) - :int) - -(defun reverse-vector (v) - (let ((status (gsl-vector-reverse v))) - (values v status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_add" - ((va gsl-vector-ptr) - (vb gsl-vector-ptr)) - :int) - -(defun add (va vb) - (let ((status (gsl-vector-add va vb))) - (values va status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_sub" - ((va gsl-vector-ptr) - (vb gsl-vector-ptr)) - :int) - -(defun sub (va vb) - (let ((status (gsl-vector-sub va vb))) - (values va status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_mul" - ((va gsl-vector-ptr) - (vb gsl-vector-ptr)) - :int) - -(defun mul (va vb) - (let ((status (gsl-vector-mul va vb))) - (values va status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_div" - ((va gsl-vector-ptr) - (vb gsl-vector-ptr)) - :int) - -(defun div (va vb) - (let ((status (gsl-vector-div va vb))) - (values va status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_scale" - ((vec gsl-vector-ptr) - (x :double)) - :int) - -(defun scale (vec x) - (let ((status (gsl-vector-scale vec x))) - (values vec status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_add_constant" - ((vec gsl-vector-ptr) - (x :double)) - :int) - -(defun add-constant (vec x) - (let ((status (gsl-vector-add-constant vec x))) - (values vec status))) - -;; ---------------------------------------------------------------------- - -(defun-foreign ("gsl_vector_max" max-value) - ((vec gsl-vector-ptr)) - :double) - -(defun-foreign ("gsl_vector_min" min-value) - ((vec gsl-vector-ptr)) - :double) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_minmax" - ((vec gsl-vector-ptr) - (min double-ptr) - (max double-ptr)) - :void) - -(defun min-max-values (vec) - (let ((min-ptr (uffi:allocate-foreign-object :double)) - (max-ptr (uffi:allocate-foreign-object :double))) - (gsl-vector-minmax vec min-ptr max-ptr) - (prog1 - (list (uffi:deref-pointer :double min-ptr) - (uffi:deref-pointer :double max-ptr)) - (uffi:free-foreign-object min-ptr) - (uffi:free-foreign-object max-ptr)))) - -;; ---------------------------------------------------------------------- - -(defun-foreign ("gsl_vector_max_index" max-index) - ((vec gsl-vector-ptr)) - size-t) - -(defun-foreign ("gsl_vector_min_index" min-index) - ((vec gsl-vector-ptr)) - size-t) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_minmax_index" - ((vec gsl-vector-ptr) - (min size-t-ptr) - (max size-t-ptr)) - :void) - -(defun min-max-indicies (vec) - (let ((min-ptr (uffi:allocate-foreign-object 'size-t)) - (max-ptr (uffi:allocate-foreign-object 'size-t))) - (gsl-vector-minmax-index vec min-ptr max-ptr) - (prog1 - (list (uffi:deref-pointer 'size-t min-ptr) - (uffi:deref-pointer 'size-t max-ptr)) - (uffi:free-foreign-object min-ptr) - (uffi:free-foreign-object max-ptr)))) - -;; ---------------------------------------------------------------------- - -(defun-foreign "gsl_vector_isnull" - ((vec gsl-vector-ptr)) - :int) - -(defun isnull (vec) - (1/0->t/nil (gsl-vector-isnull vec))) - -;; ----------------------------------------------------------------------

;; Function: gsl_matrix * gsl_matrix_alloc (size_t n1, size_t n2)