Context Navigation

permutation.lisp

Revision 34, 12.0 kB (checked in by lhealy, 9 months ago)

The classes/types in the different contexts are now gathered together
in one place, in *type-names* for the types and in *data-class-name*
for data classes, populated by #'add-data-class. Both defdata and
defmfun-all use the table and so mapping between various names is
consistent. The data class names are now different, *-double-float
and *-single-float replaces *-double and *-single. The regression
tests give the same results as before.

Property svn:keywords set to Id

Line
1	;; Permutations
2	;; Liam Healy, Sun Mar 26 2006 - 11:51
3	;; Time-stamp: <2008-03-09 21:52:16EDT permutation.lisp>
4	;; $Id$
5
6	(in-package :gsl)
7
8	;;;;****************************************************************************
9	;;;; Permutation structure and CL object
10	;;;;****************************************************************************
11
12	;;; GSL-permutation definition
13	(cffi:defcstruct gsl-permutation-c
14	(size size)
15	(data :pointer))
16
17	(add-data-class permutation fixnum permutation gsl-data "permutation")
18	(defdata permutation fixnum 1 "")
19
20	(defmethod gsl-array ((object permutation))
21	(foreign-slot-value (pointer object) 'gsl-permutation-c 'data))
22
23	;;;;****************************************************************************
24	;;;; Getting values
25	;;;;****************************************************************************
26
27	(defmfun maref ((permutation permutation) &rest indices)
28	"gsl_permutation_get"
29	(((pointer permutation) :pointer) ((first indices) size))
30	:type :method
31	:c-return size
32	:documentation "The ith element of the permutation.") ; FDL
33
34	;;;;****************************************************************************
35	;;;; Setting values
36	;;;;****************************************************************************
37
38	(defmfun set-identity ((permutation permutation))
39	"gsl_permutation_init"
40	(((pointer permutation) :pointer))
41	:type :method
42	:c-return :void
43	:documentation ; FDL
44	"Initialize the permutation p to the identity, i.e.
45	(0,1,2,...,n-1).")
46
47	(defmfun copy ((destination permutation) (source permutation))
48	"gsl_permutation_memcpy"
49	(((pointer destination) gsl-permutation-c)
50	((pointer source) gsl-permutation-c))
51	:type :method
52	:invalidate (destination)
53	:documentation ; FDL
54	"Copy the elements of the permutation source into the
55	permutation destination. The two permutations must have the same size.")
56
57	(defmfun swap-elements ((p permutation) i j)
58	"gsl_permutation_swap"
59	(((pointer p) gsl-permutation-c) (i size) (j size))
60	:type :method
61	:invalidate (p)
62	:documentation ; FDL
63	"Exchanges the ith and jth elements of the permutation p.")
64
65	;;;;****************************************************************************
66	;;;; Permutation properties
67	;;;;****************************************************************************
68
69	(defmfun permutation-size (p)
70	"gsl_permutation_size"
71	(((pointer p) gsl-permutation-c))
72	:c-return size
73	:documentation ; FDL
74	"The size of the permutation p.")
75
76	(defmfun permutation-data (p)
77	"gsl_permutation_data"
78	(((pointer p) gsl-permutation-c))
79	:c-return :pointer
80	:documentation ; FDL
81	"A pointer to the array of elements in the
82	permutation p.")
83
84	(defmfun data-valid ((permutation permutation))
85	"gsl_permutation_valid"
86	(((pointer permutation) :pointer))
87	:type :method
88	:c-return :boolean
89	:documentation ; FDL
90	"Check that the permutation p is valid. The n
91	elements should contain each of the numbers 0 to n-1 once and only
92	once.")
93
94	;;;;****************************************************************************
95	;;;; Permutation functions
96	;;;;****************************************************************************
97
98	(defmfun permutation-reverse (p)
99	"gsl_permutation_reverse"
100	(((pointer p) gsl-permutation-c))
101	:invalidate (p)
102	:c-return :void
103	:documentation ; FDL
104	"Reverse the order of the elements of the permutation p.")
105
106	(defmfun permutation-inverse (inv p)
107	"gsl_permutation_inverse"
108	(((pointer inv) gsl-permutation-c) ((pointer p) gsl-permutation-c))
109	:invalidate (inv)
110	:documentation ; FDL
111	"Find the inverse of the permutation p.")
112
113	(defmfun permutation-next (p)
114	"gsl_permutation_next"
115	(((pointer p) gsl-permutation-c))
116	:c-return :success-failure
117	:invalidate (p)
118	:documentation ; FDL
119	"Advance the permutation p to the next permutation
120	in lexicographic order and return p and T. If no further
121	permutations are available, return p and NIL with
122	p unmodified. Starting with the identity permutation and
123	repeatedly applying this function will iterate through all possible
124	permutations of a given order.")
125
126	(defmfun permutation-previous (p)
127	"gsl_permutation_prev"
128	(((pointer p) gsl-permutation-c))
129	:c-return :success-failure
130	:invalidate (p)
131	:documentation ; FDL
132	"Step backwards from the permutation p to the
133	previous permutation in lexicographic order, returning p and T.
134	If no previous permutation is available, return
135	p and NIL with p unmodified.")
136
137	;;;;****************************************************************************
138	;;;; Applying Permutations
139	;;;;****************************************************************************
140
141	(defmfun permute (p data stride n)
142	"gsl_permute"
143	(((pointer p) gsl-permutation-c) (data :pointer) (stride size) (n size))
144	:documentation ; FDL
145	"Apply the permutation p to the array data of
146	size n with stride stride.")
147
148	(defmfun permute-inverse (p data stride n)
149	"gsl_permute_inverse"
150	(((pointer p) gsl-permutation-c) (data :pointer) (stride size) (n size))
151	:documentation ; FDL
152	"Apply the inverse of the permutation p to the array data of
153	size n with stride.")
154
155	(export 'permute-vector)
156	(defgeneric permute-vector (permutation vector)
157	(:documentation ; FDL
158	"Apply the permutation p to the elements of the
159	vector v considered as a row-vector acted on by a permutation
160	matrix from the right, v' = v P. The jth column of the
161	permutation matrix P is given by the p_j-th column of the
162	identity matrix. The permutation p and the vector v must
163	have the same length."))
164
165	(defmfun-vdsfc permute-vector (p (v vector))
166	"gsl_permute_vector"
167	(((pointer p) gsl-permutation-c) ((pointer v) gsl-vector-c))
168	:invalidate (v))
169
170	(export 'permute-vector-inverse)
171	(defgeneric permute-vector-inverse (permutation vector)
172	(:documentation ; FDL
173	"Apply the inverse of the permutation p to the
174	elements of the vector v considered as a row-vector acted on by
175	an inverse permutation matrix from the right, v' = v P^T. Note
176	that for permutation matrices the inverse is the same as the transpose.
177	The jth column of the permutation matrix P is given by
178	the p_j-th column of the identity matrix. The permutation p
179	and the vector v must have the same length."))
180
181	(defmfun-vdsfc permute-vector-inverse (p (v vector))
182	"gsl_permute_vector_inverse"
183	(((pointer p) gsl-permutation-c) ((pointer v) gsl-vector-c))
184	:invalidate (v))
185
186	(defmfun permutation* (p pa pb)
187	"gsl_permutation_mul"
188	(((pointer p) gsl-permutation-c)
189	((pointer pa) gsl-permutation-c)
190	((pointer pb) gsl-permutation-c))
191	:invalidate (p)
192	:documentation ; FDL
193	"Combine the two permutations pa and pb into a
194	single permutation p where p = pa . pb. The permutation
195	p is equivalent to applying pb first and then pa.")
196
197	;;;;****************************************************************************
198	;;;; Permutations in cyclic form
199	;;;;****************************************************************************
200
201	(defmfun linear-to-canonical (q p)
202	"gsl_permutation_linear_to_canonical"
203	(((pointer q) gsl-permutation-c) ((pointer p) gsl-permutation-c))
204	:invalidate (q)
205	:documentation ; FDL
206	"Compute the canonical form of the permutation p and
207	stores it in the output argument q.")
208
209	(defmfun canonical-to-linear (p q)
210	"gsl_permutation_canonical_to_linear"
211	(((pointer p) gsl-permutation-c) ((pointer q) gsl-permutation-c))
212	:invalidate (p)
213	:documentation ; FDL
214	"Convert a permutation q in canonical form back into
215	linear form storing it in the output argument p.")
216
217	(defmfun inversions (p)
218	"gsl_permutation_inversions" (((pointer p) gsl-permutation-c))
219	:c-return size
220	:documentation ; FDL
221	"Count the number of inversions in the permutation
222	p. An inversion is any pair of elements that are not in order.
223	For example, the permutation 2031 has three inversions, corresponding to
224	the pairs (2,0) (2,1) and (3,1). The identity permutation has no
225	inversions.")
226
227	(defmfun linear-cycles (p)
228	"gsl_permutation_linear_cycles" (((pointer p) gsl-permutation-c))
229	:c-return size
230	:documentation ; FDL
231	"Count the number of cycles in the permutation p, given in linear form.")
232
233	(defmfun canonical-cycles (p)
234	"gsl_permutation_canonical_cycles"
235	(((pointer p) gsl-permutation-c))
236	:c-return size
237	:documentation ; FDL
238	"Count the number of cycles in the permutation q, given in canonical form.")
239
240	;;;;****************************************************************************
241	;;;; Examples and unit test
242	;;;;****************************************************************************
243
244	(defun generate-all-permutations (n)
245	"Generate all the permutations of n objects."
246	(letm ((perm (permutation n t)))
247	(loop collect (data perm 'list)
248	while (permutation-next perm))))
249
250	#\|
251	(make-tests
252	permutation
253	(letm ((perm-1 (permutation 4 t))) ;maref
254	(set-identity perm-1)
255	(maref perm-1 2))
256	(letm ((perm-1 (permutation 4 t))) ;data
257	(set-identity perm-1)
258	(data perm-1))
259	(letm ((perm-1 (permutation 4 t))) ;permutation-reverse
260	(set-identity perm-1)
261	(data (permutation-reverse perm-1)))
262	(letm ;permutation-next, permutation-inverse
263	((perm-1 (permutation 4 t)) (perm-2 (permutation 4 t)))
264	(set-identity perm-1)
265	(permutation-next perm-1)
266	(permutation-next perm-1)
267	(permutation-next perm-1)
268	(permutation-inverse perm-2 perm-1)
269	(data perm-2))
270	(letm ((perm-1 (permutation 4 t))) ;swap-elements
271	(set-identity perm-1)
272	(swap-elements perm-1 1 3)
273	(data perm-1))
274	(letm ((perm-1 (permutation 4 t)) ;permute-vector
275	(intvec (vector-fixnum #(11 22 33 44))))
276	(set-identity perm-1)
277	(swap-elements perm-1 1 3)
278	(swap-elements perm-1 0 2)
279	(permute-vector perm-1 intvec)
280	(data intvec))
281	(letm ((perm-1 (permutation 4 t))) ;inversions
282	(set-identity perm-1)
283	(swap-elements perm-1 1 3)
284	(inversions perm-1))
285	(letm ((perm-1 (permutation 4 t))) ;linear-cycles
286	(set-identity perm-1)
287	(swap-elements perm-1 1 3)
288	(linear-cycles perm-1))
289	(letm ((perm-1 (permutation 4 t))) ;canonical-cycles
290	(set-identity perm-1)
291	(swap-elements perm-1 1 3)
292	(swap-elements perm-1 0 2)
293	(canonical-cycles perm-1)))
294	\|#
295
296	(LISP-UNIT:DEFINE-TEST PERMUTATION
297	(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
298	(LIST 2)
299	(MULTIPLE-VALUE-LIST
300	(LETM ((PERM-1 (PERMUTATION 4 T)))
301	(SET-IDENTITY PERM-1)
302	(MAREF PERM-1 2))))
303	(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
304	(LIST #(0 1 2 3))
305	(MULTIPLE-VALUE-LIST
306	(LETM ((PERM-1 (PERMUTATION 4 T)))
307	(SET-IDENTITY PERM-1)
308	(DATA PERM-1))))
309	(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
310	(LIST #(3 2 1 0))
311	(MULTIPLE-VALUE-LIST
312	(LETM ((PERM-1 (PERMUTATION 4 T)))
313	(SET-IDENTITY
314	PERM-1)
315	(DATA (PERMUTATION-REVERSE PERM-1)))))
316	(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
317	(LIST #(0 3 1 2))
318	(MULTIPLE-VALUE-LIST
319	(LETM ((PERM-1 (PERMUTATION 4 T))
320	(PERM-2 (PERMUTATION 4 T)))
321	(SET-IDENTITY PERM-1)
322	(PERMUTATION-NEXT PERM-1)
323	(PERMUTATION-NEXT PERM-1)
324	(PERMUTATION-NEXT PERM-1)
325	(PERMUTATION-INVERSE PERM-2 PERM-1)
326	(DATA PERM-2))))
327	(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
328	(LIST #(0 3 2 1))
329	(MULTIPLE-VALUE-LIST
330	(LETM ((PERM-1 (PERMUTATION 4 T)))
331	(SET-IDENTITY PERM-1)
332	(SWAP-ELEMENTS PERM-1 1 3)
333	(DATA PERM-1))))
334	(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
335	(LIST #(33 44 11 22))
336	(MULTIPLE-VALUE-LIST
337	(LETM ((PERM-1 (PERMUTATION 4 T))
338	(INTVEC (VECTOR-FIXNUM
339	#(11 22 33 44))))
340	(SET-IDENTITY PERM-1)
341	(SWAP-ELEMENTS PERM-1 1 3)
342	(SWAP-ELEMENTS PERM-1 0 2)
343	(PERMUTE-VECTOR PERM-1 INTVEC)
344	(DATA INTVEC))))
345	(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
346	(LIST 3)
347	(MULTIPLE-VALUE-LIST
348	(LETM ((PERM-1 (PERMUTATION 4 T)))
349	(SET-IDENTITY PERM-1)
350	(SWAP-ELEMENTS PERM-1 1 3)
351	(INVERSIONS PERM-1))))
352	(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
353	(LIST 3)
354	(MULTIPLE-VALUE-LIST
355	(LETM ((PERM-1 (PERMUTATION 4 T)))
356	(SET-IDENTITY PERM-1)
357	(SWAP-ELEMENTS PERM-1 1 3)
358	(LINEAR-CYCLES PERM-1))))
359	(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
360	(LIST 2)
361	(MULTIPLE-VALUE-LIST
362	(LETM ((PERM-1 (PERMUTATION 4 T)))
363	(SET-IDENTITY PERM-1)
364	(SWAP-ELEMENTS PERM-1 1 3)
365	(SWAP-ELEMENTS PERM-1 0 2)
366	(CANONICAL-CYCLES PERM-1)))))
367

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format