aboutsummaryrefslogtreecommitdiff
path: root/scm
diff options
context:
space:
mode:
Diffstat (limited to 'scm')
-rw-r--r--scm/extent-sampling/wrap.scm70
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)))
+