[cl-gsl-cvs] CVS update: cl-gsl/permutation.lisp

[cl-gsl-cvs at common-lisp.net]

Update of /project/cl-gsl/cvsroot/cl-gsl
In directory common-lisp.net:/tmp/cvs-serv30115

Modified Files:
	permutation.lisp 
Log Message:
Completed adding the wrappers.

Date: Wed May  4 04:48:37 2005
Author: edenny

Index: cl-gsl/permutation.lisp
diff -u cl-gsl/permutation.lisp:1.1 cl-gsl/permutation.lisp:1.2
--- cl-gsl/permutation.lisp:1.1	Sun May  1 00:41:10 2005
+++ cl-gsl/permutation.lisp	Wed May  4 04:48:37 2005
@@ -21,7 +21,8 @@
 
 (defclass gsl-permutation ()
   ((ptr :accessor ptr :initarg :ptr)
-   (size :accessor size :initarg :size)))
+   (size :accessor size :initarg :size)
+   (element-type :accessor element-type :initform 'integer)))
 
 ;; ----------------------------------------------------------------------
 
@@ -85,8 +86,12 @@
     ((p gsl-permutation-ptr))
   :int)
 
-(defmethod valid ((o gsl-permutation))
-  (1/0->t/nil (gsl-permutation-valid (ptr o))))
+(defmethod isvalid ((o gsl-permutation))
+  ;; The C function gsl_permutation_valid does not return when the
+  ;; permutation is invalid - instead it calls GSL_ERROR.
+  ;; It only returns a value when the permutation is valid.
+  (ignore-errors
+    (= (gsl-permutation-valid (ptr o)) +success+)))
 
 ;; ----------------------------------------------------------------------
 
@@ -266,26 +271,38 @@
                (i 0 (1+ i)))
               ((= i size))
             (set-element p i (car x)))
-          (unless (valid p)
+          (unless (isvalid p)
             (error "intitial contents are not a valid permutation.")))
          ((vectorp initial-contents)
           (do ((i 0 (1+ i)))
               ((= i size))
             (set-element p i (aref initial-contents i)))
-          (unless (valid p)
+          (unless (isvalid p)
             (error "intitial contents are not a valid permutation.")))
          (t
           (error "initial-contents must be either a list or a vector."))))
       (from-file
        (read-from-file p from-file)
-       (unless (valid p)
+       (unless (isvalid p)
          (error "file contents are not a valid permutation.")))
       (from-binary-file
        (read-from-binary-file p from-binary-file)
-       (unless (valid p)
-         (error "file contents are not a valid permutation."))))
+       (unless (isvalid p)
+         (error "file contents are not a valid permutation.")))
+      (t
+       (permutation-init p)))
     p))
 
+(defmacro with-permutation ((p size &key initial-contents from-file
+                               from-binary-file)
+                            &body body)
+  `(let ((,p (make-permutation ,size :initial-contents ,initial-contents
+                               :from-file ,from-file
+                               :from-binary-file ,from-binary-file)))
+     (unwind-protect
+          (progn , at body)
+       (free ,p))))
+
 ;; ----------------------------------------------------------------------
 
 (defun-foreign "gsl_permutation_memcpy"
@@ -330,16 +347,18 @@
      (p gsl-permutation-ptr))
   :int)
 
-(defmethod linear->canonical ((p gsl-permutation))
-  (let* ((q (make-permutation (size p)))
-         (status (gsl-permutation-linear-to-canonical (ptr q) (ptr p))))
-    (values q status)))
-
-(defmacro with-permutation-linear->canonical ((q p) &body body)
-  `(let ((,q (linear->canonical ,p)))
+(defmethod linear->canonical ((p-can gsl-permutation) (p-lin gsl-permutation))
+  (let ((status (gsl-permutation-linear-to-canonical (ptr p-can) (ptr p-lin))))
+    (values p-can status)))
+
+(defmacro with-permutation-linear->canonical ((p-can p-lin) &body body)
+  (let ((p (gensym)))
+    `(let* ((,p ,p-lin)
+            (,p-can (make-permutation (size ,p))))
+     (linear->canonical ,p-can ,p)
      (unwind-protect
           , at body
-       (free ,q))))
+       (free ,p-can)))))
 
 ;; ----------------------------------------------------------------------
 
@@ -348,16 +367,18 @@
      (q gsl-permutation-ptr))
   :int)
 
-(defmethod canonical->linear ((q gsl-permutation))
-  (let* ((p (make-permutation (size q)))
-         (status (gsl-permutation-linear-to-canonical (ptr p) (ptr q))))
-    (values p status)))
-
-(defmacro with-permutation-canonical->linear ((p q) &body body)
-  `(let ((,p (linear->canonical ,q)))
-     (unwind-protect
-          , at body
-       (free ,p))))
+(defmethod canonical->linear ((p-lin gsl-permutation) (p-can gsl-permutation))
+  (let ((status (gsl-permutation-canonical-to-linear (ptr p-lin) (ptr p-can))))
+    (values p-lin status)))
+
+(defmacro with-permutation-canonical->linear ((p-lin p-can) &body body)
+  (let ((p (gensym)))
+    `(let* ((,p ,p-can)
+            (,p-lin (make-permutation (size ,p))))
+       (canonical->linear ,p-lin ,p)
+       (unwind-protect
+            , at body
+         (free ,p-lin)))))
 
 ;; ----------------------------------------------------------------------
 
@@ -386,3 +407,10 @@
 (defmethod canonical-cycles ((o gsl-permutation))
   (gsl-permutation-linear-cycles (ptr o)))
 
+;; ----------------------------------------------------------------------
+
+(defmethod set-element ((p gsl-permutation) i &optional x dummy)
+  (assert (typep x 'integer))
+  (assert (and (typep i 'integer) (>= i 0) (< i (size p))))
+  (let ((data-ptr (uffi:get-slot-pointer (ptr p) '(* size-t) 'cl-gsl::data)))
+    (setf (uffi:deref-array data-ptr 'size-t i) x)))