Commit d6a0d879 authored by Liam Healy's avatar Liam Healy
Browse files

Port permutation to foreign-array

parent 827d6818
;; Permutations
;; Liam Healy, Sun Mar 26 2006 - 11:51
;; Time-stamp: <2010-06-27 18:14:06EDT permutation.lisp>
;; Time-stamp: <2010-06-28 21:56:26EDT permutation.lisp>
;;
;; Copyright 2006, 2007, 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -27,23 +27,20 @@
;;;; Permutation structure and CL object
;;;;****************************************************************************
(defclass permutation (mobject grid:foreign-array)
((element-type
:initform
#+int64 '(unsigned-byte 64)
#+int32 '(unsigned-byte 32)
:reader element-type :allocation :class))
(defclass permutation
(#+int64 grid:vector-unsigned-byte-64 #+int32 grid:vector-unsigned-byte-32)
()
(:documentation "GSL permutations."))
(defmethod initialize-instance :after
((object permutation) &key dimensions &allow-other-keys)
(let ((mptr (cffi:foreign-alloc 'gsl-permutation-c)))
(setf (slot-value object 'mpointer)
(setf (metadata-slot object 'mpointer)
mptr
(cffi:foreign-slot-value mptr 'gsl-permutation-c 'data)
(foreign-pointer object)
(cffi:foreign-slot-value mptr 'gsl-permutation-c 'size)
dimensions)
(first dimensions))
(tg:finalize object (lambda () (cffi:foreign-free mptr)))))
(export 'make-permutation)
......@@ -55,13 +52,21 @@
(let ((perm
(make-instance
'permutation
:dimensions (if (typep n 'permutation) (dimensions n) n))))
:element-type '(unsigned-byte #+int64 64 #+int32 32)
:dimensions (if (typep n 'permutation) (dimensions n) (list n)))))
;; It is necessary to change class because the initialize-instance
;; :after method for grid:foreign-array changes to the vector class.
(change-class perm 'permutation)
(when initialize
(if (typep n 'permutation)
(copy perm n)
(error "not available yet") ; (copy perm n)
(set-identity perm)))
perm))
(defmethod print-object ((object permutation) stream)
(print-unreadable-object (object stream :type t)
(princ (grid:contents object) stream)))
;;;;****************************************************************************
;;;; Setting values
;;;;****************************************************************************
......@@ -77,6 +82,7 @@
"Initialize the permutation p to the identity, i.e.
(0,1,2,...,n-1).")
#|
(defmfun grid:copy-to-destination ((source permutation) (destination permutation))
"gsl_permutation_memcpy"
(((mpointer destination) :pointer)
......@@ -89,6 +95,7 @@
:documentation ; FDL
"Copy the elements of the permutation source into the
permutation destination. The two permutations must have the same size.")
|#
(defmfun swap-elements ((p permutation) i j)
"gsl_permutation_swap"
......@@ -152,7 +159,7 @@
:documentation ; FDL
"Reverse the order of the elements of the permutation p.")
(defmfun permutation-inverse (inv p)
(defmfun permutation-inverse (p &optional (inv (make-permutation (size p))))
"gsl_permutation_inverse"
(((mpointer inv) :pointer) ((mpointer p) :pointer))
:inputs (p)
......@@ -265,7 +272,7 @@
;;;; Permutations in cyclic form
;;;;****************************************************************************
(defmfun linear-to-canonical (q p)
(defmfun linear-to-canonical (p &optional (q (make-permutation (size p))))
"gsl_permutation_linear_to_canonical"
(((mpointer q) :pointer) ((mpointer p) :pointer))
:inputs (p)
......@@ -274,7 +281,7 @@
"Compute the canonical form of the permutation p and
stores it in the output argument q.")
(defmfun canonical-to-linear (p q)
(defmfun canonical-to-linear (q &optional (p (make-permutation (size q))))
"gsl_permutation_canonical_to_linear"
(((mpointer p) :pointer) ((mpointer q) :pointer))
:inputs (q)
......@@ -317,25 +324,25 @@
"Generate all the permutations of n objects."
(let ((perm (make-permutation n)))
(set-identity perm)
(loop collect (copy-seq (cl-array perm))
while (permutation-next perm))))
(loop collect (grid:contents perm)
while (nth-value 1 (permutation-next perm)))))
(defun generate-all-permutations-backwards (n)
"Generate all the permutations of n objects."
(let ((perm (make-permutation n)))
(set-identity perm)
(permutation-reverse perm)
(loop collect (copy-seq (cl-array perm))
while (permutation-previous perm))))
(loop collect (grid:contents perm)
while (nth-value 1 (permutation-previous perm)))))
(save-test permutation
(let ((perm-1 (make-permutation 4 t))) ;maref
(grid:gref perm-1 2))
(let ((perm-1 (make-permutation 4 t))) ;cl-array
(cl-array perm-1))
(let ((perm-1 (make-permutation 4 t))) ;grid:contents
(grid:contents perm-1))
(let ((perm-1 (make-permutation 4 t))) ;permutation-reverse
(set-identity perm-1)
(cl-array (permutation-reverse perm-1)))
(grid:contents (permutation-reverse perm-1)))
(let ;permutation-next, permutation-inverse
((perm-1 (make-permutation 4 t)) (perm-2 (make-permutation 4 t)))
(set-identity perm-1)
......@@ -343,18 +350,18 @@
(permutation-next perm-1)
(permutation-next perm-1)
(permutation-inverse perm-2 perm-1)
(cl-array perm-2))
(grid:contents perm-2))
(let ((perm-1 (make-permutation 4 t))) ;swap-elements
(set-identity perm-1)
(swap-elements perm-1 1 3)
(cl-array perm-1))
(grid:contents perm-1))
(let ((perm-1 (make-permutation 4 t)) ;permute-vector
(intvec #31m(11 22 33 44)))
(set-identity perm-1)
(swap-elements perm-1 1 3)
(swap-elements perm-1 0 2)
(permute perm-1 intvec)
(cl-array intvec))
(grid:contents intvec))
(let ((perm-1 (make-permutation 4 t))) ;inversions
(set-identity perm-1)
(swap-elements perm-1 1 3)
......
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2010-06-27 22:15:09EDT gsll.asd>
;; Time-stamp: <2010-06-28 21:18:11EDT gsll.asd>
;;
;; Copyright 2006, 2007, 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -80,7 +80,7 @@
(:file "both" :depends-on ("foreign-array" "vector" "matrix"))
;(:file "copy-cl")
(:file "array-tests" :depends-on ("both"))
;(:file "permutation" :depends-on ("foreign-array" "array-structs"))
(:file "permutation" :depends-on ("foreign-array" "array-structs"))
;(:file "combination" :depends-on ("foreign-array" "array-structs"))
))
#+(or)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment