Commit 4c380808 authored by Liam Healy's avatar Liam Healy

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
;; Combinations
;; 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$
(in-package :gsl)
......@@ -18,35 +18,40 @@
(defclass combination
(#+sizet-64 vector-unsigned-byte-64
#+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."))
(export 'make-combination)
(defun make-combination (nk)
"Make the combination object with the data array."
(let ((k (second nk)))
(make-instance
'combination
:cl-array (make-array* k *sizet-type*)
:mpointer nil ; this will be set by :before method below.
#-native :c-pointer #-native nil ; this will be set by defmfun
:dimensions (copy-list nk)
;; The total-size of a combination is k, because that is the length
;; of the vector that represents it.
:total-size k)))
(defun make-combination (n &optional k (initialize t))
"Make the object representing a combination of k things from a set of n.
If initialize is T, initialize as the first k values (init-first).
If n is a combination, make a new combination with the same
specification. If initialize is also T, copy it."
(let ((comb
(if (typep n 'combination)
(make-instance
'combination :choice-of (choice-of n) :dimensions (dimensions k))
(make-instance 'combination :choice-of n :dimensions k))))
(when initialize
(if (typep n 'combination)
(copy comb n)
(init-first comb)))
comb))
(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)))
(setf (block-pointer object)
blockptr
(cffi:foreign-slot-value blockptr 'gsl-combination-c 'data)
(c-pointer object)
(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)
(elt (dimensions object) 1)
(mpointer object)
(first (dimensions object))
(slot-value object 'mpointer)
(block-pointer object))
(tg:finalize
object
......@@ -161,21 +166,21 @@
;;;;****************************************************************************
(save-test combination
(letm ((comb (combination '(4 2) t))) ; combination-range
(let ((comb (make-combination 4 2))) ; combination-range
(combination-range comb))
(letm ((comb (combination '(4 2) t))) ; combination-size
(let ((comb (make-combination 4 2))) ; combination-size
(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)
(loop collect (copy-seq (cl-array 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)
(loop collect (copy-seq (cl-array comb))
while (combination-previous comb)))
(loop for i from 0 to 4 ; combination-next
append
(letm ((comb (combination (list 4 i) t)))
(let ((comb (make-combination 4 i)))
(init-first comb)
(loop collect (copy-seq (cl-array comb))
while (combination-next comb)))))
;; "Data" is bulk arrayed data, like vectors, matrices, permutations,
;; combinations, or histograms.
;; 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$
(in-package :gsl)
......@@ -11,19 +11,18 @@
;;;;****************************************************************************
(defclass gsl-data ()
((cl-array :initarg :cl-array :documentation "The Lisp array.")
(mpointer :initarg :mpointer :accessor mpointer
((cl-array :documentation "The Lisp array.")
(mpointer :accessor mpointer
:documentation "A pointer to the GSL representation of the data.")
(block-pointer :initform nil :accessor block-pointer
:documentation "A pointer to the gsl-block-c.")
#-native
(c-pointer :initarg :c-pointer :accessor c-pointer
:documentation "A pointer to the C array.")
(dimensions :initarg :dimensions :reader dimensions)
(total-size :initarg :total-size :reader total-size)
(element-type :initarg :element-type :reader element-type)
(original-array :initarg :original-array :reader original-array)
(offset :initarg :offset :reader offset)
(c-pointer :accessor c-pointer :documentation "A pointer to the C array.")
(dimensions :reader dimensions)
(total-size :reader total-size)
(element-type :reader element-type)
(original-array :reader original-array)
(offset :reader offset)
#-native
(cl-invalid
:initform t :accessor cl-invalid
......@@ -47,11 +46,16 @@
(export '(dimensions total-size element-type))
(defmethod initialize-instance :after ((object gsl-data) &rest initargs)
(declare (ignore initargs))
(multiple-value-bind (oa index-offset)
(find-original-array (cl-array object))
(with-slots (original-array offset) object
;;; Allowable keys: :dimensions, :initial-contents, :initial-element.
(defmethod initialize-instance :after
((object gsl-data) &rest initargs &key &allow-other-keys)
(with-slots (cl-array dimensions original-array offset total-size) 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
offset
(* index-offset
......@@ -112,19 +116,19 @@
;;;;****************************************************************************
(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,
:dimensions, :initial-contents and/or :initial-element."
(let ((ffa (apply #'make-ffa element-type keys)))
(make-instance
(data-class-name
(if (eql (array-rank ffa) 2) 'matrix 'vector)
element-type)
:cl-array ffa
:mpointer nil
#-native :c-pointer #-native nil ; this will be set by defmfun
:dimensions (array-dimensions ffa)
:total-size (array-total-size ffa))))
(apply #'make-instance
(data-class-name
(if
(or
(and dimensions (listp dimensions) (eql (length dimensions) 2))
(and initial-contents (listp (first initial-contents))))
'matrix 'vector)
element-type)
keys))
(defun hashm-numeric-code (n)
"Get the appropriate element type for the numeric code n"
......
;; Permutations
;; 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$
(in-package :gsl)
......@@ -18,6 +18,22 @@
(pushnew (cons 'permutation *sizet-type*)
*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))
;; GSL permutations are not based on blocks, but a gsl_permutation
;; struct is identical to the gsl_block struct, so return the
......@@ -35,6 +51,8 @@
:definition :method
:c-return :void
:inputs (permutation)
:outputs (permutation)
:return (permutation)
:documentation ; FDL
"Initialize the permutation p to the identity, i.e.
(0,1,2,...,n-1).")
......@@ -239,14 +257,14 @@
(defun generate-all-permutations (n)
"Generate all the permutations of n objects."
(letm ((perm (permutation n)))
(let ((perm (make-permutation n)))
(set-identity perm)
(loop collect (copy-seq (cl-array perm))
while (permutation-next perm))))
(defun generate-all-permutations-backwards (n)
"Generate all the permutations of n objects."
(letm ((perm (permutation n)))
(let ((perm (make-permutation n)))
(set-identity perm)
(permutation-reverse perm)
(loop collect (copy-seq (cl-array perm))
......@@ -254,43 +272,41 @@
(save-test
permutation
(letm ((perm-1 (permutation 4 t))) ;maref
(set-identity perm-1)
(let ((perm-1 (make-permutation 4 t))) ;maref
(maref perm-1 2))
(letm ((perm-1 (permutation 4 t))) ;cl-array
(set-identity perm-1)
(let ((perm-1 (make-permutation 4 t))) ;cl-array
(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)
(cl-array (permutation-reverse perm-1)))
(letm ;permutation-next, permutation-inverse
((perm-1 (permutation 4 t)) (perm-2 (permutation 4 t)))
(let ;permutation-next, permutation-inverse
((perm-1 (make-permutation 4 t)) (perm-2 (make-permutation 4 t)))
(set-identity perm-1)
(permutation-next perm-1)
(permutation-next perm-1)
(permutation-next perm-1)
(permutation-inverse perm-2 perm-1)
(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)
(swap-elements perm-1 1 3)
(cl-array perm-1))
(letm ((perm-1 (permutation 4 t)) ;permute-vector
(intvec #31m(11 22 33 44)))
(let ((perm-1 (make-permutation 4 t)) ;permute-vector
(intvec #31m(11 22 33 44)))
(set-identity perm-1)
(swap-elements perm-1 1 3)
(swap-elements perm-1 0 2)
(permute-vector perm-1 intvec)
(cl-array intvec))
(letm ((perm-1 (permutation 4 t))) ;inversions
(let ((perm-1 (make-permutation 4 t))) ;inversions
(set-identity perm-1)
(swap-elements perm-1 1 3)
(inversions perm-1))
(letm ((perm-1 (permutation 4 t))) ;linear-cycles
(let ((perm-1 (make-permutation 4 t))) ;linear-cycles
(set-identity perm-1)
(swap-elements perm-1 1 3)
(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)
(swap-elements perm-1 1 3)
(swap-elements perm-1 0 2)
......
;; Polynomials
;; 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$
(in-package :gsl)
......@@ -172,8 +172,8 @@
;;;;****************************************************************************
(save-test polynomial
(letm ((xa #m(0.0d0 1.0d0 2.0d0 3.0d0))
(ya (#m(2.5d0 7.2d0 32.7d0 91.0d0) ))
(let ((xa #m(0.0d0 1.0d0 2.0d0 3.0d0))
(ya #m(2.5d0 7.2d0 32.7d0 91.0d0))
(dd (make-array* 'double-float :dimensions 4)))
(divided-difference dd xa ya)
(list
......@@ -181,7 +181,7 @@
(polynomial-eval-divided-difference dd xa 1.0d0)
(polynomial-eval-divided-difference dd xa 2.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))
(solve-quadratic 1.0d0 0.0d0 1.0d0)
(solve-quadratic 1.0d0 -2.0d0 1.0d0)
......
;; Sorting
;; 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$
(in-package :gsl)
......@@ -256,7 +256,7 @@
(cl-array (msort m1))))
(generate-all-array-tests sort-vector-index :no-complex
(letm ((perm (permutation 8))
(letm ((perm (make-permutation 8))
(v1 (array-default 8)))
(sort-vector-index perm v1)
(cl-array perm)))
......@@ -272,7 +272,7 @@
(cl-array (sort-smallest m2 m1))))
(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)))
(cl-array (sort-vector-smallest-index comb v1))))
......@@ -287,6 +287,6 @@
(cl-array (sort-largest m2 m1))))
(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)))
(cl-array (sort-vector-largest-index comb v1))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment