Skip to content
Snippets Groups Projects
Commit d6a0d879 authored by Liam Healy's avatar Liam Healy
Browse files

Port permutation to foreign-array

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