Commit 2965e775 authored by Liam Healy's avatar Liam Healy
Browse files

Merge ntuple

Merge branch 'ntuple'
parents 8555fb6a f9157461
;; 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")
......
;; 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*))
......
;; 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))
;; 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))
......
;; 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)))
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