From efa2315f574040cd29ddf45f87ff88e248cb5068 Mon Sep 17 00:00:00 2001
From: Liam Healy <lnp@healy.washington.dc.us>
Date: Fri, 20 Mar 2009 14:25:27 -0400
Subject: [PATCH] Extend #'copy to copy to or from mpointers

Both copy-to-array and copy-making-destination have been extended so
that an mpointer can occur as the first or second argument.  If the
first argument, the second argument should be a symbol representing a
subclass of marray.  If the second argument is not present
(copy-making-destination), 'vector-double-float is assumed.  If the
mpointer is the second argument, the marray contents are copied into
its contents.  These methods are useful for callbacks and GSL
functions that send raw mpointers.  For example, a callback that uses
foreign arrays directly can simply copy from and to them.  This has
been applied in the solve-minimize-fit functions that return a raw
mpointer, replacing the explicit call to make-marray.  The first
argument to #'marray can now be either the class name or element-type.
---
 data/marray.lisp                              | 54 +++++++++++++------
 data/matrix.lisp                              | 12 ++++-
 data/vector.lisp                              | 10 +++-
 documentation/index.html                      |  9 +++-
 init/mobject.lisp                             |  7 +--
 solve-minimize-fit/minimization-multi.lisp    |  8 +--
 .../nonlinear-least-squares.lisp              | 10 ++--
 solve-minimize-fit/roots-multi.lisp           | 14 ++---
 8 files changed, 81 insertions(+), 43 deletions(-)

diff --git a/data/marray.lisp b/data/marray.lisp
index 225e68c4..1c21f817 100644
--- a/data/marray.lisp
+++ b/data/marray.lisp
@@ -1,6 +1,6 @@
 ;; A "marray" is an array in both GSL and CL
 ;; Liam Healy 2008-04-06 21:23:41EDT
-;; Time-stamp: <2009-03-16 09:36:00EDT marray.lisp>
+;; Time-stamp: <2009-03-20 11:33:31EDT marray.lisp>
 ;; $Id$
 
 (in-package :gsl)
