diff --git a/gsll-tests.asd b/gsll-tests.asd index 5c721d57b845b7c1676c0d297f8f4e2f7051c1d9..b3889103aa37b24d1197b61fe72d7673b2d32a18 100644 --- a/gsll-tests.asd +++ b/gsll-tests.asd @@ -1,6 +1,6 @@ ;; Definition of GSLL system ;; Liam Healy -;; Time-stamp: <2009-05-03 16:59:16EDT gsll-tests.asd> +;; Time-stamp: <2009-08-26 21:04:08EDT gsll-tests.asd> (asdf:defsystem "gsll-tests" :name "gsll-tests" @@ -125,6 +125,7 @@ (:file "multinomial") (:file "negative-binomial") (:file "nonlinear-least-squares") + (:file "ntuple") (:file "numerical-differentiation") (:file "numerical-integration") (:file "ode") diff --git a/gsll.asd b/gsll.asd index 05cc200b0486b4300d4cd2e2eb0ad2116b8caeeb..5c571976a4e8768693382289db21c1281ee1cc54 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,6 +1,6 @@ ;; Definition of GSLL system ;; Liam Healy -;; Time-stamp: <2009-08-24 09:53:37EDT gsll.asd> +;; Time-stamp: <2009-08-26 21:26:40EDT gsll.asd> (when (asdf:find-system :fsbv nil) (pushnew :fsbv *features*)) diff --git a/histogram/ntuple-example.dat b/histogram/ntuple-example.dat new file mode 100644 index 0000000000000000000000000000000000000000..be4cb5a5d29dc9072987e90d6886995088febcb2 Binary files /dev/null and b/histogram/ntuple-example.dat differ diff --git a/histogram/ntuple.lisp b/histogram/ntuple.lisp index 437eaf5466ef09fdede7a4f8a300f87eec2d3101..6b21b432577b2f8382acf5af9ba6536dfb565d55 100644 --- a/histogram/ntuple.lisp +++ b/histogram/ntuple.lisp @@ -1,17 +1,16 @@ ;; N-tuples ;; Liam Healy Sat Feb 3 2007 - 12:53 -;; Time-stamp: <2008-08-17 09:39:34EDT ntuple.lisp> -;; $Id$ +;; Time-stamp: <2009-08-26 21:15:23EDT ntuple.lisp> (in-package :gsl) -;;; The basic definitions are here, but a smooth interface to CL -;;; has not been created, and it has not been tested. +;;; /usr/include/gsl/gsl_ntuple.h ;;; Writing a file -(defmfun create-ntuple (filename data size) +(defmfun create-ntuple (filename data foreign-type) "gsl_ntuple_create" - ((filename :string) (data :pointer) (size sizet)) + ((filename :string) (data :pointer) + ((cffi:foreign-type-size foreign-type) sizet)) :c-return :pointer :documentation ; FDL "Create a new write-only ntuple file filename for @@ -22,9 +21,10 @@ in and out of the file.") ;;; Reading a file -(defmfun open-ntuple (filename data size) - "gsl_ntuple_create" - ((filename :string) (data :pointer) (size sizet)) +(defmfun open-ntuple (filename data foreign-type) + "gsl_ntuple_open" + ((filename :string) (data :pointer) + ((cffi:foreign-type-size foreign-type) sizet)) :c-return :pointer :documentation ; FDL "Open an existing ntuple file filename for reading @@ -59,39 +59,169 @@ "gsl_ntuple_close" ((ntuple :pointer)) :documentation ; FDL - "Closes the ntuple file ntupe and frees its - associated allocated memory.") + "Closes the ntuple file and frees its associated allocated memory.") ;;; Histogramming ntuple values +#| +;;; This the one function in GSL that requires two cbstructs. Rather +;;; than modify the entire defmfun apparatus to handle it, we just +;;; manually build the expansion below. + (defmfun project-ntuple (histogram ntuple value-function select-function) "gsl_ntuple_project" - ((histogram :pointer) (ntuple :pointer) - (value-function :pointer) (select-function :pointer)) + (((mpointer histogram) :pointer) (ntuple :pointer) + (valfn :pointer) (selfn :pointer)) + :callbacks + ;; (valfn fnstruct nil (value-function :pointer (:input :pointer) :slug)) + ;; Need a second cbstruct definition: + (selfn fnstruct nil (select-function :pointer (:input :pointer) :slug)) + ;;:callback-dynamic (nil (value-function)) + :callback-dynamic (nil (select-function)) :documentation ; FDL - "Update the histogram the ntuple + "Update the histogram from the ntuple using the functions value-function and select-function. For each ntuple row where the selection function select-function is non-zero the corresponding value of that row is computed using the function value-function and added to the histogram. Those ntuple rows where select-function returns zero are ignored. New entries are added to the histogram, so subsequent calls can be used to accumulate further - data in the same histogram.") + data in the same histogram.") +|# -;;; Callback definitions +(PROGN + (DEFUN PROJECT-NTUPLE (HISTOGRAM NTUPLE VALUE-FUNCTION SELECT-FUNCTION) + (DECLARE (SPECIAL PROJECT-NTUPLE-DYNFN0 PROJECT-NTUPLE-DYNFN1)) + "Update the histogram from the ntuple + using the functions value-function and select-function. For each + ntuple row where the selection function select-function is non-zero the + corresponding value of that row is computed using the function + value-function and added to the histogram. Those ntuple rows where + select-function returns zero are ignored. New entries are added to + the histogram, so subsequent calls can be used to accumulate further + data in the same histogram." + (WITH-FOREIGN-OBJECTS ((VALFN 'FNSTRUCT) (SELFN 'fnstruct)) + (SETF PROJECT-NTUPLE-DYNFN0 + (MAKE-COMPILED-FUNCALLABLE + VALUE-FUNCTION + '(FUNCTION :double (:INPUT :POINTER) :SLUG) NIL (LIST)) + PROJECT-NTUPLE-DYNFN1 + (MAKE-COMPILED-FUNCALLABLE + SELECT-FUNCTION + '(FUNCTION :boolean (:INPUT :POINTER) :SLUG) NIL (LIST))) + (SET-CBSTRUCT VALFN 'FNSTRUCT NIL (LIST 'FUNCTION 'PROJECT-NTUPLE-CBFN0)) + (SET-CBSTRUCT SELFN 'FNSTRUCT NIL (LIST 'FUNCTION 'PROJECT-NTUPLE-CBFN1)) + (LET ((CRETURN + (FOREIGN-FUNCALL "gsl_ntuple_project" :POINTER + (MPOINTER HISTOGRAM) :POINTER NTUPLE + :POINTER VALFN :POINTER SELFN + :INT))) + (CHECK-GSL-STATUS CRETURN 'PROJECT-NTUPLE) + (VALUES)))) + (DEFMCALLBACK PROJECT-NTUPLE-CBFN0 PROJECT-NTUPLE-DYNFN0 + (VALUE-FUNCTION :double (:INPUT :POINTER) :SLUG)) + (DEFMCALLBACK PROJECT-NTUPLE-CBFN1 PROJECT-NTUPLE-DYNFN1 + (SELECT-FUNCTION :boolean (:INPUT :POINTER) :SLUG)) + (MAP-NAME 'PROJECT-NTUPLE "gsl_ntuple_project") + (EXPORT 'PROJECT-NTUPLE)) -(export '(def-ntuple-select-function def-ntuple-value-function)) +;;; Callback definitions -(defmacro def-ntuple-select-function (name arg) +#| ;; FDL "The selection function determines which ntuple rows are selected for histogramming. The struct component function should return a non-zero value for each ntuple row that is to be included in the histogram. " - `(def-single-function ,name ,arg :int :pointer)) - -(defmacro def-ntuple-value-function (name arg) ;; FDL "The value function computes scalar values for those ntuple rows selected by the selection function which should return the value to be added to the histogram." - `(def-single-function ,name ,arg :double :pointer)) +|# + +;;; Examples and unit test +;;; See gsl-1.11/ntuple/test.c + +(defparameter *ntuple-example-data-file* + (namestring + (merge-pathnames + "ntuple-example.dat" + (asdf:component-pathname + (asdf:find-component (asdf:find-system :gsll) "histogram")))) + "The full path string of the ntuple example data file. This can be created + with the function #'make-ntuple-example-data.") + +(defcstruct ntuple-data + (num :int) + (x :double) + (y :double) + (z :double)) + +(defvar *ntuple-example-scale* 1.5d0) + +(defun ntuple-example-values (i) + (let ((xi (/ (+ i 1.5d0)))) + (values xi (expt xi 2) (expt xi 3)))) + +(defun make-ntuple-example-data + (&optional (filename *ntuple-example-data-file*)) + (cffi:with-foreign-object (data 'ntuple-data) + (let ((ntuple (create-ntuple filename data 'ntuple-data)) + (answer (make-array 100 :element-type 'fixnum :initial-element 0))) + (dotimes (row 1000) + (multiple-value-bind (xi yi zi) + (ntuple-example-values row) + (setf (cffi:foreign-slot-value data 'ntuple-data 'num) row + (cffi:foreign-slot-value data 'ntuple-data 'x) xi + (cffi:foreign-slot-value data 'ntuple-data 'y) yi + (cffi:foreign-slot-value data 'ntuple-data 'z) zi) + (when (< (* xi *ntuple-example-scale*) 0.1d0) + (incf (aref answer (truncate (* 100 *ntuple-example-scale* (+ xi yi zi))))))) + (bookdata-ntuple ntuple)) + (close-ntuple ntuple) + answer))) + +(defun ntuple-example-read (&optional (filename *ntuple-example-data-file*)) + (cffi:with-foreign-object (data 'ntuple-data) + (let ((ntuple (open-ntuple filename data 'ntuple-data))) + (prog1 + (dotimes (row 1000 t) + (multiple-value-bind (xi yi zi) + (ntuple-example-values row) + (read-ntuple ntuple) + (unless + (and (eql row (cffi:foreign-slot-value data 'ntuple-data 'num)) + (eql xi (cffi:foreign-slot-value data 'ntuple-data 'x)) + (eql yi (cffi:foreign-slot-value data 'ntuple-data 'y)) + (eql zi (cffi:foreign-slot-value data 'ntuple-data 'z))) + (return nil)))) + (close-ntuple ntuple))))) + +(defun ntuple-example-sel-func (ntuple-data) + (< (* (cffi:foreign-slot-value ntuple-data 'ntuple-data 'x) + *ntuple-example-scale*) + 0.1d0)) + +(defun ntuple-example-val-func (ntuple-data) + (* (+ (cffi:foreign-slot-value ntuple-data 'ntuple-data 'x) + (cffi:foreign-slot-value ntuple-data 'ntuple-data 'y) + (cffi:foreign-slot-value ntuple-data 'ntuple-data 'z)) + *ntuple-example-scale*)) + +(defun ntuple-example-histogramming + (&optional (filename *ntuple-example-data-file*)) + (cffi:with-foreign-object (data 'ntuple-data) + (let ((histo (make-histogram 100)) + (ntuple (open-ntuple filename data 'ntuple-data)) + (answer (make-ntuple-example-data filename))) + (set-ranges-uniform histo 0.0d0 1.0d0) + (project-ntuple + histo ntuple 'ntuple-example-val-func 'ntuple-example-sel-func) + (close-ntuple ntuple) + ;; Check the histogram to see if it matches ntuple-example-values + (dotimes (row 100 t) + (unless (= (maref histo row) (aref answer row)) + (return nil)))))) + +(save-test ntuple + (ntuple-example-read) + (ntuple-example-histogramming)) diff --git a/init/callback-struct.lisp b/init/callback-struct.lisp index 2257e40f59272125d9ac903e805e39ff9150e1b1..4322c2c0ed2c7d504e9418a989432d61ab1526ad 100644 --- a/init/callback-struct.lisp +++ b/init/callback-struct.lisp @@ -1,6 +1,6 @@ ;; GSL structures for holding functions ;; Liam Healy 2009-04-04 22:15:56EDT callback-struct.lisp -;; Time-stamp: <2009-08-23 10:15:52EDT callback-struct.lisp> +;; Time-stamp: <2009-08-26 21:26:02EDT callback-struct.lisp> (in-package :gsl) @@ -15,6 +15,8 @@ (include "gsl/gsl_math.h") ;;; Only the function +;;; also in /usr/include/gsl/gsl_ntuple.h as gsl_ntuple_select_fn and +;;; gsl_ntuple_value_fn. (cstruct fnstruct "gsl_function" (function "function" :type :pointer) (parameters "params" :type :pointer)) diff --git a/tests/ntuple.lisp b/tests/ntuple.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c07bc9b2a22c10b4bbe1291deead396c22d26f06 --- /dev/null +++ b/tests/ntuple.lisp @@ -0,0 +1,8 @@ +;; Regression test NTUPLE for GSLL, automatically generated + +(in-package :gsl) + +(LISP-UNIT:DEFINE-TEST NTUPLE + (LISP-UNIT:ASSERT-true (NTUPLE-EXAMPLE-READ)) + (LISP-UNIT:ASSERT-true (NTUPLE-EXAMPLE-HISTOGRAMMING))) +