[cl-gsl-cvs] CVS update: cl-gsl/matrix.lisp
cl-gsl-cvs at common-lisp.net
cl-gsl-cvs at common-lisp.net
Mon Apr 18 00:52:17 UTC 2005
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)
More information about the Cl-gsl-cvs
mailing list