permutation.lisp 12.6 KB
Newer Older
1 2
;; Permutations
;; Liam Healy, Sun Mar 26 2006 - 11:51
3
;; Time-stamp: <2011-01-10 18:16:26EST permutation.lisp>
4
;;
5
;; Copyright 2006, 2007, 2008, 2009, 2010, 2011 Liam M. Healy
6 7 8 9 10 11 12 13 14 15 16 17 18 19
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
lhealy's avatar
lhealy committed
20
;; $Id$
21 22 23

(in-package :gsl)

24 25
;;; /usr/include/gsl/gsl_permutation.h

26
;;;;****************************************************************************
27
;;;; Permutation structure and CL object
28
;;;;****************************************************************************
Liam Healy's avatar
Liam Healy committed
29
   
30 31 32
(defclass permutation
    (#+int64 grid:vector-unsigned-byte-64 #+int32 grid:vector-unsigned-byte-32)
  ()
33
  (:documentation "GSL permutations."))
34

Liam Healy's avatar
Liam Healy committed
35 36 37
(defmethod initialize-instance :after
    ((object permutation) &key dimensions &allow-other-keys)
  (let ((mptr (cffi:foreign-alloc 'gsl-permutation-c)))
38
    (setf (grid:metadata-slot object 'mpointer)
Liam Healy's avatar
Liam Healy committed
39 40
	  mptr
	  (cffi:foreign-slot-value mptr 'gsl-permutation-c 'data)
41
	  (grid:foreign-pointer object)
Liam Healy's avatar
Liam Healy committed
42
	  (cffi:foreign-slot-value mptr 'gsl-permutation-c 'size)
43
	  (first dimensions))
Liam Healy's avatar
Liam Healy committed
44
    (tg:finalize object (lambda () (cffi:foreign-free mptr)))))
45

46 47 48 49 50 51 52 53 54
(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
   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
55
	  :element-type '(unsigned-byte #+int64 64 #+int32 32)
56
	  :dimensions (if (typep n 'permutation) (grid:dimensions n) (list n)))))
57 58
    (when initialize
      (if (typep n 'permutation)
59
	  (error "not available yet")	; (copy perm n)
60 61 62
	  (set-identity perm)))
    perm))

63 64 65 66
(defmethod print-object ((object permutation) stream)
  (print-unreadable-object (object stream :type t)
    (princ (grid:contents object) stream)))

67 68 69 70
;;;;****************************************************************************
;;;; Setting values
;;;;****************************************************************************

71
(defmfun set-identity ((permutation permutation))
72
  "gsl_permutation_init"
73 74
  (((mpointer permutation) :pointer))
  :definition :method
75
  :c-return :void
76 77
  :outputs (permutation)
  :return (permutation)
78 79
  :documentation			; FDL
  "Initialize the permutation p to the identity, i.e.
liam's avatar
liam committed
80
   (0,1,2,...,n-1).")
81

82
(defmfun perm-copy (source destination)
83
  "gsl_permutation_memcpy"
84 85 86 87
  (((mpointer destination) :pointer)
   ((mpointer source) :pointer))
  :inputs (source)
  :outputs (destination)
88
  :return (destination)
89 90
  :export nil
  :index grid:copy
91 92 93
  :documentation			; FDL
  "Copy the elements of the permutation source into the
   permutation destination.  The two permutations must have the same size.")
94

95
(defmethod grid:copy
96
    ((source permutation) &key grid-type destination &allow-other-keys)
97 98 99
  (if grid-type
      (call-next-method)
      (perm-copy
100
       source (or destination (make-permutation (size source))))))
101

102
(defmfun swap-elements ((p permutation) i j)
103
  "gsl_permutation_swap"
104 105 106 107
  (((mpointer p) :pointer) (i sizet) (j sizet))
  :definition :method
  :inputs (p)
  :outputs (p)
108
  :return (p)
109 110
  :documentation			; FDL
  "Exchanges the ith and jth elements of the permutation p.")
111 112 113 114 115

;;;;****************************************************************************
;;;; Permutation properties
;;;;****************************************************************************

Liam Healy's avatar
Liam Healy committed
116
(defmfun size ((p permutation))
117
  "gsl_permutation_size"
118
  (((mpointer p) :pointer))
Liam Healy's avatar
Liam Healy committed
119
  :definition :method
120
  :c-return sizet
121
  :inputs (p)
122
  :documentation			; FDL
123
  "The size of the permutation p.")
124

liam's avatar
liam committed
125
(defmfun permutation-data (p)
126
  "gsl_permutation_data"
127
  (((mpointer p) :pointer))
128
  :c-return :pointer
129
  :inputs (p)
130
  :documentation			; FDL
131
  "A pointer to the array of elements in the
132
   permutation p.")
133

134
(export 'validp)
135
(defgeneric validp (object)
136 137 138
  (:documentation			; FDL
   "Check that the object p is valid."))

139
(defmfun validp ((permutation permutation))
140
  "gsl_permutation_valid"
141
  (((mpointer permutation) :pointer))
142
  :definition :method
143
  :c-return :success-failure
144
  :inputs (permutation)
145 146 147
  :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
148
  once.")
149 150 151 152 153

;;;;****************************************************************************
;;;; Permutation functions
;;;;****************************************************************************

liam's avatar
liam committed
154
(defmfun permutation-reverse (p)
155
  "gsl_permutation_reverse"
156
  (((mpointer p) :pointer))
157
  :c-return :void
158 159 160
  :inputs (p)
  :outputs (p)
  :return (p)
161 162
  :documentation			; FDL
  "Reverse the order of the elements of the permutation p.")
163

164
(defmfun permutation-inverse (p &optional (inv (make-permutation (size p))))
165
  "gsl_permutation_inverse"
166
  (((mpointer inv) :pointer) ((mpointer p) :pointer))
167
  :inputs (p)
168
  :outputs (inv)
169
  :return (inv)
170 171
  :documentation			; FDL
  "Find the inverse of the permutation p.")
172

liam's avatar
liam committed
173
(defmfun permutation-next (p)
174
  "gsl_permutation_next"
175
  (((mpointer p) :pointer))
176
  :c-return :success-failure
177
  :inputs (p)
178
  :outputs (p)
179
  :return (p :c-return)
180 181
  :documentation			; FDL
  "Advance the permutation p to the next permutation
182 183
   in lexicographic order and return p and T.  If no further
   permutations are available, return p and NIL with
184
   p unmodified.  Starting with the identity permutation and
185 186 187
   repeatedly applying this function will iterate through all possible
   permutations of a given order.")

liam's avatar
liam committed
188
(defmfun permutation-previous (p)
189
  "gsl_permutation_prev"
190
  (((mpointer p) :pointer))
191
  :c-return :success-failure
192
  :inputs (p)
193
  :outputs (p)
194
  :return (p :c-return)
195 196
  :documentation			; FDL
  "Step backwards from the permutation p to the
197
   previous permutation in lexicographic order, returning p and T.
198
   If no previous permutation is available, return
199
   p and NIL with p unmodified.")
200 201 202 203 204

;;;;****************************************************************************
;;;; Applying Permutations
;;;;****************************************************************************

205
(defmfun permute ((p permutation) (v vector) &optional size stride)
206 207 208
  ("gsl_permute_vector" :type)
  (((mpointer p) :pointer) ((mpointer v) :pointer))
  :definition :generic
209
  :inputs (p v)
210
  :outputs (v)
211
  :return (v)
212
  :documentation			; FDL
213 214 215 216 217
  "Apply the permutation p to the elements of the
   vector v considered as a row-vector acted on by a permutation
   matrix from the right, v' = v P.  The jth column of the
   permutation matrix P is given by the p_j-th column of the
   identity matrix. The permutation p and the vector v must
218 219
   have the same length.")

220
(defmfun permute
221
    (p (data #.grid:+foreign-pointer-class+) &optional (size 1) (stride 1))
222 223 224 225 226 227 228 229 230 231 232 233
  "gsl_permute"
  (((mpointer p) :pointer) (data :pointer) (stride sizet) (size sizet))
  :definition :method
  :inputs (p data)
  :outputs (data)
  :return (data)
  :documentation			; FDL
  "Apply the permutation p to the array data of
   size n with stride stride.")

(defmfun permute-inverse
    ((p permutation) (v vector) &optional size stride)
234 235 236
  ("gsl_permute_vector" :type "_inverse")
  (((mpointer p) :pointer) ((mpointer v) :pointer))
  :definition :generic
237
  :inputs (p v)
238
  :outputs (v)
239
  :return (v)
240 241 242 243 244 245 246
  :documentation			; FDL
  "Apply the permutation p to the elements of the
   vector v considered as a row-vector acted on by a permutation
   matrix from the right, v' = v P.  The jth column of the
   permutation matrix P is given by the p_j-th column of the
   identity matrix. The permutation p and the vector v must
   have the same length.")
247

248
(defmfun permute-inverse
249
    (p (data #.grid:+foreign-pointer-class+) &optional (size 1) (stride 1))
250
  "gsl_permute_inverse"
251
  (((mpointer p) :pointer) (data :pointer) (stride sizet) (stride sizet))
252 253 254 255 256 257 258 259
  :definition :method
  :inputs (p data)
  :outputs (data)
  :return (data)
  :documentation			; FDL
  "Apply the inverse of the permutation p to the array data of
   size n with stride.")

liam's avatar
liam committed
260
(defmfun permutation* (p pa pb)
261
  "gsl_permutation_mul"
262 263 264
  (((mpointer p) :pointer)
   ((mpointer pa) :pointer)
   ((mpointer pb) :pointer))
265
  :inputs (pa pb)
266
  :outputs (p)
267
  :return (p)
268 269 270 271
  :documentation			; FDL
  "Combine the two permutations pa and pb into a
  single permutation p where p = pa . pb. The permutation
  p is equivalent to applying pb first and then pa.")
272 273 274 275 276

;;;;****************************************************************************
;;;; Permutations in cyclic form
;;;;****************************************************************************

277
(defmfun linear-to-canonical (p &optional (q (make-permutation (size p))))
278
  "gsl_permutation_linear_to_canonical"
279
  (((mpointer q) :pointer) ((mpointer p) :pointer))
280
  :inputs (p)
281
  :outputs (q)
282 283 284
  :documentation			; FDL
  "Compute the canonical form of the permutation p and
   stores it in the output argument q.")
285

286
(defmfun canonical-to-linear (q &optional (p (make-permutation (size q))))
287
  "gsl_permutation_canonical_to_linear"
288
  (((mpointer p) :pointer) ((mpointer q) :pointer))
289
  :inputs (q)
290
  :outputs (p)
291 292 293
  :documentation			; FDL
  "Convert a permutation q in canonical form back into
   linear form storing it in the output argument p.")
294

liam's avatar
liam committed
295
(defmfun inversions (p)
296 297
  "gsl_permutation_inversions" (((mpointer p) :pointer))
  :c-return sizet
298
  :inputs (p)
299
  :documentation			; FDL
300
  "Count the number of inversions in the permutation
301
  p.  An inversion is any pair of elements that are not in order.
302 303 304 305
  For example, the permutation 2031 has three inversions, corresponding to
  the pairs (2,0) (2,1) and (3,1).  The identity permutation has no
  inversions.")

liam's avatar
liam committed
306
(defmfun linear-cycles (p)
307 308
  "gsl_permutation_linear_cycles" (((mpointer p) :pointer))
  :c-return sizet
309
  :inputs (p)
310 311
  :documentation			; FDL
  "Count the number of cycles in the permutation p, given in linear form.")
312

liam's avatar
liam committed
313
(defmfun canonical-cycles (p)
314
  "gsl_permutation_canonical_cycles"
315 316
  (((mpointer p) :pointer))
  :c-return sizet
317
  :inputs (p)
318 319
  :documentation			; FDL
  "Count the number of cycles in the permutation q, given in canonical form.")
320

321 322 323 324
;;;;****************************************************************************
;;;; Examples and unit test
;;;;****************************************************************************

325 326
(defun generate-all-permutations (n)
  "Generate all the permutations of n objects."
327
  (let ((perm (make-permutation n)))
328
    (set-identity perm)
329 330
    (loop collect (grid:contents perm)
       while (nth-value 1 (permutation-next perm)))))
331

332 333
(defun generate-all-permutations-backwards (n)
  "Generate all the permutations of n objects."
334
  (let ((perm (make-permutation n)))
335 336
    (set-identity perm)
    (permutation-reverse perm)
337 338
    (loop collect (grid:contents perm)
       while (nth-value 1 (permutation-previous perm)))))
339

340
(save-test permutation
341
 (let ((perm-1 (make-permutation 4 t)))
342
   (grid:gref perm-1 2))
343 344
 (let ((perm-1 (make-permutation 4 t)))	;grid:contents
   (grid:contents perm-1))
345
 (let ((perm-1 (make-permutation 4 t)))	;permutation-reverse
liam's avatar
liam committed
346
   (set-identity perm-1)
347
   (grid:contents (permutation-reverse perm-1)))
348
 (let				;permutation-next, permutation-inverse
349
     ((perm-1 (make-permutation 4 t)))
liam's avatar
liam committed
350 351 352 353
   (set-identity perm-1)
   (permutation-next perm-1)
   (permutation-next perm-1)
   (permutation-next perm-1)
354
   (grid:contents (permutation-inverse perm-1)))
355
 (let ((perm-1 (make-permutation 4 t)))	;swap-elements
liam's avatar
liam committed
356 357
   (set-identity perm-1)
   (swap-elements perm-1 1 3)
358
   (grid:contents perm-1))
359 360
 (let ((perm-1 (make-permutation 4 t))	;permute-vector
       (intvec #31m(11 22 33 44)))
liam's avatar
liam committed
361 362 363
   (set-identity perm-1)
   (swap-elements perm-1 1 3)
   (swap-elements perm-1 0 2)
364
   (permute perm-1 intvec)
365
   (grid:contents intvec))
366
 (let ((perm-1 (make-permutation 4 t)))	;inversions
liam's avatar
liam committed
367 368 369
   (set-identity perm-1)
   (swap-elements perm-1 1 3)
   (inversions perm-1))
370
 (let ((perm-1 (make-permutation 4 t)))	;linear-cycles
liam's avatar
liam committed
371 372 373
   (set-identity perm-1)
   (swap-elements perm-1 1 3)
   (linear-cycles perm-1))
374
 (let ((perm-1 (make-permutation 4 t)))	;canonical-cycles
liam's avatar
liam committed
375 376 377 378
   (set-identity perm-1)
   (swap-elements perm-1 1 3)
   (swap-elements perm-1 0 2)
   (canonical-cycles perm-1)))