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

Make FFA at initialize-instance time for gsl-data; restore permutations and combinations

Instead of making the ffa in make-array*, we now make it in the
initialize-instance :after method for gsl-data.  This means that
subclasses (permutations, combinations) will automatically make the
arrays.  Rewrote make-array* so that it is just a wrapper for
make-instance, computing the dimensions from the specified initial
parameters.  Permutations and combinations are now made with make-*
functions.
parent 95be73ee
No related branches found
No related tags found
No related merge requests found
;; Combinations ;; Combinations
;; Liam Healy, Sun Mar 26 2006 - 11:51 ;; Liam Healy, Sun Mar 26 2006 - 11:51
;; Time-stamp: <2008-12-06 14:10:53EST combination.lisp> ;; Time-stamp: <2008-12-06 18:57:42EST combination.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -18,35 +18,40 @@ ...@@ -18,35 +18,40 @@
(defclass combination (defclass combination
(#+sizet-64 vector-unsigned-byte-64 (#+sizet-64 vector-unsigned-byte-64
#+sizet-32 vector-unsigned-byte-32) #+sizet-32 vector-unsigned-byte-32)
() ((choice-of :initarg :choice-of :reader choice-of :type integer
:documentation "Maximum possible value; n in the (n k) notation."))
(:documentation "GSL permutations.")) (:documentation "GSL permutations."))
(export 'make-combination) (export 'make-combination)
(defun make-combination (nk)
"Make the combination object with the data array." (defun make-combination (n &optional k (initialize t))
(let ((k (second nk))) "Make the object representing a combination of k things from a set of n.
(make-instance If initialize is T, initialize as the first k values (init-first).
'combination If n is a combination, make a new combination with the same
:cl-array (make-array* k *sizet-type*) specification. If initialize is also T, copy it."
:mpointer nil ; this will be set by :before method below. (let ((comb
#-native :c-pointer #-native nil ; this will be set by defmfun (if (typep n 'combination)
:dimensions (copy-list nk) (make-instance
;; The total-size of a combination is k, because that is the length 'combination :choice-of (choice-of n) :dimensions (dimensions k))
;; of the vector that represents it. (make-instance 'combination :choice-of n :dimensions k))))
:total-size k))) (when initialize
(if (typep n 'combination)
(copy comb n)
(init-first comb)))
comb))
(defmethod alloc-gsl-struct ((object combination)) (defmethod alloc-gsl-struct ((object combination))
(unless (slot-value object 'mpointer) (unless (and (slot-boundp object 'mpointer) (slot-value object 'mpointer))
(let ((blockptr (cffi:foreign-alloc 'gsl-combination-c))) (let ((blockptr (cffi:foreign-alloc 'gsl-combination-c)))
(setf (block-pointer object) (setf (block-pointer object)
blockptr blockptr
(cffi:foreign-slot-value blockptr 'gsl-combination-c 'data) (cffi:foreign-slot-value blockptr 'gsl-combination-c 'data)
(c-pointer object) (c-pointer object)
(cffi:foreign-slot-value blockptr 'gsl-combination-c 'n) (cffi:foreign-slot-value blockptr 'gsl-combination-c 'n)
(elt (dimensions object) 0) (choice-of object)
(cffi:foreign-slot-value blockptr 'gsl-combination-c 'k) (cffi:foreign-slot-value blockptr 'gsl-combination-c 'k)
(elt (dimensions object) 1) (first (dimensions object))
(mpointer object) (slot-value object 'mpointer)
(block-pointer object)) (block-pointer object))
(tg:finalize (tg:finalize
object object
...@@ -161,21 +166,21 @@ ...@@ -161,21 +166,21 @@
;;;;**************************************************************************** ;;;;****************************************************************************
(save-test combination (save-test combination
(letm ((comb (combination '(4 2) t))) ; combination-range (let ((comb (make-combination 4 2))) ; combination-range
(combination-range comb)) (combination-range comb))
(letm ((comb (combination '(4 2) t))) ; combination-size (let ((comb (make-combination 4 2))) ; combination-size
(combination-size comb)) (combination-size comb))
(letm ((comb (combination '(4 2) t))) ; init-first, combination-next (let ((comb (make-combination 4 2))) ; init-first, combination-next
(init-first comb) (init-first comb)
(loop collect (copy-seq (cl-array comb)) (loop collect (copy-seq (cl-array comb))
while (combination-next comb))) while (combination-next comb)))
(letm ((comb (combination '(4 2) t))) ; init-last, combination-previous (let ((comb (make-combination 4 2))) ; init-last, combination-previous
(init-last comb) (init-last comb)
(loop collect (copy-seq (cl-array comb)) (loop collect (copy-seq (cl-array comb))
while (combination-previous comb))) while (combination-previous comb)))
(loop for i from 0 to 4 ; combination-next (loop for i from 0 to 4 ; combination-next
append append
(letm ((comb (combination (list 4 i) t))) (let ((comb (make-combination 4 i)))
(init-first comb) (init-first comb)
(loop collect (copy-seq (cl-array comb)) (loop collect (copy-seq (cl-array comb))
while (combination-next comb))))) while (combination-next comb)))))
;; "Data" is bulk arrayed data, like vectors, matrices, permutations, ;; "Data" is bulk arrayed data, like vectors, matrices, permutations,
;; combinations, or histograms. ;; combinations, or histograms.
;; Liam Healy 2008-04-06 21:23:41EDT ;; Liam Healy 2008-04-06 21:23:41EDT
;; Time-stamp: <2008-12-06 15:57:20EST data.lisp> ;; Time-stamp: <2008-12-06 18:50:57EST data.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -11,19 +11,18 @@ ...@@ -11,19 +11,18 @@
;;;;**************************************************************************** ;;;;****************************************************************************
(defclass gsl-data () (defclass gsl-data ()
((cl-array :initarg :cl-array :documentation "The Lisp array.") ((cl-array :documentation "The Lisp array.")
(mpointer :initarg :mpointer :accessor mpointer (mpointer :accessor mpointer
:documentation "A pointer to the GSL representation of the data.") :documentation "A pointer to the GSL representation of the data.")
(block-pointer :initform nil :accessor block-pointer (block-pointer :initform nil :accessor block-pointer
:documentation "A pointer to the gsl-block-c.") :documentation "A pointer to the gsl-block-c.")
#-native #-native
(c-pointer :initarg :c-pointer :accessor c-pointer (c-pointer :accessor c-pointer :documentation "A pointer to the C array.")
:documentation "A pointer to the C array.") (dimensions :reader dimensions)
(dimensions :initarg :dimensions :reader dimensions) (total-size :reader total-size)
(total-size :initarg :total-size :reader total-size) (element-type :reader element-type)
(element-type :initarg :element-type :reader element-type) (original-array :reader original-array)
(original-array :initarg :original-array :reader original-array) (offset :reader offset)
(offset :initarg :offset :reader offset)
#-native #-native
(cl-invalid (cl-invalid
:initform t :accessor cl-invalid :initform t :accessor cl-invalid
...@@ -47,11 +46,16 @@ ...@@ -47,11 +46,16 @@
(export '(dimensions total-size element-type)) (export '(dimensions total-size element-type))
(defmethod initialize-instance :after ((object gsl-data) &rest initargs) ;;; Allowable keys: :dimensions, :initial-contents, :initial-element.
(declare (ignore initargs)) (defmethod initialize-instance :after
(multiple-value-bind (oa index-offset) ((object gsl-data) &rest initargs &key &allow-other-keys)
(find-original-array (cl-array object)) (with-slots (cl-array dimensions original-array offset total-size) object
(with-slots (original-array offset) object (let ((ffa (apply #'make-ffa (element-type object) initargs)))
(setf cl-array ffa
dimensions (array-dimensions ffa)
total-size (array-total-size ffa)))
(multiple-value-bind (oa index-offset)
(find-original-array (cl-array object))
(setf original-array oa (setf original-array oa
offset offset
(* index-offset (* index-offset
...@@ -112,19 +116,19 @@ ...@@ -112,19 +116,19 @@
;;;;**************************************************************************** ;;;;****************************************************************************
(export 'make-array*) (export 'make-array*)
(defun make-array* (element-type &rest keys) (defun make-array*
(element-type &rest keys &key dimensions initial-contents &allow-other-keys)
"Make a GSLL array with the given element type, "Make a GSLL array with the given element type,
:dimensions, :initial-contents and/or :initial-element." :dimensions, :initial-contents and/or :initial-element."
(let ((ffa (apply #'make-ffa element-type keys))) (apply #'make-instance
(make-instance (data-class-name
(data-class-name (if
(if (eql (array-rank ffa) 2) 'matrix 'vector) (or
element-type) (and dimensions (listp dimensions) (eql (length dimensions) 2))
:cl-array ffa (and initial-contents (listp (first initial-contents))))
:mpointer nil 'matrix 'vector)
#-native :c-pointer #-native nil ; this will be set by defmfun element-type)
:dimensions (array-dimensions ffa) keys))
:total-size (array-total-size ffa))))
(defun hashm-numeric-code (n) (defun hashm-numeric-code (n)
"Get the appropriate element type for the numeric code n" "Get the appropriate element type for the numeric code n"
......
;; Permutations ;; Permutations
;; Liam Healy, Sun Mar 26 2006 - 11:51 ;; Liam Healy, Sun Mar 26 2006 - 11:51
;; Time-stamp: <2008-12-06 14:10:53EST permutation.lisp> ;; Time-stamp: <2008-12-06 19:03:50EST permutation.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -18,6 +18,22 @@ ...@@ -18,6 +18,22 @@
(pushnew (cons 'permutation *sizet-type*) (pushnew (cons 'permutation *sizet-type*)
*class-element-type* :test #'equal) *class-element-type* :test #'equal)
(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
:dimensions (if (typep n 'permutation) (dimensions n) n))))
(when initialize
(if (typep n 'permutation)
(copy perm n)
(set-identity perm)))
perm))
(defmethod alloc-from-block ((perm permutation)) (defmethod alloc-from-block ((perm permutation))
;; GSL permutations are not based on blocks, but a gsl_permutation ;; GSL permutations are not based on blocks, but a gsl_permutation
;; struct is identical to the gsl_block struct, so return the ;; struct is identical to the gsl_block struct, so return the
...@@ -35,6 +51,8 @@ ...@@ -35,6 +51,8 @@
:definition :method :definition :method
:c-return :void :c-return :void
:inputs (permutation) :inputs (permutation)
:outputs (permutation)
:return (permutation)
:documentation ; FDL :documentation ; FDL
"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).")
...@@ -239,14 +257,14 @@ ...@@ -239,14 +257,14 @@
(defun generate-all-permutations (n) (defun generate-all-permutations (n)
"Generate all the permutations of n objects." "Generate all the permutations of n objects."
(letm ((perm (permutation n))) (let ((perm (make-permutation n)))
(set-identity perm) (set-identity perm)
(loop collect (copy-seq (cl-array perm)) (loop collect (copy-seq (cl-array perm))
while (permutation-next perm)))) while (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."
(letm ((perm (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 (copy-seq (cl-array perm))
...@@ -254,43 +272,41 @@ ...@@ -254,43 +272,41 @@
(save-test (save-test
permutation permutation
(letm ((perm-1 (permutation 4 t))) ;maref (let ((perm-1 (make-permutation 4 t))) ;maref
(set-identity perm-1)
(maref perm-1 2)) (maref perm-1 2))
(letm ((perm-1 (permutation 4 t))) ;cl-array (let ((perm-1 (make-permutation 4 t))) ;cl-array
(set-identity perm-1)
(cl-array perm-1)) (cl-array perm-1))
(letm ((perm-1 (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))) (cl-array (permutation-reverse perm-1)))
(letm ;permutation-next, permutation-inverse (let ;permutation-next, permutation-inverse
((perm-1 (permutation 4 t)) (perm-2 (permutation 4 t))) ((perm-1 (make-permutation 4 t)) (perm-2 (make-permutation 4 t)))
(set-identity perm-1) (set-identity perm-1)
(permutation-next perm-1) (permutation-next perm-1)
(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)) (cl-array perm-2))
(letm ((perm-1 (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)) (cl-array perm-1))
(letm ((perm-1 (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-vector perm-1 intvec) (permute-vector perm-1 intvec)
(cl-array intvec)) (cl-array intvec))
(letm ((perm-1 (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)
(inversions perm-1)) (inversions perm-1))
(letm ((perm-1 (permutation 4 t))) ;linear-cycles (let ((perm-1 (make-permutation 4 t))) ;linear-cycles
(set-identity perm-1) (set-identity perm-1)
(swap-elements perm-1 1 3) (swap-elements perm-1 1 3)
(linear-cycles perm-1)) (linear-cycles perm-1))
(letm ((perm-1 (permutation 4 t))) ;canonical-cycles (let ((perm-1 (make-permutation 4 t))) ;canonical-cycles
(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)
......
;; Polynomials ;; Polynomials
;; Liam Healy, Tue Mar 21 2006 - 18:33 ;; Liam Healy, Tue Mar 21 2006 - 18:33
;; Time-stamp: <2008-11-30 23:38:39EST polynomial.lisp> ;; Time-stamp: <2008-12-06 16:08:23EST polynomial.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -172,8 +172,8 @@ ...@@ -172,8 +172,8 @@
;;;;**************************************************************************** ;;;;****************************************************************************
(save-test polynomial (save-test polynomial
(letm ((xa #m(0.0d0 1.0d0 2.0d0 3.0d0)) (let ((xa #m(0.0d0 1.0d0 2.0d0 3.0d0))
(ya (#m(2.5d0 7.2d0 32.7d0 91.0d0) )) (ya #m(2.5d0 7.2d0 32.7d0 91.0d0))
(dd (make-array* 'double-float :dimensions 4))) (dd (make-array* 'double-float :dimensions 4)))
(divided-difference dd xa ya) (divided-difference dd xa ya)
(list (list
...@@ -181,7 +181,7 @@ ...@@ -181,7 +181,7 @@
(polynomial-eval-divided-difference dd xa 1.0d0) (polynomial-eval-divided-difference dd xa 1.0d0)
(polynomial-eval-divided-difference dd xa 2.0d0) (polynomial-eval-divided-difference dd xa 2.0d0)
(polynomial-eval-divided-difference dd xa 3.0d0))) (polynomial-eval-divided-difference dd xa 3.0d0)))
(letm ((vec #m(1.0d0 2.0d0 3.0d0))) (let ((vec #m(1.0d0 2.0d0 3.0d0)))
(polynomial-eval vec -1.0d0)) (polynomial-eval vec -1.0d0))
(solve-quadratic 1.0d0 0.0d0 1.0d0) (solve-quadratic 1.0d0 0.0d0 1.0d0)
(solve-quadratic 1.0d0 -2.0d0 1.0d0) (solve-quadratic 1.0d0 -2.0d0 1.0d0)
......
;; Sorting ;; Sorting
;; Liam Healy, Fri Apr 14 2006 - 20:20 ;; Liam Healy, Fri Apr 14 2006 - 20:20
;; Time-stamp: <2008-11-15 22:51:52EST sorting.lisp> ;; Time-stamp: <2008-12-06 17:46:20EST sorting.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -256,7 +256,7 @@ ...@@ -256,7 +256,7 @@
(cl-array (msort m1)))) (cl-array (msort m1))))
(generate-all-array-tests sort-vector-index :no-complex (generate-all-array-tests sort-vector-index :no-complex
(letm ((perm (permutation 8)) (letm ((perm (make-permutation 8))
(v1 (array-default 8))) (v1 (array-default 8)))
(sort-vector-index perm v1) (sort-vector-index perm v1)
(cl-array perm))) (cl-array perm)))
...@@ -272,7 +272,7 @@ ...@@ -272,7 +272,7 @@
(cl-array (sort-smallest m2 m1)))) (cl-array (sort-smallest m2 m1))))
(generate-all-array-tests sort-vector-smallest-index :no-complex (generate-all-array-tests sort-vector-smallest-index :no-complex
(letm ((comb (combination '(8 3))) (letm ((comb (make-combination '(8 3)))
(v1 (array-default 8))) (v1 (array-default 8)))
(cl-array (sort-vector-smallest-index comb v1)))) (cl-array (sort-vector-smallest-index comb v1))))
...@@ -287,6 +287,6 @@ ...@@ -287,6 +287,6 @@
(cl-array (sort-largest m2 m1)))) (cl-array (sort-largest m2 m1))))
(generate-all-array-tests sort-vector-largest-index :no-complex (generate-all-array-tests sort-vector-largest-index :no-complex
(letm ((comb (combination '(8 3))) (letm ((comb (make-combination '(8 3)))
(v1 (array-default 8))) (v1 (array-default 8)))
(cl-array (sort-vector-largest-index comb v1)))) (cl-array (sort-vector-largest-index comb v1))))
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