From 9e2e1c54dd2538e9c0f0f3a73a392a6f593c4bff Mon Sep 17 00:00:00 2001
From: Mirko Vukovic <mirko.vukovic@gmail.com>
Date: Fri, 27 Nov 2015 21:53:27 -0500
Subject: [PATCH 5/5] Adapted data/permutation.lisp to use GSL's native 
 structure

- The class PERMUTATION holds a foreign pointer to GSL's native
  permutation pointer
- It is accessed by MPOINTER, making it accessible via existing
  GSLL's messaging mechanism
- INITIALIZE-INSTANCE creates an empty or identity permutation
  by calling appropriate GSL functions
- I did not know how to test pointer cleanup
- MAKE-permutation was fixed to create a permutation copy as per
  the function documentation
- Added a test for that at end of file
- Modified PRINT-OBJECT for new permutation class
- Rearanged code in file (a matter of taste)
---
 .gitignore            |   4 ++
 data/permutation.lisp | 166 +++++++++++++++++++++++++++++++-------------------
 2 files changed, 106 insertions(+), 64 deletions(-)
 create mode 100644 .gitignore

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..a073471
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+*/*.lisp~
+*.wx64fsl
+*~
+*.fasl
diff --git a/data/permutation.lisp b/data/permutation.lisp
index 46967ed..1a4263e 100644
--- a/data/permutation.lisp
+++ b/data/permutation.lisp
@@ -1,6 +1,6 @@
 ;; Permutations
 ;; Liam Healy, Sun Mar 26 2006 - 11:51
-;; Time-stamp: <2014-12-08 23:19:56EST permutation.lisp>
+;; Time-stamp: <2015-11-27 21:52:04Eastern Standard Time permutation.lisp>
 ;;
 ;; Copyright 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2014 Liam M. Healy
 ;; Distributed under the terms of the GNU General Public License
@@ -26,43 +26,107 @@
 ;;;;****************************************************************************
 ;;;; Permutation structure and CL object
 ;;;;****************************************************************************
-   
-(defclass permutation
-    (#+int64 grid:vector-unsigned-byte-64 #+int32 grid:vector-unsigned-byte-32)
-  ()
+
+;;; I use the CLOS PERMUTATION object to store a foreign pointer GSL's
+;;; pointer structure.  I use the reader MPOINTER to access this
+;;; pointer.
+
+(defclass permutation ()
+  ((pointer :reader mpointer
+	    :documentation "Pointer to GSL's permutation object"))
   (:documentation "GSL permutations."))
 
 (defmethod initialize-instance :after
-    ((object permutation) &key dimensions &allow-other-keys)
-  (let ((mptr (cffi:foreign-alloc 'gsl-permutation-c)))
-    (setf (grid:metadata-slot object 'mpointer)
-	  mptr
-	  (cffi:foreign-slot-value mptr 'gsl-permutation-c 'data)
-	  (grid:foreign-pointer object)
-	  (cffi:foreign-slot-value mptr 'gsl-permutation-c 'size)
-	  (first dimensions))
-    (tg:finalize object (lambda () (cffi:foreign-free mptr)))))
+    ((object permutation) &key dimensions identity
+			    &allow-other-keys)
+  (let* ((dim0 (first dimensions))
+	 (permutation* (if identity
+			   (cffi:foreign-funcall "gsl_permutation_calloc"
+						 :sizet dim0
+						 :pointer)
+			   (cffi:foreign-funcall "gsl_permutation_alloc"
+						 :sizet dim0
+						 :pointer))))
+    (setf (slot-value object 'pointer) permutation*)
+    (tg:finalize object
+		 (lambda ()
+		   (cffi:foreign-funcall "gsl_permutation_free"
+					 :pointer (mpointer object)
+					 :int)))
+    object))
 
 (export 'make-permutation)
 (defun make-permutation (n &optional (initialize t))
   "Make the object representing a permutation of n objects.
-   If n is a permutation, make a new permutation of the same size.  If
+   If n is a permutation, make a new permutation of that size.  If
    initialize is T (default), set to the identity permutation if n is
    an integer, or copy the permutation if it's a permutation."
   (let ((perm
 	 (make-instance
 	  'permutation
-	  :element-type '(unsigned-byte #+int64 64 #+int32 32)
-	  :dimensions (if (typep n 'permutation) (grid:dimensions n) (list n)))))
+	  :dimensions (if (typep n 'permutation) (grid:dimensions n) (list n))
+	  :identity initialize)))
     (when initialize
       (if (typep n 'permutation)
-	  (error "not available yet")	; (copy perm n)
+	  #+skip(error "not available yet")    
+	  (grid:copy perm)
 	  (set-identity perm)))
     perm))
 
 (defmethod print-object ((object permutation) stream)
-  (print-unreadable-object (object stream :type t)
-    (princ (grid:contents object) stream)))
+  (print-unreadable-object (object stream :type t :identity t)
+    (format stream "-- size: ~a" (size object))))
+
+
+;;;;****************************************************************************
+;;;; Permutation properties
+;;;;****************************************************************************
+
+(defmfun size ((p permutation))
+  "gsl_permutation_size"
+  (((mpointer p) :pointer))
+  :definition :method
+  :c-return :sizet
+  :inputs (p)
+  :documentation			; FDL
+  "The size of the permutation p.")
+
+(defmfun permutation-data (p)
+  "gsl_permutation_data"
+  (((mpointer p) :pointer))
+  :c-return :pointer
+  :inputs (p)
+  :documentation			; FDL
+  "A pointer to the array of elements in the
+   permutation p.")
+
+(export 'validp)
+(defgeneric validp (object)
+  (:documentation			; FDL
+   "Check that the object p is valid."))
+
+(defmfun validp ((permutation permutation))
+  "gsl_permutation_valid"
+  (((mpointer permutation) :pointer))
+  :definition :method
+  :c-return :success-failure
+  :inputs (permutation)
+  :documentation			; FDL
+  "Check that the permutation p is valid.  The n
+  elements should contain each of the numbers 0 to n-1 once and only
+  once.")
+
+(defmethod grid:aref ((permutation permutation) &rest indices)
+  (let ((i (first indices)))
+    (assert (< i (size permutation)) ()
+	    "Index ~a out of bounds" i)
+    (cffi:foreign-funcall "gsl_permutation_get" 
+			  :pointer (mpointer permutation)
+			  :sizet i
+			  :sizet)))
+
+(defmethod grid:dimensions ((permutation permutation))
+  (list (size permutation)))
 
 ;;;;****************************************************************************
 ;;;; Setting values
@@ -93,9 +157,22 @@
    permutation destination.  The two permutations must have the same size.")
 
 (defmethod grid:copy
-    ((source permutation) &key grid-type destination &allow-other-keys)
+    ((source permutation) &rest named-pairs
+     &key grid-type destination &allow-other-keys)
   (if grid-type
-      (call-next-method)
+      ;; When returning a grid (array or foreign array), I first
+      ;; repackage the contents as an array, and then call GRID:COPY
+      (let* ((contents (grid:contents source))
+	     (arr (make-array (size source) :initial-contents 
+			      contents)))
+	;; CALL-NEXT-METHOD insisted on passing a permutation as first
+	;; argument, irrespective of what I typed in.  I reverted to
+	;; calling COPY instead.
+	(apply #'grid:copy arr
+	       :grid-type grid-type
+	       :destination destination
+	       :allow-other-keys t
+	       named-pairs))
       (perm-copy
        source (or destination (make-permutation (size source))))))
 
@@ -110,44 +187,6 @@
   "Exchanges the ith and jth elements of the permutation p.")
 
 ;;;;****************************************************************************
-;;;; Permutation properties
-;;;;****************************************************************************
-
-(defmfun size ((p permutation))
-  "gsl_permutation_size"
-  (((mpointer p) :pointer))
-  :definition :method
-  :c-return :sizet
-  :inputs (p)
-  :documentation			; FDL
-  "The size of the permutation p.")
-
-(defmfun permutation-data (p)
-  "gsl_permutation_data"
-  (((mpointer p) :pointer))
-  :c-return :pointer
-  :inputs (p)
-  :documentation			; FDL
-  "A pointer to the array of elements in the
-   permutation p.")
-
-(export 'validp)
-(defgeneric validp (object)
-  (:documentation			; FDL
-   "Check that the object p is valid."))
-
-(defmfun validp ((permutation permutation))
-  "gsl_permutation_valid"
-  (((mpointer permutation) :pointer))
-  :definition :method
-  :c-return :success-failure
-  :inputs (permutation)
-  :documentation			; FDL
-  "Check that the permutation p is valid.  The n
-  elements should contain each of the numbers 0 to n-1 once and only
-  once.")
-
-;;;;****************************************************************************
 ;;;; Permutation functions
 ;;;;****************************************************************************
 
@@ -342,23 +381,22 @@
    (grid:aref perm-1 2))
  (let ((perm-1 (make-permutation 4 t)))	;grid:contents
    (grid:contents perm-1))
+ (let* ((perm-0 (make-permutation 4 t))
+	(perm-1 (make-permutation perm-0 t)))	;make-permutation makes a copy
+   (grid:contents perm-1))
  (let ((perm-1 (make-permutation 4 t)))	;permutation-reverse
-   (set-identity perm-1)
    (grid:contents (permutation-reverse perm-1)))
  (let				;permutation-next, permutation-inverse
      ((perm-1 (make-permutation 4 t)))
-   (set-identity perm-1)
    (permutation-next perm-1)
    (permutation-next perm-1)
    (permutation-next perm-1)
    (grid:contents (permutation-inverse perm-1)))
  (let ((perm-1 (make-permutation 4 t)))	;swap-elements
-   (set-identity perm-1)
    (swap-elements perm-1 1 3)
    (grid:contents perm-1))
  (let ((perm-1 (make-permutation 4 t))	;permute-vector
        (intvec (grid:make-foreign-array '(signed-byte 32) :initial-contents '(11 22 33 44))))
-   (set-identity perm-1)
    (swap-elements perm-1 1 3)
    (swap-elements perm-1 0 2)
    (permute perm-1 intvec)
-- 
2.6.3

