diff options
| -rw-r--r-- | scm/extent-sampling/wrap.scm | 70 |
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))) + |