From 87dee7fd98539d1fbcbae1a1c0d5217a080de299 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Fri, 26 Feb 2021 19:25:31 +0530 Subject: Rename project to nsmc. --- scm/extent-sampling/load-libs.scm.in | 13 -- scm/extent-sampling/wrap.scm | 365 ----------------------------------- scm/nsmc/load-libs.scm.in | 13 ++ scm/nsmc/wrap.scm | 365 +++++++++++++++++++++++++++++++++++ 4 files changed, 378 insertions(+), 378 deletions(-) delete mode 100644 scm/extent-sampling/load-libs.scm.in delete mode 100644 scm/extent-sampling/wrap.scm create mode 100644 scm/nsmc/load-libs.scm.in create mode 100644 scm/nsmc/wrap.scm (limited to 'scm') diff --git a/scm/extent-sampling/load-libs.scm.in b/scm/extent-sampling/load-libs.scm.in deleted file mode 100644 index 1b99e53..0000000 --- a/scm/extent-sampling/load-libs.scm.in +++ /dev/null @@ -1,13 +0,0 @@ -(define lib-extentsampling - (catch #t - (lambda () - (dynamic-link "@CMAKE_INSTALL_FULL_LIBDIR@/libextentsampling")) - (lambda _ - (dynamic-link "libextentsampling")))) - -(define lib-gsl - (catch #t - (lambda () - (dynamic-link "@GSL_LIBRARY@")) - (lambda _ - (dynamic-link "libgsl")))) diff --git a/scm/extent-sampling/wrap.scm b/scm/extent-sampling/wrap.scm deleted file mode 100644 index 306caa4..0000000 --- a/scm/extent-sampling/wrap.scm +++ /dev/null @@ -1,365 +0,0 @@ -(define-module (extent-sampling wrap) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (ice-9 match) - #:use-module (system foreign)) - -(include "load-libs.scm") - -(define (make-gsl-alloc allocator-name allocator-args freer-name) - (lambda args - (let ((obj - (apply (pointer->procedure - '* (dynamic-func allocator-name lib-gsl) allocator-args) - args))) - (set-pointer-finalizer! obj (dynamic-func freer-name lib-gsl)) - obj))) - -(define-public pi - ((pointer->procedure double - (dynamic-func "pi" lib-extentsampling) - (list)))) - -(define-public volume-of-ball - (pointer->procedure double - (dynamic-func "volume_of_ball" lib-extentsampling) - (list int))) - -(define-public surface-area-of-ball - (pointer->procedure double - (dynamic-func "surface_area_of_ball" lib-extentsampling) - (list int))) - -(define-public (lower-incomplete-gamma s x) - (* ((pointer->procedure double - (dynamic-func "gsl_sf_gamma" lib-gsl) - (list double)) - s) - ((pointer->procedure double - (dynamic-func "gsl_sf_gamma_inc_P" lib-gsl) - (list double double)) - s x))) - -(define-public angle-between-vectors - (pointer->procedure double - (dynamic-func "angle_between_vectors" lib-extentsampling) - (list '* '*))) - -(define-public planar-angle->solid-angle - (pointer->procedure double - (dynamic-func "planar_angle_to_solid_angle" lib-extentsampling) - (list double int))) - -;; Random state - -(define %gsl-random-state - ((make-gsl-alloc "gsl_rng_alloc" (list '*) "gsl_rng_free") - (dereference-pointer - (dynamic-pointer "gsl_rng_default" lib-gsl)))) - -(define-public (set-gsl-random-state! seed) - ((pointer->procedure void - (dynamic-func "gsl_rng_set" lib-gsl) - (list '* unsigned-long)) - %gsl-random-state seed)) - -(define-public random-flat - (cut (pointer->procedure double - (dynamic-func "gsl_ran_flat" lib-gsl) - (list '* double double)) - %gsl-random-state <> <>)) - -;; Vector functions - -(define vector-alloc - (make-gsl-alloc "gsl_vector_alloc" (list int) "gsl_vector_free")) - -(define-public (vector-size vector) - (match (parse-c-struct vector - (list size_t size_t '* '* int)) - ((size _ _ _ _) size))) - -(define-public (vector-scale! vector k) - "Scale VECTOR by a factor K." - ((pointer->procedure int - (dynamic-func "gsl_vector_scale" lib-gsl) - (list '* double)) - vector k) - vector) - -(define-public (vector-norm2 vector) - ((pointer->procedure double - (dynamic-func "gsl_blas_dnrm2" lib-gsl) - (list '*)) - vector)) - -(define-public (vector-add! u v) - "Return the vector sum of vectors U and V. The sum is stored in U." - ((pointer->procedure int - (dynamic-func "gsl_vector_add" lib-gsl) - (list '* '*)) - u v) - u) - -(define-public (basis n dimension) - "Return the basis vector in the Nth canonical direction." - (let ((vector (vector-alloc dimension))) - ((pointer->procedure void - (dynamic-func "gsl_vector_set_basis" lib-gsl) - (list '* int)) - vector n) - vector)) - -;; Histogram functions - -(define histogram-struct - (list size_t '* '*)) - -(define (histogram-alloc bins min max) - (let ((histogram - ((make-gsl-alloc "gsl_histogram_alloc" (list size_t) "gsl_histogram_free") - bins))) - ((pointer->procedure int - (dynamic-func "gsl_histogram_set_ranges_uniform" lib-gsl) - (list '* double double)) - histogram min max) - histogram)) - -(define-public (histogram->points histogram) - (match (parse-c-struct histogram histogram-struct) - ((n range bin) - (let ((range (array->list (pointer->bytevector range (1+ n) 0 'f64)))) - (map cons - (drop-right range 1) - (array->list (pointer->bytevector bin n 0 'f64))))))) - -(define-public (histogram->pdf histogram) - (match (parse-c-struct histogram histogram-struct) - ((n range bin) - (let ((range (pointer->bytevector range (1+ n) 0 'f64))) - ((pointer->procedure int - (dynamic-func "gsl_histogram_scale" lib-extentsampling) - (list '* double)) - histogram - (/ n - (- (array-ref range n) - (array-ref range 0)) - (fold + 0 (array->list (pointer->bytevector bin n 0 'f64))))) - histogram)))) - -(define-public (rhistogram bins min max) - (case-lambda - (() (histogram-alloc bins min max)) - ((histogram) histogram) - ((histogram input) - ((pointer->procedure int - (dynamic-func "gsl_histogram_increment" lib-extentsampling) - (list '* double)) - histogram input) - histogram))) - -;; Running statistics - -(define rstat-alloc - (make-gsl-alloc "gsl_rstat_alloc" (list) "gsl_rstat_free")) - -(define-public rstat-n - (pointer->procedure size_t - (dynamic-func "gsl_rstat_n" lib-extentsampling) - (list '*))) - -;; Polynomial functions - -(define-public (polyval coefficients x) - ((pointer->procedure double - (dynamic-func "gsl_poly_eval" lib-gsl) - (list '* int double)) - (bytevector->pointer (list->typed-array 'f64 1 coefficients)) - (length coefficients) - x)) - -;; nd-random - -(define-public (random-direction-vector dimension) - (let ((vector (vector-alloc dimension))) - ((pointer->procedure void - (dynamic-func "random_direction_vector" lib-extentsampling) - (list '* '*)) - %gsl-random-state vector) - vector)) - -(define-public (subsampling-random-vector mean max-theta) - (let ((vector (vector-alloc (vector-size mean)))) - ((pointer->procedure void - (dynamic-func "subsampling_random_vector" lib-extentsampling) - (list '* '* double '*)) - %gsl-random-state mean max-theta vector) - vector)) - -(define-public (shifted-gaussian-random-vector mean max-theta standard-deviation) - (let* ((vector (vector-alloc (vector-size mean))) - (cost - ((pointer->procedure int - (dynamic-func "shifted_gaussian_random_vector" lib-extentsampling) - (list '* '* double double '*)) - %gsl-random-state mean max-theta standard-deviation vector))) - vector)) - -(define-public (shifted-gaussian-random-vector-cost mean max-theta standard-deviation) - ((pointer->procedure int - (dynamic-func "shifted_gaussian_random_vector" lib-extentsampling) - (list '* '* double double '*)) - %gsl-random-state mean max-theta standard-deviation (vector-alloc (vector-size mean)))) - -(define %integration-workspace - ((make-gsl-alloc "gsl_integration_workspace_alloc" (list size_t) "gsl_integration_workspace_free") - 1000)) - -(define-public (shifted-gaussian-pdf theta mean max-theta standard-deviation) - ((pointer->procedure double - (dynamic-func "shifted_gaussian_pdf" lib-extentsampling) - (list double double double double unsigned-int '*)) - theta (vector-norm2 mean) max-theta standard-deviation (vector-size mean) %integration-workspace)) - -;; oracles - -(define (make-extent-oracle oracle params) - (make-c-struct (list '* '*) - (list oracle params))) - -(define (make-bernoulli-params p r0 r1) - (make-c-struct (list double double double) - (list p r0 r1))) - -(define-public (make-bernoulli-oracle p r0 r1) - (make-extent-oracle (dynamic-func "bernoulli_extent_oracle" lib-extentsampling) - (make-bernoulli-params p r0 r1))) - -(define (true-volume-procedure name) - (pointer->procedure double - (dynamic-func name lib-extentsampling) - (list unsigned-int '*))) - -(define-public (bernoulli-true-volume p r0 r1 dimension) - ((true-volume-procedure "bernoulli_true_volume") - dimension (make-bernoulli-params p r0 r1))) - -(define (make-uniform-params a b) - (make-c-struct (list double double) - (list a b))) - -(define-public (make-uniform-oracle a b) - (make-extent-oracle (dynamic-func "uniform_extent_oracle" lib-extentsampling) - (make-uniform-params a b))) - -(define-public (uniform-true-volume a b dimension) - ((true-volume-procedure "uniform_true_volume") - dimension (make-uniform-params a b))) - -(define (make-beta-params alpha beta) - (make-c-struct (list double double) - (list alpha beta))) - -(define-public (make-beta-oracle alpha beta) - (make-extent-oracle (dynamic-func "beta_extent_oracle" lib-extentsampling) - (make-beta-params alpha beta))) - -(define-public (beta-true-volume alpha beta dimension) - ((true-volume-procedure "beta_true_volume") - dimension (make-beta-params alpha beta))) - -(define (make-cube-params edge) - (make-c-struct (list double) (list edge))) - -(define-public (make-cube-oracle edge) - (make-extent-oracle (dynamic-func "cube_extent_oracle" lib-extentsampling) - (make-cube-params edge))) - -(define-public (cube-true-volume edge dimension) - ((true-volume-procedure "cube_true_volume") - dimension (make-cube-params edge))) - -(define (make-spheroid-params eccentricity) - (make-c-struct (list double) (list eccentricity))) - -(define-public (make-spheroid-oracle eccentricity) - (make-extent-oracle (dynamic-func "spheroid_extent_oracle" lib-extentsampling) - (make-spheroid-params eccentricity))) - -(define-public (spheroid-true-volume eccentricity dimension) - ((true-volume-procedure "spheroid_true_volume") - dimension (make-spheroid-params eccentricity))) - -;; integrands - -(define (make-integrand integrand params) - (make-c-struct (list '* '*) - (list integrand params))) - -(define-public (make-polynomial-integrand polynomial) - (make-integrand (dynamic-func "polynomial_integrand" lib-extentsampling) - (make-c-struct (list '* int) - (list (bytevector->pointer - (list->typed-array 'f64 1 polynomial)) - (1- (length polynomial)))))) - -(define-public gaussian-integrand - (make-integrand (dynamic-func "gaussian_integrand" lib-extentsampling) - %null-pointer)) - -(define-public x-coordinate-integrand - (make-integrand (dynamic-func "x_coordinate_integrand" lib-extentsampling) - %null-pointer)) - -;; extent-sampling - -(define maybe-procedure->extent-oracle - (match-lambda - ((? procedure? proc) - (make-extent-oracle - (procedure->pointer double - (lambda (r x params) - (proc r x)) - (list '* '* '*)) - %null-pointer)) - (extent-oracle extent-oracle))) - -(define maybe-procedure->integrand - (match-lambda - ((? procedure? integrand) - (make-integrand - (procedure->pointer double - (lambda (r x params) - (integrand r x)) - (list double '* '*)) - %null-pointer)) - (integrand integrand))) - -(define-public (volume extent-oracle true-volume dimension rtol) - (let ((stats (rstat-alloc))) - ((pointer->procedure double - (dynamic-func "volume" lib-extentsampling) - (list '* double '* unsigned-int double '*)) - (maybe-procedure->extent-oracle extent-oracle) - true-volume %gsl-random-state dimension rtol stats) - (rstat-n stats))) - -(define-public (volume-window extent-oracle true-volume dimension rtol) - (let ((samples (make-c-struct (list unsigned-int) (list 0)))) - ((pointer->procedure double - (dynamic-func "volume_window" lib-extentsampling) - (list '* double '* unsigned-int double '*)) - (maybe-procedure->extent-oracle extent-oracle) - true-volume %gsl-random-state dimension rtol samples) - (match (parse-c-struct samples (list unsigned-int)) - ((samples) samples)))) - -(define-public (integral integrand extent-oracle true-integral dimension rtol) - (let ((stats (rstat-alloc))) - ((pointer->procedure double - (dynamic-func "integral" lib-extentsampling) - (list '* '* double '* unsigned-int double '*)) - (maybe-procedure->integrand integrand) - (maybe-procedure->extent-oracle extent-oracle) - true-integral %gsl-random-state dimension rtol stats) - (rstat-n stats))) diff --git a/scm/nsmc/load-libs.scm.in b/scm/nsmc/load-libs.scm.in new file mode 100644 index 0000000..cd2fbe3 --- /dev/null +++ b/scm/nsmc/load-libs.scm.in @@ -0,0 +1,13 @@ +(define lib-nsmc + (catch #t + (lambda () + (dynamic-link "@CMAKE_INSTALL_FULL_LIBDIR@/libnsmc")) + (lambda _ + (dynamic-link "libnsmc")))) + +(define lib-gsl + (catch #t + (lambda () + (dynamic-link "@GSL_LIBRARY@")) + (lambda _ + (dynamic-link "libgsl")))) diff --git a/scm/nsmc/wrap.scm b/scm/nsmc/wrap.scm new file mode 100644 index 0000000..e6d9a47 --- /dev/null +++ b/scm/nsmc/wrap.scm @@ -0,0 +1,365 @@ +(define-module (nsmc wrap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (system foreign)) + +(include "load-libs.scm") + +(define (make-gsl-alloc allocator-name allocator-args freer-name) + (lambda args + (let ((obj + (apply (pointer->procedure + '* (dynamic-func allocator-name lib-gsl) allocator-args) + args))) + (set-pointer-finalizer! obj (dynamic-func freer-name lib-gsl)) + obj))) + +(define-public pi + ((pointer->procedure double + (dynamic-func "pi" lib-nsmc) + (list)))) + +(define-public volume-of-ball + (pointer->procedure double + (dynamic-func "volume_of_ball" lib-nsmc) + (list int))) + +(define-public surface-area-of-ball + (pointer->procedure double + (dynamic-func "surface_area_of_ball" lib-nsmc) + (list int))) + +(define-public (lower-incomplete-gamma s x) + (* ((pointer->procedure double + (dynamic-func "gsl_sf_gamma" lib-gsl) + (list double)) + s) + ((pointer->procedure double + (dynamic-func "gsl_sf_gamma_inc_P" lib-gsl) + (list double double)) + s x))) + +(define-public angle-between-vectors + (pointer->procedure double + (dynamic-func "angle_between_vectors" lib-nsmc) + (list '* '*))) + +(define-public planar-angle->solid-angle + (pointer->procedure double + (dynamic-func "planar_angle_to_solid_angle" lib-nsmc) + (list double int))) + +;; Random state + +(define %gsl-random-state + ((make-gsl-alloc "gsl_rng_alloc" (list '*) "gsl_rng_free") + (dereference-pointer + (dynamic-pointer "gsl_rng_default" lib-gsl)))) + +(define-public (set-gsl-random-state! seed) + ((pointer->procedure void + (dynamic-func "gsl_rng_set" lib-gsl) + (list '* unsigned-long)) + %gsl-random-state seed)) + +(define-public random-flat + (cut (pointer->procedure double + (dynamic-func "gsl_ran_flat" lib-gsl) + (list '* double double)) + %gsl-random-state <> <>)) + +;; Vector functions + +(define vector-alloc + (make-gsl-alloc "gsl_vector_alloc" (list int) "gsl_vector_free")) + +(define-public (vector-size vector) + (match (parse-c-struct vector + (list size_t size_t '* '* int)) + ((size _ _ _ _) size))) + +(define-public (vector-scale! vector k) + "Scale VECTOR by a factor K." + ((pointer->procedure int + (dynamic-func "gsl_vector_scale" lib-gsl) + (list '* double)) + vector k) + vector) + +(define-public (vector-norm2 vector) + ((pointer->procedure double + (dynamic-func "gsl_blas_dnrm2" lib-gsl) + (list '*)) + vector)) + +(define-public (vector-add! u v) + "Return the vector sum of vectors U and V. The sum is stored in U." + ((pointer->procedure int + (dynamic-func "gsl_vector_add" lib-gsl) + (list '* '*)) + u v) + u) + +(define-public (basis n dimension) + "Return the basis vector in the Nth canonical direction." + (let ((vector (vector-alloc dimension))) + ((pointer->procedure void + (dynamic-func "gsl_vector_set_basis" lib-gsl) + (list '* int)) + vector n) + vector)) + +;; Histogram functions + +(define histogram-struct + (list size_t '* '*)) + +(define (histogram-alloc bins min max) + (let ((histogram + ((make-gsl-alloc "gsl_histogram_alloc" (list size_t) "gsl_histogram_free") + bins))) + ((pointer->procedure int + (dynamic-func "gsl_histogram_set_ranges_uniform" lib-gsl) + (list '* double double)) + histogram min max) + histogram)) + +(define-public (histogram->points histogram) + (match (parse-c-struct histogram histogram-struct) + ((n range bin) + (let ((range (array->list (pointer->bytevector range (1+ n) 0 'f64)))) + (map cons + (drop-right range 1) + (array->list (pointer->bytevector bin n 0 'f64))))))) + +(define-public (histogram->pdf histogram) + (match (parse-c-struct histogram histogram-struct) + ((n range bin) + (let ((range (pointer->bytevector range (1+ n) 0 'f64))) + ((pointer->procedure int + (dynamic-func "gsl_histogram_scale" lib-nsmc) + (list '* double)) + histogram + (/ n + (- (array-ref range n) + (array-ref range 0)) + (fold + 0 (array->list (pointer->bytevector bin n 0 'f64))))) + histogram)))) + +(define-public (rhistogram bins min max) + (case-lambda + (() (histogram-alloc bins min max)) + ((histogram) histogram) + ((histogram input) + ((pointer->procedure int + (dynamic-func "gsl_histogram_increment" lib-nsmc) + (list '* double)) + histogram input) + histogram))) + +;; Running statistics + +(define rstat-alloc + (make-gsl-alloc "gsl_rstat_alloc" (list) "gsl_rstat_free")) + +(define-public rstat-n + (pointer->procedure size_t + (dynamic-func "gsl_rstat_n" lib-nsmc) + (list '*))) + +;; Polynomial functions + +(define-public (polyval coefficients x) + ((pointer->procedure double + (dynamic-func "gsl_poly_eval" lib-gsl) + (list '* int double)) + (bytevector->pointer (list->typed-array 'f64 1 coefficients)) + (length coefficients) + x)) + +;; nd-random + +(define-public (random-direction-vector dimension) + (let ((vector (vector-alloc dimension))) + ((pointer->procedure void + (dynamic-func "random_direction_vector" lib-nsmc) + (list '* '*)) + %gsl-random-state vector) + vector)) + +(define-public (subsampling-random-vector mean max-theta) + (let ((vector (vector-alloc (vector-size mean)))) + ((pointer->procedure void + (dynamic-func "subsampling_random_vector" lib-nsmc) + (list '* '* double '*)) + %gsl-random-state mean max-theta vector) + vector)) + +(define-public (shifted-gaussian-random-vector mean max-theta standard-deviation) + (let* ((vector (vector-alloc (vector-size mean))) + (cost + ((pointer->procedure int + (dynamic-func "shifted_gaussian_random_vector" lib-nsmc) + (list '* '* double double '*)) + %gsl-random-state mean max-theta standard-deviation vector))) + vector)) + +(define-public (shifted-gaussian-random-vector-cost mean max-theta standard-deviation) + ((pointer->procedure int + (dynamic-func "shifted_gaussian_random_vector" lib-nsmc) + (list '* '* double double '*)) + %gsl-random-state mean max-theta standard-deviation (vector-alloc (vector-size mean)))) + +(define %integration-workspace + ((make-gsl-alloc "gsl_integration_workspace_alloc" (list size_t) "gsl_integration_workspace_free") + 1000)) + +(define-public (shifted-gaussian-pdf theta mean max-theta standard-deviation) + ((pointer->procedure double + (dynamic-func "shifted_gaussian_pdf" lib-nsmc) + (list double double double double unsigned-int '*)) + theta (vector-norm2 mean) max-theta standard-deviation (vector-size mean) %integration-workspace)) + +;; oracles + +(define (make-extent-oracle oracle params) + (make-c-struct (list '* '*) + (list oracle params))) + +(define (make-bernoulli-params p r0 r1) + (make-c-struct (list double double double) + (list p r0 r1))) + +(define-public (make-bernoulli-oracle p r0 r1) + (make-extent-oracle (dynamic-func "bernoulli_extent_oracle" lib-nsmc) + (make-bernoulli-params p r0 r1))) + +(define (true-volume-procedure name) + (pointer->procedure double + (dynamic-func name lib-nsmc) + (list unsigned-int '*))) + +(define-public (bernoulli-true-volume p r0 r1 dimension) + ((true-volume-procedure "bernoulli_true_volume") + dimension (make-bernoulli-params p r0 r1))) + +(define (make-uniform-params a b) + (make-c-struct (list double double) + (list a b))) + +(define-public (make-uniform-oracle a b) + (make-extent-oracle (dynamic-func "uniform_extent_oracle" lib-nsmc) + (make-uniform-params a b))) + +(define-public (uniform-true-volume a b dimension) + ((true-volume-procedure "uniform_true_volume") + dimension (make-uniform-params a b))) + +(define (make-beta-params alpha beta) + (make-c-struct (list double double) + (list alpha beta))) + +(define-public (make-beta-oracle alpha beta) + (make-extent-oracle (dynamic-func "beta_extent_oracle" lib-nsmc) + (make-beta-params alpha beta))) + +(define-public (beta-true-volume alpha beta dimension) + ((true-volume-procedure "beta_true_volume") + dimension (make-beta-params alpha beta))) + +(define (make-cube-params edge) + (make-c-struct (list double) (list edge))) + +(define-public (make-cube-oracle edge) + (make-extent-oracle (dynamic-func "cube_extent_oracle" lib-nsmc) + (make-cube-params edge))) + +(define-public (cube-true-volume edge dimension) + ((true-volume-procedure "cube_true_volume") + dimension (make-cube-params edge))) + +(define (make-spheroid-params eccentricity) + (make-c-struct (list double) (list eccentricity))) + +(define-public (make-spheroid-oracle eccentricity) + (make-extent-oracle (dynamic-func "spheroid_extent_oracle" lib-nsmc) + (make-spheroid-params eccentricity))) + +(define-public (spheroid-true-volume eccentricity dimension) + ((true-volume-procedure "spheroid_true_volume") + dimension (make-spheroid-params eccentricity))) + +;; integrands + +(define (make-integrand integrand params) + (make-c-struct (list '* '*) + (list integrand params))) + +(define-public (make-polynomial-integrand polynomial) + (make-integrand (dynamic-func "polynomial_integrand" lib-nsmc) + (make-c-struct (list '* int) + (list (bytevector->pointer + (list->typed-array 'f64 1 polynomial)) + (1- (length polynomial)))))) + +(define-public gaussian-integrand + (make-integrand (dynamic-func "gaussian_integrand" lib-nsmc) + %null-pointer)) + +(define-public x-coordinate-integrand + (make-integrand (dynamic-func "x_coordinate_integrand" lib-nsmc) + %null-pointer)) + +;; extent-sampling + +(define maybe-procedure->extent-oracle + (match-lambda + ((? procedure? proc) + (make-extent-oracle + (procedure->pointer double + (lambda (r x params) + (proc r x)) + (list '* '* '*)) + %null-pointer)) + (extent-oracle extent-oracle))) + +(define maybe-procedure->integrand + (match-lambda + ((? procedure? integrand) + (make-integrand + (procedure->pointer double + (lambda (r x params) + (integrand r x)) + (list double '* '*)) + %null-pointer)) + (integrand integrand))) + +(define-public (volume extent-oracle true-volume dimension rtol) + (let ((stats (rstat-alloc))) + ((pointer->procedure double + (dynamic-func "volume" lib-nsmc) + (list '* double '* unsigned-int double '*)) + (maybe-procedure->extent-oracle extent-oracle) + true-volume %gsl-random-state dimension rtol stats) + (rstat-n stats))) + +(define-public (volume-window extent-oracle true-volume dimension rtol) + (let ((samples (make-c-struct (list unsigned-int) (list 0)))) + ((pointer->procedure double + (dynamic-func "volume_window" lib-nsmc) + (list '* double '* unsigned-int double '*)) + (maybe-procedure->extent-oracle extent-oracle) + true-volume %gsl-random-state dimension rtol samples) + (match (parse-c-struct samples (list unsigned-int)) + ((samples) samples)))) + +(define-public (integral integrand extent-oracle true-integral dimension rtol) + (let ((stats (rstat-alloc))) + ((pointer->procedure double + (dynamic-func "integral" lib-nsmc) + (list '* '* double '* unsigned-int double '*)) + (maybe-procedure->integrand integrand) + (maybe-procedure->extent-oracle extent-oracle) + true-integral %gsl-random-state dimension rtol stats) + (rstat-n stats))) -- cgit v1.2.3