Wrap extent oracles.

* scm/extent-sampling/wrap.scm (make-extent-oracle,
make-bernoulli-params, make-bernoulli-oracle, true-volume-procedure,
bernoulli-true-volume, make-uniform-params, make-uniform-oracle,
uniform-true-volume, make-beta-params, make-beta-oracle,
beta-true-volume, make-cube-params, make-cube-oracle,
cube-true-volume, make-spheroid-params, make-spheroid-oracle,
spheroid-true-volume): New functions.

1 files changed, 70 insertions, 0 deletions

diff --git a/scm/extent-sampling/wrap.scm b/scm/extent-sampling/wrap.scm
index 0e32452..e22e299 100644
--- a/scm/extent-sampling/wrap.scm
+++ b/scm/extent-sampling/wrap.scm
@@ -220,3 +220,73 @@
                        (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)))
+