[cl-gsl-cvs] CVS update: cl-gsl/vector.lisp
cl-gsl-cvs at common-lisp.net
cl-gsl-cvs at common-lisp.net
Mon Apr 18 00:55:10 UTC 2005
Update of /project/cl-gsl/cvsroot/cl-gsl
In directory common-lisp.net:/tmp/cvs-serv22808
Modified Files:
vector.lisp
Log Message:
Ripped out struct implementation and replaced with classes.
Date: Mon Apr 18 02:55:10 2005
Author: edenny
Index: cl-gsl/vector.lisp
diff -u cl-gsl/vector.lisp:1.7 cl-gsl/vector.lisp:1.8
--- cl-gsl/vector.lisp:1.7 Sun Apr 10 04:31:06 2005
+++ cl-gsl/vector.lisp Mon Apr 18 02:55:09 2005
@@ -19,11 +19,28 @@
(in-package #:cl-gsl-vector)
+
+(defclass gsl-vector ()
+ ((ptr :accessor ptr :initarg :ptr)
+ (size :accessor size :initarg :size)
+ (element-type :accessor element-type :initarg :element-type)))
+
+
+(defclass gsl-vector-double-float (gsl-vector) ())
+(defclass gsl-vector-single-float (gsl-vector) ())
+(defclass gsl-vector-integer (gsl-vector) ())
+(defclass gsl-vector-complex-double-float (gsl-vector) ())
+(defclass gsl-vector-complex-single-float (gsl-vector) ())
+
+
(defmacro def-vector-type-funcs% (typ)
(let ((type-ptr)
(type-val)
(type-val-ptr)
- (type-string))
+ (type-string)
+ (is-real (or (eq typ 'double-float)
+ (eq typ 'single-float)
+ (eq typ 'integer))))
(cond
((eq typ 'double-float)
(setq type-ptr 'gsl-vector-ptr)
@@ -107,92 +124,6 @@
((v1 ,type-ptr))
:int)
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_add")
- ((va ,type-ptr)
- (vb ,type-ptr))
- :int))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_sub")
- ((va ,type-ptr)
- (vb ,type-ptr))
- :int))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_mul")
- ((va ,type-ptr)
- (vb ,type-ptr))
- :int))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_div")
- ((va ,type-ptr)
- (vb ,type-ptr))
- :int))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_scale")
- ((vec ,type-ptr)
- ;; seems odd that this is :double for all types
- (x :double))
- :int))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string
- "gsl_" type-string "_add_constant")
- ((vec ,type-ptr)
- ;; and again, :double for all types
- (x :double))
- :int))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_max")
- ((vec ,type-ptr))
- ,type-val))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_min")
- ((vec ,type-ptr))
- ,type-val))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_minmax")
- ((vec ,type-ptr)
- (min ,type-val-ptr)
- (max ,type-val-ptr))
- :void))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_max_index")
- ((vec ,type-ptr))
- size-t))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string "gsl_" type-string "_min_index")
- ((vec ,type-ptr))
- size-t))
-
- ,(unless (or (equal typ '(complex (double-float)))
- (equal typ '(complex (single-float))))
- `(defun-foreign ,(concatenate 'string
- "gsl_" type-string "_minmax_index")
- ((vec ,type-ptr)
- (min size-t-ptr)
- (max size-t-ptr))
- :void))
-
(defun-foreign ,(concatenate 'string "gsl_" type-string "_isnull")
((vec ,type-ptr))
:int)
@@ -230,40 +161,95 @@
(offset size-t)
(stride size-t)
(n size-t))
- ,type-ptr))))
+ ,type-ptr)
+ ,(when is-real
+ `(progn
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_add")
+ ((va ,type-ptr)
+ (vb ,type-ptr))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_sub")
+ ((va ,type-ptr)
+ (vb ,type-ptr))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_mul")
+ ((va ,type-ptr)
+ (vb ,type-ptr))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_div")
+ ((va ,type-ptr)
+ (vb ,type-ptr))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_scale")
+ ((vec ,type-ptr)
+ ;; seems odd that this is :double for all types
+ (x :double))
+ :int)
+
+ (defun-foreign ,(concatenate 'string
+ "gsl_" type-string "_add_constant")
+ ((vec ,type-ptr)
+ ;; and again, :double for all types
+ (x :double))
+ :int)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_max")
+ ((vec ,type-ptr))
+ ,type-val)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_min")
+ ((vec ,type-ptr))
+ ,type-val)
+
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_minmax")
+ ((vec ,type-ptr)
+ (min ,type-val-ptr)
+ (max ,type-val-ptr))
+ :void)
+
+ (defun-foreign ,(concatenate 'string
+ "gsl_" type-string "_max_index")
+ ((vec ,type-ptr))
+ size-t)
+
+ (defun-foreign ,(concatenate 'string
+ "gsl_" type-string "_min_index")
+ ((vec ,type-ptr))
+ size-t)
+
+ (defun-foreign ,(concatenate 'string
+ "gsl_" type-string "_minmax_index")
+ ((vec ,type-ptr)
+ (min size-t-ptr)
+ (max size-t-ptr))
+ :void)
+ ))
+
+ ,(when (not is-real)
+ `(progn
+ (defun-foreign ,(concatenate 'string "gsl_" type-string "_ptr")
+ ((v ,type-ptr)
+ (i size-t))
+ (* ,type-val))
+
+ (defun-foreign ,(concatenate 'string "wrap_gsl_" type-string "_set")
+ ((v ,type-ptr)
+ (i size-t)
+ (z (* ,type-val)))
+ :void)
+
+ (defun-foreign ,(concatenate 'string
+ "wrap_gsl_" type-string "_set_all")
+ ((v ,type-ptr)
+ (z (* ,type-val)))
+ :void)))
+ )))
-(defun-foreign "gsl_vector_complex_float_ptr"
- ((v gsl-vector-complex-float-ptr)
- (i size-t))
- (* gsl-complex-float))
-
-(defun-foreign "gsl_vector_complex_ptr"
- ((v gsl-vector-complex-ptr)
- (i size-t))
- (* gsl-complex))
-
-(defun-foreign "wrap_gsl_vector_complex_float_set"
- ((v gsl-vector-complex-float-ptr)
- (i size-t)
- (z (* gsl-complex-float)))
- :void)
-
-(defun-foreign "wrap_gsl_vector_complex_set"
- ((v gsl-vector-complex-ptr)
- (i size-t)
- (z (* gsl-complex)))
- :void)
-
-(defun-foreign "wrap_gsl_vector_complex_float_set_all"
- ((v gsl-vector-complex-float-ptr)
- (z (* gsl-complex-float)))
- :void)
-
-(defun-foreign "wrap_gsl_vector_complex_set_all"
- ((v gsl-vector-complex-ptr)
- (z (* gsl-complex)))
- :void)
(def-vector-type-funcs% double-float)
(def-vector-type-funcs% single-float)
@@ -271,221 +257,252 @@
(def-vector-type-funcs% (complex (double-float)))
(def-vector-type-funcs% (complex (single-float)))
-(defstruct gsl-vec
- ;; TODO: print-function ?
- ptr
- size
- element-type)
-
-(defun alloc (v)
- (assert (eq 'gsl-vec (type-of v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (setf (gsl-vec-ptr v) (gsl-vector-int-alloc (gsl-vec-size v))))
- ((eq (gsl-vec-element-type v) 'single-float)
- (setf (gsl-vec-ptr v) (gsl-vector-float-alloc (gsl-vec-size v))))
- ((eq (gsl-vec-element-type v) 'double-float)
- (setf (gsl-vec-ptr v) (gsl-vector-alloc (gsl-vec-size v))))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (setf (gsl-vec-ptr v) (gsl-vector-complex-float-alloc (gsl-vec-size v))))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (setf (gsl-vec-ptr v) (gsl-vector-complex-alloc (gsl-vec-size v))))
- (t
- (error "No matching type"))))
-
-
-(defun free (v)
- (assert (eq 'gsl-vec (type-of v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-free (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-free (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-free (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (gsl-vector-complex-float-free (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (gsl-vector-complex-free (gsl-vec-ptr v)))
- (t
- (error "No matching type")))
- (setf (gsl-vec-ptr v) nil)
- (setf (gsl-vec-size v) nil)
- (setf (gsl-vec-element-type v) nil))
-
-
-(defun get-element (v i)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (typep i 'integer))
- (assert (< i (gsl-vec-size v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-get (gsl-vec-ptr v) i))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-get (gsl-vec-ptr v) i))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-get (gsl-vec-ptr v) i))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (gsl-complex-float->complex
- (gsl-vector-complex-float-ptr (gsl-vec-ptr v) i)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (gsl-complex->complex (gsl-vector-complex-ptr (gsl-vec-ptr v) i)))
- (t
- (error "No matching type"))))
-
-
-;; TODO: make a (setf (get-element v i) x) version.
-(defun set-element (v i x)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (typep x (gsl-vec-element-type v)))
- (assert (typep i 'integer))
- (assert (< i (gsl-vec-size v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-set (gsl-vec-ptr v) i x))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-set (gsl-vec-ptr v) i x))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-set (gsl-vec-ptr v) i x))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (with-complex-single-float->gsl-complex-float-ptr (c-ptr x)
- (wrap-gsl-vector-complex-float-set (gsl-vec-ptr v) i c-ptr)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (with-complex-double-float->gsl-complex-ptr (c-ptr x)
- (wrap-gsl-vector-complex-set (gsl-vec-ptr v) i c-ptr)))
- (t
- (error "No matching type")))
- v)
-
-
-(defun set-all (v x)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (typep x (gsl-vec-element-type v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-set-all (gsl-vec-ptr v) x))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-set-all (gsl-vec-ptr v) x))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-set-all (gsl-vec-ptr v) x))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (with-complex-single-float->gsl-complex-float-ptr (c-ptr x)
- (wrap-gsl-vector-complex-float-set-all (gsl-vec-ptr v) c-ptr)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (with-complex-double-float->gsl-complex-ptr (c-ptr x)
- (wrap-gsl-vector-complex-set-all (gsl-vec-ptr v) c-ptr)))
- (t
- (error "No matching type")))
- v)
-
-
-(defun set-zero (v)
- (assert (eq 'gsl-vec (type-of v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-set-zero (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-set-zero (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-set-zero (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (gsl-vector-complex-float-set-zero (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (gsl-vector-complex-set-zero (gsl-vec-ptr v)))
- (t
- (error "No matching type")))
- v)
-
-
-(defun set-basis (v i)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (typep i 'integer))
- (assert (< i (gsl-vec-size v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-set-basis (gsl-vec-ptr v) i))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-set-basis (gsl-vec-ptr v) i))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-set-basis (gsl-vec-ptr v) i))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (gsl-vector-complex-float-set-basis (gsl-vec-ptr v) i))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (gsl-vector-complex-set-basis (gsl-vec-ptr v) i))
- (t
- (error "No matching type")))
- v)
-
-
-(defun read-from-binary-file (v file-name size)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (<= size (gsl-vec-size v)))
- (let ((status))
- (uffi:with-cstring (c-file-name file-name)
- (setq status
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (wrap-gsl-vector-int-fread c-file-name (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (wrap-gsl-vector-float-fread c-file-name (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (wrap-gsl-vector-fread c-file-name (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (wrap-gsl-vector-complex-float-fread c-file-name (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (wrap-gsl-vector-complex-fread c-file-name (gsl-vec-ptr v)))
- (t
- (error "No matching type")))))
- (values v status)))
-
-
-(defun read-from-file (v file-name size)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (<= size (gsl-vec-size v)))
- (let ((status))
- (uffi:with-cstring (c-file-name file-name)
- (setq status
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (wrap-gsl-vector-int-fscanf c-file-name (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (wrap-gsl-vector-float-fscanf c-file-name (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (wrap-gsl-vector-fscanf c-file-name (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (wrap-gsl-vector-complex-float-fscanf c-file-name
- (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (wrap-gsl-vector-complex-fscanf c-file-name (gsl-vec-ptr v)))
- (t
- (error "No matching type")))))
- (values v status)))
+
+(defmacro def-vector-methods% (class-string func-string)
+ (let ((class-object (kmrcl:concat-symbol "gsl-vector-" class-string))
+ (is-real (or (string= class-string "integer")
+ (string= class-string "single-float")
+ (string= class-string "double-float"))))
+ `(progn
+
+ (defmethod alloc ((o ,class-object))
+ (setf (ptr o) (,(kmrcl:concat-symbol "gsl-vector-" func-string "alloc")
+ (size o)))
+ o)
+
+ (defmethod free ((o ,class-object))
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "free") (ptr o))
+ (setf (ptr o) nil)
+ (setf (size o) nil)
+ (setf (element-type o) nil))
+
+
+ (defmethod get-element ((o ,class-object) i)
+ (assert (typep i 'integer))
+ (assert (and (>= i 0) (< i (size o))))
+ ,(if is-real
+ `(,(kmrcl:concat-symbol "gsl-vector-" func-string "get")
+ (ptr o) i)
+ `(,(kmrcl:concat-symbol "gsl-" func-string ">complex")
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "ptr")
+ (ptr o) i))))
+
+ (defmethod set-element ((o ,class-object) i x)
+ (assert (typep i 'integer))
+ (assert (typep x (element-type o)))
+ (assert (and (>= i 0) (< i (size o))))
+ ,(if is-real
+ `(,(kmrcl:concat-symbol "gsl-vector-" func-string "set")
+ (ptr o) i x)
+ `(,(kmrcl:concat-symbol "with-" class-string "->gsl-" func-string
+ "ptr") (c-ptr x)
+ (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string "set")
+ (ptr o) i c-ptr)))
+ x)
+
+ (defmethod set-all ((o ,class-object) x)
+ (assert (typep x (element-type o)))
+ ,(if is-real
+ `(,(kmrcl:concat-symbol "gsl-vector-" func-string "set-all")
+ (ptr o) x)
+ `(,(kmrcl:concat-symbol "with-" class-string "->gsl-" func-string
+ "ptr") (c-ptr x)
+ (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string "set-all")
+ (ptr o) c-ptr)))
+ o)
+
+ (defmethod set-zero ((o ,class-object))
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "set-zero") (ptr o))
+ o)
+
+
+ (defmethod set-basis ((o ,class-object) i)
+ (assert (typep i 'integer))
+ (assert (and (>= i 0) (< i (size o))))
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "set-basis")
+ (ptr o) i)
+ o)
+
+
+ (defmethod read-from-binary-file ((o ,class-object) file-name size)
+ (assert (and (> size 0) (<= size (size o))))
+ (let ((status))
+ (uffi:with-cstring (c-file-name file-name)
+ (setq status
+ (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string
+ "fread") c-file-name (ptr o))))
+ (values o status)))
+
+ (defmethod read-from-file ((o ,class-object) file-name size)
+ (assert (and (> size 0) (<= size (size o))))
+ (let ((status))
+ (uffi:with-cstring (c-file-name file-name)
+ (setq status
+ (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string
+ "fscanf") c-file-name (ptr o))))
+ (values o status)))
+
+ (defmethod write-to-binary-file (file-name (o ,class-object))
+ (let ((status))
+ ;; TODO: check if uffi:with-string returns a result, docs unclear.
+ (uffi:with-cstring (c-file-name file-name)
+ (setq status
+ (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string
+ "fwrite") c-file-name (ptr o))))
+ status))
+
+ (defmethod write-to-file (file-name (o ,class-object))
+ (let ((status))
+ (uffi:with-cstring (c-file-name file-name)
+ (setq status
+ (,(kmrcl:concat-symbol "wrap-gsl-vector-" func-string
+ "fprintf") c-file-name (ptr o))))
+ status))
+
+ (defmethod swap ((o1 ,class-object) (o2 ,class-object))
+ (assert (= (size o1) (size o2)))
+ (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "swap") (ptr o1) (ptr o2))))
+ (values o1 status)))
+
+ (defmethod swap-elements ((o ,class-object) i j)
+ (assert (and (typep i 'integer) (>= i 0) (< i (size o))))
+ (assert (and (typep j 'integer) (>= j 0) (< j (size o))))
+ (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "swap-elements") (ptr o) i j)))
+ (values o status)))
+
+ (defmethod reverse-vector ((o ,class-object))
+ (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "reverse") (ptr o))))
+ (values o status)))
+
+
+ (defmethod isnull ((o ,class-object))
+ (1/0->t/nil (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "isnull") (ptr o))))
+
+ ,(when is-real
+ `(progn
+ (defmethod add ((o1 ,class-object) (o2 ,class-object))
+ (assert (= (size o1) (size o2)))
+ (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "add") (ptr o1) (ptr o2))))
+ (values o1 status)))
+
+ (defmethod sub ((o1 ,class-object) (o2 ,class-object))
+ (assert (= (size o1) (size o2)))
+ (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "sub") (ptr o1) (ptr o2))))
+ (values o1 status)))
+
+ (defmethod mul ((o1 ,class-object) (o2 ,class-object))
+ (assert (= (size o1) (size o2)))
+ (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "mul") (ptr o1) (ptr o2))))
+ (values o1 status)))
+
+ (defmethod div ((o1 ,class-object) (o2 ,class-object))
+ (assert (= (size o1) (size o2)))
+ (let ((status (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "div") (ptr o1) (ptr o2))))
+ (values o1 status)))
+
+ (defmethod scale ((o ,class-object) x)
+ (assert (typep x (element-type o)))
+ ;; coerce to double-float looks wrong, but isn't.
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "scale")
+ (ptr o) (coerce x 'double-float)))
+
+ (defmethod add-constant ((o ,class-object) x)
+ (assert (typep x (element-type o)))
+ ;; coerce to double-float looks wrong, but isn't.
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "add-constant")
+ (ptr o) (coerce x 'double-float)))
+
+ (defmethod max-value ((o ,class-object))
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "max") (ptr o)))
+
+ (defmethod min-value ((o ,class-object))
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "min") (ptr o)))
+
+ (defmethod max-index ((o ,class-object))
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "max-index")
+ (ptr o)))
+
+ (defmethod min-index ((o ,class-object))
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string "min-index")
+ (ptr o)))
+
+ (defmethod min-max-indicies ((o ,class-object))
+ (let ((min-ptr (uffi:allocate-foreign-object 'size-t))
+ (max-ptr (uffi:allocate-foreign-object 'size-t)))
+ (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "minmax-index")
+ (ptr o) min-ptr max-ptr)
+ (prog1
+ (list (uffi:deref-pointer min-ptr 'size-t)
+ (uffi:deref-pointer max-ptr 'size-t))
+ (uffi:free-foreign-object min-ptr)
+ (uffi:free-foreign-object max-ptr))))
+
+ (defmethod min-max-values ((o ,class-object))
+ (destructuring-bind (min-index max-index)
+ (min-max-indicies o)
+ (list (get-element o min-index)
+ (get-element o max-index))))
+
+ )))))
+
+
+(def-vector-methods% "integer" "int-")
+(def-vector-methods% "single-float" "float-")
+(def-vector-methods% "double-float" "")
+(def-vector-methods% "complex-single-float" "complex-float-")
+(def-vector-methods% "complex-double-float" "complex-")
(defun make-vector (size &key (element-type 'double-float) initial-element
initial-contents from-file from-binary-file)
- (assert (typep size 'integer))
+ (assert (and (typep size 'integer) (> size 0) ))
(assert (find element-type '(integer single-float double-float
(complex (single-float))
(complex (double-float))) :test #'equal))
- (let ((v (make-gsl-vec :size size :element-type element-type)))
- (setf (gsl-vec-ptr v) (alloc v))
+ (let ((v (cond
+ ((eq element-type 'integer)
+ (make-instance 'gsl-vector-integer
+ :size size :element-type element-type))
+ ((eq element-type 'double-float)
+ (make-instance 'gsl-vector-double-float
+ :size size :element-type element-type))
+ ((eq element-type 'single-float)
+ (make-instance 'gsl-vector-single-float
+ :size size :element-type element-type))
+ ((equal element-type '(complex (double-float)))
+ (make-instance 'gsl-vector-complex-double-float
+ :size size :element-type element-type))
+ ((equal element-type '(complex (single-float)))
+ (make-instance 'gsl-vector-complex-single-float
+ :size size :element-type element-type))
+ (t
+ (error "should never get here.")))))
+ (alloc v)
(cond
((and initial-element initial-contents from-file from-binary-file)
(error "can only define one of the keys: initial-element, initial-contents, from-file, from-binary-file."))
(initial-element
- (gsl-vector:set-all v initial-element))
+ (set-all v initial-element))
(initial-contents
(cond
((listp initial-contents)
(do ((x initial-contents (cdr x))
(i 0 (1+ i)))
((= i size))
- (gsl-vector:set-element v i (car x))))
+ (set-element v i (car x))))
((vectorp initial-contents)
(do ((i 0 (1+ i)))
((= i size))
- (gsl-vector:set-element v i (aref initial-contents i))))
+ (set-element v i (aref initial-contents i))))
(t
(error "initial-contents must be either a list or a vector."))))
(from-file
@@ -509,132 +526,19 @@
(free ,vec))))
-(defun write-to-binary-file (file-name v)
- (assert (eq 'gsl-vec (type-of v)))
- (let ((status))
- ;; TODO: check if uffi:with-string returns a result, docs unclear.
- (uffi:with-cstring (c-file-name file-name)
- (setq status
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (wrap-gsl-vector-int-fwrite c-file-name (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (wrap-gsl-vector-float-fwrite c-file-name (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (wrap-gsl-vector-fwrite c-file-name (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (wrap-gsl-vector-complex-float-fwrite c-file-name
- (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (wrap-gsl-vector-complex-fwrite c-file-name (gsl-vec-ptr v)))
- (t
- (error "No matching type")))))
- status))
-
-
-(defun write-to-file (file-name v)
- (assert (eq 'gsl-vec (type-of v)))
- (let ((status))
- (uffi:with-cstring (c-file-name file-name)
- (setq status
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (wrap-gsl-vector-int-fprintf c-file-name (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (wrap-gsl-vector-float-fprintf c-file-name (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (wrap-gsl-vector-fprintf c-file-name (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (wrap-gsl-vector-complex-float-fprintf c-file-name
- (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (wrap-gsl-vector-complex-fprintf c-file-name (gsl-vec-ptr v)))
- (t
- (error "No matching type")))))
- status))
-
-
-(defun subvector (v offset n)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (typep offset 'integer))
- (assert (typep n 'integer))
- (assert (< (+ offset n) (gsl-vec-size v)))
- ;; use make-gsl-vec here rather than make-vector - we do not want to
- ;; allocate any foreign memory for the subvector.
- (let ((v-sub (make-gsl-vec :size n :element-type (gsl-vec-element-type v))))
- (setf (gsl-vec-ptr v-sub)
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (wrap-gsl-vector-int-subvector (gsl-vec-ptr v) offset n))
- ((eq (gsl-vec-element-type v) 'single-float)
- (wrap-gsl-vector-float-subvector (gsl-vec-ptr v) offset n))
- ((eq (gsl-vec-element-type v) 'double-float)
- (wrap-gsl-vector-subvector (gsl-vec-ptr v) offset n))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (wrap-gsl-vector-complex-float-subvector (gsl-vec-ptr v) offset n))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (wrap-gsl-vector-complex-subvector (gsl-vec-ptr v) offset n))
- (t
- (error "No matching type"))))
- v-sub))
-
-
-(defun subvector-with-stride (v offset stride n)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (typep offset 'integer))
- (assert (typep stride 'integer))
- (assert (typep n 'integer))
- (assert (< (* (+ offset n) stride) (gsl-vec-size v)))
- ;; use make-gsl-vec here rather than make-vector - we do not want to
- ;; allocate any foreign memory for the subvector.
- (let ((v-sub (make-gsl-vec :size n :element-type (gsl-vec-element-type v))))
- (setf (gsl-vec-ptr v-sub)
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (wrap-gsl-vector-int-subvector-with-stride (gsl-vec-ptr v)
- offset stride n))
- ((eq (gsl-vec-element-type v) 'single-float)
- (wrap-gsl-vector-float-subvector-with-stride (gsl-vec-ptr v)
- offset stride n))
- ((eq (gsl-vec-element-type v) 'double-float)
- (wrap-gsl-vector-subvector-with-stride (gsl-vec-ptr v)
- offset stride n))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (wrap-gsl-vector-complex-float-subvector-with-stride
- (gsl-vec-ptr v) offset stride n))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (wrap-gsl-vector-complex-subvector-with-stride (gsl-vec-ptr v)
- offset stride n))
- (t
- (error "No matching type"))))
- v-sub))
-
-
-(defun copy (v-src)
- (assert (eq 'gsl-vec (type-of v-src)))
- (let* ((v-dest (make-vector (gsl-vec-size v-src)
- :element-type (gsl-vec-element-type v-src)))
- (status (cond
- ((eq (gsl-vec-element-type v-src) 'integer)
- (gsl-vector-int-memcpy (gsl-vec-ptr v-dest)
- (gsl-vec-ptr v-src)))
- ((eq (gsl-vec-element-type v-src) 'single-float)
- (gsl-vector-float-memcpy (gsl-vec-ptr v-dest)
- (gsl-vec-ptr v-src)))
- ((eq (gsl-vec-element-type v-src) 'double-float)
- (gsl-vector-memcpy (gsl-vec-ptr v-dest)
- (gsl-vec-ptr v-src)))
- ((equal (gsl-vec-element-type v-src)
- '(complex (single-float)))
- (gsl-vector-complex-float-memcpy (gsl-vec-ptr v-dest)
- (gsl-vec-ptr v-src)))
- ((equal (gsl-vec-element-type v-src)
- '(complex (double-float)))
- (gsl-vector-complex-memcpy (gsl-vec-ptr v-dest)
- (gsl-vec-ptr v-src)))
- (t
- (error "No matching type")))))
- (values v-dest status)))
+(defmacro def-vector-copy-method% (class-string func-string)
+ (let ((class-object (kmrcl:concat-symbol "gsl-vector-" class-string)))
+ `(defmethod copy ((o ,class-object))
+ (let* ((o-copy (make-vector (size o) :element-type (element-type o)))
+ (status (,(kmrcl:concat-symbol "gsl-vector-" func-string
+ "memcpy") (ptr o-copy) (ptr o))))
+ (values o-copy status)))))
+
+(def-vector-copy-method% "integer" "int-")
+(def-vector-copy-method% "single-float" "float-")
+(def-vector-copy-method% "double-float" "")
+(def-vector-copy-method% "complex-single-float" "complex-float-")
+(def-vector-copy-method% "complex-double-float" "complex-")
(defmacro with-vector-copy ((vec-dest vec-src) &body body)
@@ -644,278 +548,9 @@
(free ,vec-dest))))
-(defun swap (va vb)
- (assert (eq 'gsl-vec (type-of va)))
- (assert (eq 'gsl-vec (type-of vb)))
- (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
- (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
- (let ((status
- (cond
- ((eq (gsl-vec-element-type va) 'integer)
- (gsl-vector-int-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'single-float)
- (gsl-vector-float-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'double-float)
- (gsl-vector-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((equal (gsl-vec-element-type va) '(complex (single-float)))
- (gsl-vector-complex-float-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((equal (gsl-vec-element-type va) '(complex (double-float)))
- (gsl-vector-complex-swap (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- (t
- (error "No matching type")))))
- (values va status)))
-
-
-(defun swap-elements (v i j)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (typep i 'integer))
- (assert (typep j 'integer))
- (assert (< i (gsl-vec-size v)))
- (assert (< j (gsl-vec-size v)))
- (let ((status
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-swap-elements (gsl-vec-ptr v) i j))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-swap-elements (gsl-vec-ptr v) i j))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-swap-elements (gsl-vec-ptr v) i j))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (gsl-vector-complex-float-swap-elements (gsl-vec-ptr v) i j))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (gsl-vector-complex-swap-elements (gsl-vec-ptr v) i j))
- (t
- (error "No matching type")))))
- (values v status)))
-
-
-(defun reverse-vector (v)
- (assert (eq 'gsl-vec (type-of v)))
- (let ((status
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-reverse (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-reverse (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-reverse (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (gsl-vector-complex-float-reverse (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (gsl-vector-complex-reverse (gsl-vec-ptr v)))
- (t
- (error "No matching type")))))
- (values v status)))
-
-
-(defun add (va vb)
- (assert (eq 'gsl-vec (type-of va)))
- (assert (eq 'gsl-vec (type-of vb)))
- (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
- (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
- (let ((status
- (cond
- ((eq (gsl-vec-element-type va) 'integer)
- (gsl-vector-int-add (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'single-float)
- (gsl-vector-float-add (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'double-float)
- (gsl-vector-add (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- (t
- (error "No matching type")))))
- (values va status)))
-
-
-(defun sub (va vb)
- (assert (eq 'gsl-vec (type-of va)))
- (assert (eq 'gsl-vec (type-of vb)))
- (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
- (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
- (let ((status
- (cond
- ((eq (gsl-vec-element-type va) 'integer)
- (gsl-vector-int-sub (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'single-float)
- (gsl-vector-float-sub (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'double-float)
- (gsl-vector-sub (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- (t
- (error "No matching type")))))
- (values va status)))
-
-
-(defun mul (va vb)
- (assert (eq 'gsl-vec (type-of va)))
- (assert (eq 'gsl-vec (type-of vb)))
- (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
- (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
- (let ((status
- (cond
- ((eq (gsl-vec-element-type va) 'integer)
- (gsl-vector-int-mul (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'single-float)
- (gsl-vector-float-mul (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'double-float)
- (gsl-vector-mul (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- (t
- (error "No matching type")))))
- (values va status)))
-
-
-(defun div (va vb)
- (assert (eq 'gsl-vec (type-of va)))
- (assert (eq 'gsl-vec (type-of vb)))
- (assert (eq (gsl-vec-element-type va) (gsl-vec-element-type vb)))
- (assert (= (gsl-vec-size va) (gsl-vec-size vb)))
- (let ((status
- (cond
- ((eq (gsl-vec-element-type va) 'integer)
- (gsl-vector-int-div (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'single-float)
- (gsl-vector-float-div (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- ((eq (gsl-vec-element-type va) 'double-float)
- (gsl-vector-div (gsl-vec-ptr va) (gsl-vec-ptr vb)))
- (t
- (error "No matching type")))))
- (values va status)))
-
-
-(defun scale (v x)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (typep x (gsl-vec-element-type v)))
- (let ((status
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- ;; coerce to double-float looks wrong, but isn't.
- (gsl-vector-int-scale (gsl-vec-ptr v) (coerce x 'double-float)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-scale (gsl-vec-ptr v) (coerce x 'double-float)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-scale (gsl-vec-ptr v) x))
- (t
- (error "No matching type")))))
- (values v status)))
-
-
-(defun add-constant (v x)
- (assert (eq 'gsl-vec (type-of v)))
- (assert (typep x (gsl-vec-element-type v)))
- (let ((status
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-add-constant (gsl-vec-ptr v)
- (coerce x 'double-float)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-add-constant (gsl-vec-ptr v)
- (coerce x 'double-float)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-add-constant (gsl-vec-ptr v) x))
- (t
- (error "No matching type")))))
- (values v status)))
-
-
-(defun max-value (v)
- (assert (eq 'gsl-vec (type-of v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-max (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-max (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-max (gsl-vec-ptr v)))
- (t
- (error "No matching type"))))
-
-
-(defun min-value (v)
- (assert (eq 'gsl-vec (type-of v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-min (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-min (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-min (gsl-vec-ptr v)))
- (t
- (error "No matching type"))))
-
-
-(defun max-index (v)
- (assert (eq 'gsl-vec (type-of v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-max-index (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-max-index (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-max-index (gsl-vec-ptr v)))
- (t
- (error "No matching type"))))
-
-
-(defun min-index (v)
- (assert (eq 'gsl-vec (type-of v)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-min-index (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-min-index (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-min-index (gsl-vec-ptr v)))
- (t
- (error "No matching type"))))
-
-
-(defun min-max-indicies (v)
- (assert (eq 'gsl-vec (type-of v)))
- (let ((min-ptr (uffi:allocate-foreign-object 'size-t))
- (max-ptr (uffi:allocate-foreign-object 'size-t)))
- (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-minmax-index (gsl-vec-ptr v) min-ptr max-ptr))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-minmax-index (gsl-vec-ptr v) min-ptr max-ptr))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-minmax-index (gsl-vec-ptr v) min-ptr max-ptr))
- (t
- (error "No matching type")))
- (prog1
- (list (uffi:deref-pointer min-ptr 'size-t)
- (uffi:deref-pointer max-ptr 'size-t))
- (uffi:free-foreign-object min-ptr)
- (uffi:free-foreign-object max-ptr))))
-
-
-(defun min-max-values (v)
- (assert (eq 'gsl-vec (type-of v)))
- (destructuring-bind (min-index max-index)
- (min-max-indicies v)
- (list (get-element v min-index)
- (get-element v max-index))))
-
-
-(defun isnull (v)
- (assert (eq 'gsl-vec (type-of v)))
- (1/0->t/nil (cond
- ((eq (gsl-vec-element-type v) 'integer)
- (gsl-vector-int-isnull (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'single-float)
- (gsl-vector-float-isnull (gsl-vec-ptr v)))
- ((eq (gsl-vec-element-type v) 'double-float)
- (gsl-vector-isnull (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (single-float)))
- (gsl-vector-complex-float-isnull (gsl-vec-ptr v)))
- ((equal (gsl-vec-element-type v) '(complex (double-float)))
- (gsl-vector-complex-isnull (gsl-vec-ptr v)))
- (t
- (error "No matching type")))))
-
-
(defun gsl->lisp-vector (v)
- (assert (eq 'gsl-vec (type-of v)))
- (let ((a (make-array (gsl-vec-size v) :element-type (gsl-vec-element-type v))))
- (dotimes (i (gsl-vec-size v) a)
+ (let ((a (make-array (size v) :element-type (element-type v))))
+ (dotimes (i (size v) a)
(setf (aref a i) (get-element v i)))))
;; Function: gsl_vector_view gsl_vector_complex_real (gsl_vector_complex *v)
More information about the Cl-gsl-cvs
mailing list