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)