/[cl-gsl]/cl-gsl/permutation.lisp
ViewVC logotype

Contents of /cl-gsl/permutation.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Wed May 4 02:48:37 2005 UTC (8 years, 11 months ago) by edenny
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +54 -26 lines
Completed adding the wrappers.
1 ;;;; -*- Mode: Lisp; Synatx: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;;
3 ;;;; Copyright (C) 2005 Edgar Denny <edgardenny@comcast.net>
4 ;;;; This file is part of CL-GSL.
5 ;;;;
6 ;;;; This program is free software; you can redistribute it and/or modify
7 ;;;; it under the terms of the GNU General Public License as published by
8 ;;;; the Free Software Foundation; either version 2 of the License, or
9 ;;;; (at your option) any later version.
10 ;;;;
11 ;;;; This program is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;;; GNU General Public License for more details.
15 ;;;;
16 ;;;; You should have received a copy of the GNU General Public License
17 ;;;; along with this program; if not, write to the Free Software
18 ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19
20 (in-package #:cl-gsl-array)
21
22 (defclass gsl-permutation ()
23 ((ptr :accessor ptr :initarg :ptr)
24 (size :accessor size :initarg :size)
25 (element-type :accessor element-type :initform 'integer)))
26
27 ;; ----------------------------------------------------------------------
28
29 (defun-foreign "gsl_permutation_alloc"
30 ((size size-t))
31 gsl-permutation-ptr)
32
33 (defmethod alloc ((o gsl-permutation))
34 (setf (ptr o) (gsl-permutation-alloc (size o)))
35 o)
36
37 ;; ----------------------------------------------------------------------
38
39 (defun-foreign "gsl_permutation_init"
40 ((p gsl-permutation-ptr))
41 :void)
42
43 (defmethod permutation-init ((o gsl-permutation))
44 (gsl-permutation-init (ptr o))
45 o)
46
47 ;; ----------------------------------------------------------------------
48
49 (defun-foreign "gsl_permutation_free"
50 ((p gsl-permutation-ptr))
51 :void)
52
53 (defmethod free ((o gsl-permutation))
54 (gsl-permutation-free (ptr o))
55 (setf (ptr o) nil)
56 (setf (size o) nil))
57
58 ;; ----------------------------------------------------------------------
59
60 (defun-foreign "gsl_permutation_get"
61 ((p gsl-permutation-ptr)
62 (i size-t))
63 size-t)
64
65 (defmethod get-element ((o gsl-permutation) i &optional j)
66 (assert (and (typep i 'integer) (>= i 0) (< i (size o))))
67 (gsl-permutation-get (ptr o) i))
68
69 ;; ----------------------------------------------------------------------
70
71 (defun-foreign "gsl_permutation_swap"
72 ((p gsl-permutation-ptr)
73 (i size-t)
74 (j size-t))
75 size-t)
76
77 (defmethod swap-elements ((o gsl-permutation) i j)
78 (assert (and (typep i 'integer) (>= i 0) (< i (size o))))
79 (assert (and (typep j 'integer) (>= j 0) (< j (size o))))
80 (let ((status (gsl-permutation-swap (ptr o) i j)))
81 (values o status)))
82
83 ;; ----------------------------------------------------------------------
84
85 (defun-foreign "gsl_permutation_valid"
86 ((p gsl-permutation-ptr))
87 :int)
88
89 (defmethod isvalid ((o gsl-permutation))
90 ;; The C function gsl_permutation_valid does not return when the
91 ;; permutation is invalid - instead it calls GSL_ERROR.
92 ;; It only returns a value when the permutation is valid.
93 (ignore-errors
94 (= (gsl-permutation-valid (ptr o)) +success+)))
95
96 ;; ----------------------------------------------------------------------
97
98 (defun-foreign "gsl_permutation_reverse"
99 ((p gsl-permutation-ptr))
100 :void)
101
102 (defmethod reverse-permutation ((o gsl-permutation))
103 (gsl-permutation-reverse (ptr o)))
104
105 ;; ----------------------------------------------------------------------
106
107 (defun-foreign "gsl_permutation_next"
108 ((p gsl-permutation-ptr))
109 :int)
110
111 (defmethod next ((o gsl-permutation))
112 (let ((status (gsl-permutation-next (ptr o))))
113 (values o status)))
114
115 ;; ----------------------------------------------------------------------
116
117 (defun-foreign "gsl_permutation_prev"
118 ((p gsl-permutation-ptr))
119 :int)
120
121 (defmethod prev ((o gsl-permutation))
122 (let ((status (gsl-permutation-prev (ptr o))))
123 (values o status)))
124
125 ;; ----------------------------------------------------------------------
126
127 (defun-foreign "wrap_gsl_permutation_fwrite"
128 ((fn :cstring)
129 (p gsl-permutation-ptr))
130 :int)
131
132 (defmethod write-to-binary-file (file-name (o gsl-permutation))
133 (let ((status))
134 (uffi:with-cstring (c-file-name file-name)
135 (setq status
136 (wrap-gsl-permutation-fwrite c-file-name (ptr o))))
137 status))
138
139 ;; ----------------------------------------------------------------------
140
141 (defun-foreign "wrap_gsl_permutation_fread"
142 ((fn :cstring)
143 (p gsl-permutation-ptr))
144 :int)
145
146 (defmethod read-from-binary-file ((o gsl-permutation) file-name)
147 (let ((status))
148 (uffi:with-cstring (c-file-name file-name)
149 (setq status
150 (wrap-gsl-permutation-fread c-file-name (ptr o))))
151 (values o status)))
152
153 ;; ----------------------------------------------------------------------
154
155 (defun-foreign "wrap_gsl_permutation_fprintf"
156 ((fn :cstring)
157 (p gsl-permutation-ptr))
158 :int)
159
160 (defmethod write-to-file (file-name (o gsl-permutation))
161 (let ((status))
162 (uffi:with-cstring (c-file-name file-name)
163 (setq status
164 (wrap-gsl-permutation-fprintf c-file-name (ptr o))))
165 status))
166
167 ;; ----------------------------------------------------------------------
168
169 (defun-foreign "wrap_gsl_permutation_fscanf"
170 ((fn :cstring)
171 (p gsl-permutation-ptr))
172 :int)
173
174 (defmethod read-from-file ((o gsl-permutation) file-name)
175 (let ((status))
176 (uffi:with-cstring (c-file-name file-name)
177 (setq status
178 (wrap-gsl-permutation-fscanf c-file-name (ptr o))))
179 (values o status)))
180
181 ;; ----------------------------------------------------------------------
182
183 (defun-foreign "gsl_permutation_inverse"
184 ((inv gsl-permutation-ptr)
185 (p gsl-permutation-ptr))
186 :int)
187
188 (defmethod inverse ((p gsl-permutation))
189 (let* ((inv (make-permutation (size p)))
190 (status (gsl-permutation-inverse (ptr inv) (ptr p))))
191 (values inv status)))
192
193 (defmacro with-permutation-inverse ((p-inv p-src) &body body)
194 `(let ((,p-inv (inverse ,p-src)))
195 (unwind-protect
196 ,@body
197 (free ,p-inv))))
198
199 ;; ----------------------------------------------------------------------
200
201 (defmacro def-vector-permutation-type-funcs% (typ)
202 (destructuring-bind (type-ptr type-string)
203 (cond
204 ((eq typ 'double-float)
205 (list 'gsl-vector-ptr ""))
206 ((eq typ 'single-float)
207 (list 'gsl-vector-float-ptr "_float"))
208 ((eq typ 'integer)
209 (list 'gsl-vector-int-ptr "_int"))
210 ((equal typ '(complex (double-float)))
211 (list 'gsl-vector-complex-ptr "_complex"))
212 ((equal typ '(complex (single-float)))
213 (list 'gsl-vector-complex-float-ptr "_complex_float"))
214 (t
215 (error "no matching type.")))
216
217 `(progn
218 (defun-foreign ,(concatenate 'string "gsl_permute_vector" type-string)
219 ((p gsl-permutation-ptr)
220 (v ,type-ptr))
221 :int)
222
223 (defun-foreign ,(concatenate 'string
224 "gsl_permute_vector" type-string "_inverse")
225 ((p gsl-permutation-ptr)
226 (v ,type-ptr))
227 :int))))
228
229 (def-vector-permutation-type-funcs% double-float)
230 (def-vector-permutation-type-funcs% single-float)
231 (def-vector-permutation-type-funcs% integer)
232 (def-vector-permutation-type-funcs% (complex (double-float)))
233 (def-vector-permutation-type-funcs% (complex (single-float)))
234
235 (defmacro def-vector-methods% (class-string func-string)
236 (let ((class-object (kmrcl:concat-symbol "gsl-vector-" class-string)))
237 `(progn
238
239 (defmethod permute-vector ((p gsl-permutation) (v ,class-object))
240 (let ((status (,(kmrcl:concat-symbol "gsl-permute-vector" func-string)
241 (ptr p) (ptr v))))
242 (values v status)))
243
244 (defmethod permute-vector-inverse ((p gsl-permutation)
245 (v ,class-object))
246 (let ((status (,(kmrcl:concat-symbol
247 "gsl-permute-vector" func-string "-inverse")
248 (ptr p) (ptr v))))
249 (values v status)))
250 )))
251
252 (def-vector-methods% "integer" "-int")
253 (def-vector-methods% "single-float" "-float")
254 (def-vector-methods% "double-float" "")
255 (def-vector-methods% "complex-single-float" "-complex-float")
256 (def-vector-methods% "complex-double-float" "-complex")
257
258 ;; ----------------------------------------------------------------------
259
260 (defun make-permutation (size &key initial-contents from-file from-binary-file)
261 (assert (and (typep size 'integer) (> size 0)))
262 (let ((p (make-instance 'gsl-permutation :size size)))
263 (alloc p)
264 (cond
265 ((and initial-contents from-file from-binary-file)
266 (error "can only define one of the keys: initial-contents, from-file, from-binary-file."))
267 (initial-contents
268 (cond
269 ((listp initial-contents)
270 (do ((x initial-contents (cdr x))
271 (i 0 (1+ i)))
272 ((= i size))
273 (set-element p i (car x)))
274 (unless (isvalid p)
275 (error "intitial contents are not a valid permutation.")))
276 ((vectorp initial-contents)
277 (do ((i 0 (1+ i)))
278 ((= i size))
279 (set-element p i (aref initial-contents i)))
280 (unless (isvalid p)
281 (error "intitial contents are not a valid permutation.")))
282 (t
283 (error "initial-contents must be either a list or a vector."))))
284 (from-file
285 (read-from-file p from-file)
286 (unless (isvalid p)
287 (error "file contents are not a valid permutation.")))
288 (from-binary-file
289 (read-from-binary-file p from-binary-file)
290 (unless (isvalid p)
291 (error "file contents are not a valid permutation.")))
292 (t
293 (permutation-init p)))
294 p))
295
296 (defmacro with-permutation ((p size &key initial-contents from-file
297 from-binary-file)
298 &body body)
299 `(let ((,p (make-permutation ,size :initial-contents ,initial-contents
300 :from-file ,from-file
301 :from-binary-file ,from-binary-file)))
302 (unwind-protect
303 (progn ,@body)
304 (free ,p))))
305
306 ;; ----------------------------------------------------------------------
307
308 (defun-foreign "gsl_permutation_memcpy"
309 ((p-dest gsl-permutation-ptr)
310 (p-src gsl-permutation-ptr))
311 :int)
312
313 (defmethod copy ((o gsl-permutation))
314 (let* ((p-copy (make-permutation (size o)))
315 (status (gsl-permutation-memcpy (ptr p-copy) (ptr o))))
316 (values p-copy status)))
317
318 (defmacro with-permutation-copy ((p-dest p-src) &body body)
319 `(let ((,p-dest (copy ,p-src)))
320 (unwind-protect
321 ,@body
322 (free ,p-dest))))
323
324 ;; ----------------------------------------------------------------------
325
326 (defun-foreign "gsl_permutation_mul"
327 ((p gsl-permutation-ptr)
328 (pa gsl-permutation-ptr)
329 (pb gsl-permutation-ptr))
330 :int)
331
332 (defmethod mul ((pa gsl-permutation) (pb gsl-permutation))
333 (let* ((p (make-permutation (size pa)))
334 (status (gsl-permutation-mul (ptr p) (ptr pa) (ptr pb))))
335 (values p status)))
336
337 (defmacro with-permutation-mul ((p-new pa pb) &body body)
338 `(let ((,p-new (mul ,pa ,pb)))
339 (unwind-protect
340 ,@body
341 (free ,p-new))))
342
343 ;; ----------------------------------------------------------------------
344
345 (defun-foreign "gsl_permutation_linear_to_canonical"
346 ((q gsl-permutation-ptr)
347 (p gsl-permutation-ptr))
348 :int)
349
350 (defmethod linear->canonical ((p-can gsl-permutation) (p-lin gsl-permutation))
351 (let ((status (gsl-permutation-linear-to-canonical (ptr p-can) (ptr p-lin))))
352 (values p-can status)))
353
354 (defmacro with-permutation-linear->canonical ((p-can p-lin) &body body)
355 (let ((p (gensym)))
356 `(let* ((,p ,p-lin)
357 (,p-can (make-permutation (size ,p))))
358 (linear->canonical ,p-can ,p)
359 (unwind-protect
360 ,@body
361 (free ,p-can)))))
362
363 ;; ----------------------------------------------------------------------
364
365 (defun-foreign "gsl_permutation_canonical_to_linear"
366 ((p gsl-permutation-ptr)
367 (q gsl-permutation-ptr))
368 :int)
369
370 (defmethod canonical->linear ((p-lin gsl-permutation) (p-can gsl-permutation))
371 (let ((status (gsl-permutation-canonical-to-linear (ptr p-lin) (ptr p-can))))
372 (values p-lin status)))
373
374 (defmacro with-permutation-canonical->linear ((p-lin p-can) &body body)
375 (let ((p (gensym)))
376 `(let* ((,p ,p-can)
377 (,p-lin (make-permutation (size ,p))))
378 (canonical->linear ,p-lin ,p)
379 (unwind-protect
380 ,@body
381 (free ,p-lin)))))
382
383 ;; ----------------------------------------------------------------------
384
385 (defun-foreign "gsl_permutation_inversions"
386 ((p gsl-permutation-ptr))
387 size-t)
388
389 (defmethod inversions ((o gsl-permutation))
390 (gsl-permutation-inversions (ptr o)))
391
392 ;; ----------------------------------------------------------------------
393
394 (defun-foreign "gsl_permutation_linear_cycles"
395 ((p gsl-permutation-ptr))
396 size-t)
397
398 (defmethod linear-cycles ((o gsl-permutation))
399 (gsl-permutation-linear-cycles (ptr o)))
400
401 ;; ----------------------------------------------------------------------
402
403 (defun-foreign "gsl_permutation_canonical_cycles"
404 ((p gsl-permutation-ptr))
405 size-t)
406
407 (defmethod canonical-cycles ((o gsl-permutation))
408 (gsl-permutation-linear-cycles (ptr o)))
409
410 ;; ----------------------------------------------------------------------
411
412 (defmethod set-element ((p gsl-permutation) i &optional x dummy)
413 (assert (typep x 'integer))
414 (assert (and (typep i 'integer) (>= i 0) (< i (size p))))
415 (let ((data-ptr (uffi:get-slot-pointer (ptr p) '(* size-t) 'cl-gsl::data)))
416 (setf (uffi:deref-array data-ptr 'size-t i) x)))

  ViewVC Help
Powered by ViewVC 1.1.5