@@ -118,13 +118,14 @@
 
 (export 'make-marray)
 (defun make-marray
-    (element-type &rest keys &key dimensions initial-contents from-pointer cl-array
+    (class-or-element-type &rest keys &key dimensions initial-contents from-pointer cl-array
      &allow-other-keys)
   "Make a GSLL array with the given element type,
    :dimensions, and :initial-contents, :initial-element or :cl-array.
    If the :cl-array is supplied, it should be a CL array generated with #'make-ffa.
    If a pointer to a GSL object is given in :from-pointer, create
-   an object with duplicate contents; if a matrix, :dimensions must be set to 2."
+   an object with duplicate contents; if a matrix, :dimensions must be a list
+   of length 2 (contents are unimportant)."
   ;; Some functions in solve-minimize-fit return a pointer to a GSL
   ;; vector of double-floats.  With the :from-pointer argument, this
   ;; function turn that into a foreign-friendly array.  There is no
@@ -132,21 +133,27 @@
   ;; because GSL is doing the mallocing, the data are not
   ;; CL-accessible.
   (if from-pointer
-      (make-marray element-type
+      (make-marray class-or-element-type
 		   :initial-contents
 		   (contents-from-pointer
 		    from-pointer
-		    (if (eql dimensions 2) 'gsl-matrix-c 'gsl-vector-c)
-		    element-type))
+		    (if (and (listp dimensions)
+			     (eql (length dimensions) 2))
+			'gsl-matrix-c 'gsl-vector-c)
+		    (if (subtypep class-or-element-type 'marray)
+			(lookup-type class-or-element-type *class-element-type*)
+			class-or-element-type)))
       (apply #'make-instance
-	     (data-class-name
-	      (if
-	       (or
-		(and dimensions (listp dimensions) (eql (length dimensions) 2))
-		(and initial-contents (listp (first initial-contents)))
-		(and cl-array (eql (length (array-dimensions cl-array)) 2)))
-	       'matrix 'vector)
-	      element-type)
+	     (if (subtypep class-or-element-type 'marray)
+		 class-or-element-type
+		 (data-class-name
+		  (if
+		   (or
+		    (and dimensions (listp dimensions) (eql (length dimensions) 2))
+		    (and initial-contents (listp (first initial-contents)))
+		    (and cl-array (eql (length (array-dimensions cl-array)) 2)))
+		   'matrix 'vector)
+		  class-or-element-type))
 	     keys)))
 
 (defun hashm-numeric-code (n)
@@ -183,7 +190,22 @@
       (total-size object)))
 
 ;;;;****************************************************************************
-;;;; C structures
+;;;; Copy to and from bare mpointers 
 ;;;;****************************************************************************
 
-;;; For #-native, do the whole thing using _alloc, _free functions.
+(defgeneric contents-from-pointer (pointer struct-type &optional element-type)
+  (:documentation
+   "Create a contents list from the GSL object of type struct-type
+    referenced by pointer."))
+
+(defmethod copy-making-destination ((pointer #.+foreign-pointer-class+))
+  (if (typep pointer +foreign-pointer-type+)
+      ;; Default assumption when destination isn't given in #'copy is
+      ;; that this should make a vector-double-float.
+      (copy-to-destination pointer 'vector-double-float)
+      (call-next-method)))
+
+(defmethod copy-to-destination ((pointer #.+foreign-pointer-class+) (class-name symbol))
+  (if (typep pointer +foreign-pointer-type+)
+      (make-marray class-name :from-pointer pointer)
+      (call-next-method)))
diff --git a/data/matrix.lisp b/data/matrix.lisp
index 84a2474f..427f62b2 100644
--- a/data/matrix.lisp
+++ b/data/matrix.lisp
@@ -1,6 +1,6 @@
 ;; Matrices
 ;; Liam Healy 2008-04-15 21:57:52EDT matrix.lisp
-;; Time-stamp: <2009-03-18 14:45:31EDT matrix.lisp>
+;; Time-stamp: <2009-03-20 10:48:31EDT matrix.lisp>
 ;; $Id$
 
 (in-package :gsl)
@@ -35,6 +35,16 @@
        collect (loop for j below dim1
 		  collect (maref pointer i j element-type)))))
 
+(defmethod copy-to-destination
+    ((object matrix) (pointer #.+foreign-pointer-class+))
+  (if (typep pointer +foreign-pointer-type+)
+      (loop for i below (dim0 object)
+	 do (loop for j below (dim1 object)
+	       do
+	       (setf (maref pointer i j (element-type object))
+		     (maref object i j))))
+      (call-next-method)))
+
 ;;;;****************************************************************************
 ;;;; Mathematical
 ;;;;****************************************************************************
diff --git a/data/vector.lisp b/data/vector.lisp
index 49e28dcd..19aa1190 100644
--- a/data/vector.lisp
+++ b/data/vector.lisp
@@ -1,6 +1,6 @@
 ;; Vectors
 ;; Liam Healy 2008-04-13 09:39:02EDT vector.lisp
-;; Time-stamp: <2008-12-28 18:01:59EST vector.lisp>
+;; Time-stamp: <2009-03-20 10:37:55EDT vector.lisp>
 ;; $Id$
 
 (in-package :gsl)
@@ -30,6 +30,14 @@
   (loop for i below (cffi:foreign-slot-value pointer struct-type 'size)
      collect (maref pointer i nil element-type)))
 
+(defmethod copy-to-destination
+    ((object mvector) (pointer #.+foreign-pointer-class+))
+  (if (typep pointer +foreign-pointer-type+)
+      (loop for i below (dim0 object)
+	   do (setf (maref pointer i nil (element-type object))
+		    (maref object i)))
+      (call-next-method)))
+
 ;;;;****************************************************************************
 ;;;; Function definitions
 ;;;;****************************************************************************
diff --git a/documentation/index.html b/documentation/index.html
index 4ec0427d..70caeaf5 100644
--- a/documentation/index.html
+++ b/documentation/index.html
@@ -303,7 +303,12 @@ area of memory.</p>
  with <code>setf maref</code>.  A complete CL array may
  be extracted with the function <code>#'cl-array</code>.
 </p>
-
+<p>Copying marrays is performed with the function <code>copy</code>.
+  This works between marrays, pointers, and CL arrays.  It is useful
+  for functions intended to be passed to GSL functions (for
+  e.g. solving, minimizing or fitting) that need to set a GSL vector
+  or matrix, because one can simply copy into the passed-in pointer.
+</p>
  <h3>Passing functions</h3>
  <p>
  Functions that are passed to GSL functions (known as <i>callbacks</i>
@@ -391,7 +396,7 @@ and arrays used internally or for function return.
 <!-- Created: Feb 25 2005 -->
 <!-- hhmts start -->
 <small>
-Time-stamp: <2009-03-10 21:00:47EDT index.html>
+Time-stamp: <2009-03-20 11:54:53EDT index.html>
 </small>
 <!-- hhmts end -->
  </div>
diff --git a/init/mobject.lisp b/init/mobject.lisp
index acd2b0d6..ad39c0a3 100644
--- a/init/mobject.lisp
+++ b/init/mobject.lisp
@@ -1,6 +1,6 @@
 ;; Definition of GSL objects and ways to use them.
 ;; Liam Healy, Sun Dec  3 2006 - 10:21
-;; Time-stamp: <2009-02-24 15:36:40EST mobject.lisp>
+;; Time-stamp: <2009-03-20 10:22:49EDT mobject.lisp>
 
 ;;; GSL objects are represented in GSLL as and instance of a 'mobject.
 ;;; The macro demobject takes care of defining the appropriate
@@ -250,11 +250,6 @@
 ;;; over the data even on native implementations; because GSL is doing
 ;;; the mallocing, the data are not CL-accessible.
 
-(defgeneric contents-from-pointer (pointer struct-type &optional element-type)
-  (:documentation
-   "Create a contents list from the GSL object of type struct-type
-    referenced by pointer."))
-
 (defmethod mpointer ((object #.+foreign-pointer-class+))
   (check-type object #.+foreign-pointer-type+)
   object)
diff --git a/solve-minimize-fit/minimization-multi.lisp b/solve-minimize-fit/minimization-multi.lisp
index ebd822ac..a7038f3b 100644
--- a/solve-minimize-fit/minimization-multi.lisp
+++ b/solve-minimize-fit/minimization-multi.lisp
@@ -1,6 +1,6 @@
 ;; Multivariate minimization.
 ;; Liam Healy  <Tue Jan  8 2008 - 21:28>
-;; Time-stamp: <2009-02-26 13:55:22EST minimization-multi.lisp>
+;; Time-stamp: <2009-03-19 11:19:31EDT minimization-multi.lisp>
 ;; $Id$
 
 (in-package :gsl)
@@ -148,7 +148,7 @@
   (((mpointer minimizer) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The current best estimate of the location of the minimum.")
 
@@ -157,7 +157,7 @@
   (((mpointer minimizer) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The current best estimate of the location of the minimum.")
 
@@ -188,7 +188,7 @@
   "gsl_multimin_fdfminimizer_gradient"
   (((mpointer minimizer) :pointer))
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The current best estimate of the gradient for the minimizer.")
 
diff --git a/solve-minimize-fit/nonlinear-least-squares.lisp b/solve-minimize-fit/nonlinear-least-squares.lisp
index 6fddfa5a..4802598c 100644
--- a/solve-minimize-fit/nonlinear-least-squares.lisp
+++ b/solve-minimize-fit/nonlinear-least-squares.lisp
@@ -1,6 +1,6 @@
 ;; Nonlinear least squares fitting.
 ;; Liam Healy, 2008-02-09 12:59:16EST nonlinear-least-squares.lisp
-;; Time-stamp: <2009-02-16 10:16:06EST nonlinear-least-squares.lisp>
+;; Time-stamp: <2009-03-19 11:13:41EDT nonlinear-least-squares.lisp>
 ;; $Id$
 
 (in-package :gsl)
@@ -157,7 +157,7 @@
   (((mpointer solver) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The current best-fit parameters.")
 
@@ -166,15 +166,13 @@
   (((mpointer solver) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The current best-fit parameters.")
 
 ;;; Why doesn't GSL have functions to extract these values?
 (defmethod function-value ((solver nonlinear-fdffit))
-  (make-marray
-   'double-float
-   :from-pointer
+  (copy
    (cffi:foreign-slot-value (mpointer solver) 'gsl-fdffit-solver 'f)))
 
 (defmethod last-step ((solver nonlinear-fdffit))
diff --git a/solve-minimize-fit/roots-multi.lisp b/solve-minimize-fit/roots-multi.lisp
index 4466a1c2..629bf69e 100644
--- a/solve-minimize-fit/roots-multi.lisp
+++ b/solve-minimize-fit/roots-multi.lisp
@@ -1,6 +1,6 @@
 ;;; Multivariate roots.                
 ;;; Liam Healy 2008-01-12 12:49:08
-;;; Time-stamp: <2009-02-16 09:56:43EST roots-multi.lisp>
+;;; Time-stamp: <2009-03-20 11:33:58EDT roots-multi.lisp>
 ;;; $Id$
 
 (in-package :gsl)
@@ -143,7 +143,7 @@
   (((mpointer solver) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The current estimate of the root for the solver.")
 
@@ -152,7 +152,7 @@
   (((mpointer solver) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation
   "The current estimate of the root for the solver.")
 
@@ -161,7 +161,7 @@
   (((mpointer solver) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The function value f(x) at the current estimate x of the root for the solver.")
 
@@ -170,7 +170,7 @@
   (((mpointer solver) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The function value f(x) at the current estimate x of the root for the solver.")
 
@@ -179,7 +179,7 @@
   (((mpointer solver) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The last step dx taken by the solver.")
 
@@ -188,7 +188,7 @@
   (((mpointer solver) :pointer))
   :definition :method
   :c-return (crtn :pointer)
-  :return ((make-marray 'double-float :from-pointer crtn))
+  :return ((copy crtn))
   :documentation			; FDL
   "The last step dx taken by the solver.")
 
-- 
GitLab