diff options
| -rw-r--r-- | CMakeLists.txt | 32 | ||||
| -rw-r--r-- | scm/extent-sampling/load-libs.scm.in | 13 | ||||
| -rw-r--r-- | scm/extent-sampling/wrap.scm | 192 |
3 files changed, 237 insertions, 0 deletions
diff --git a/CMakeLists.txt b/CMakeLists.txt index 935c3b3..beae2ff 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -4,6 +4,15 @@ project(extent-sampling VERSION 0.1.0) find_package(GSL REQUIRED) find_program(SC NAMES sc REQUIRED) find_program(INDENT NAMES indent) +# TODO: Maybe, support other versions of guile such as 2.2. +pkg_check_modules(GUILE guile-3.0) +pkg_get_variable(GUILD guile-3.0 guild) + +function(change_extension var filename extension) + get_filename_component(basename ${filename} NAME_WE) + get_filename_component(dirname ${filename} DIRECTORY) + set(${var} ${dirname}/${basename}.${extension} PARENT_SCOPE) +endfunction() # Generate C source files from SC source files, and optionally indent # them. @@ -37,3 +46,26 @@ set_target_properties(extentsampling PROPERTIES PUBLIC_HEADER "include/extent-sampling.h;include/gaussian-nd-random.h;include/nd-random.h;include/oracles.h") install(TARGETS extentsampling LIBRARY PUBLIC_HEADER DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}/extent-sampling) + +# Build and install scheme wrapper. +if(${GUILE_FOUND}) + configure_file(scm/extent-sampling/load-libs.scm.in scm/extent-sampling/load-libs.scm) + set(SCM_WRAPPER_PATH scm/extent-sampling/wrap.scm) + change_extension(SCM_WRAPPER_GO_PATH ${SCM_WRAPPER_PATH} go) + add_custom_command( + OUTPUT ${SCM_WRAPPER_GO_PATH} + COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/${SCM_WRAPPER_PATH} ${CMAKE_BINARY_DIR}/${SCM_WRAPPER_PATH} + COMMAND ${GUILD} compile ${CMAKE_BINARY_DIR}/${SCM_WRAPPER_PATH} -o ${CMAKE_BINARY_DIR}/${SCM_WRAPPER_GO_PATH} + DEPENDS ${SCM_WRAPPER_PATH} + VERBATIM) + add_custom_target(scheme ALL DEPENDS ${SCM_WRAPPER_GO_PATH}) + string(REPLACE "." ";" GUILE_VERSION_LIST ${GUILE_VERSION}) + list(GET GUILE_VERSION_LIST 0 GUILE_MAJOR_VERSION) + list(GET GUILE_VERSION_LIST 1 GUILE_MINOR_VERSION) + install(FILES ${CMAKE_BINARY_DIR}/scm/extent-sampling/load-libs.scm + DESTINATION ${CMAKE_INSTALL_DATADIR}/guile/site/${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}/extent-sampling) + install(FILES ${CMAKE_BINARY_DIR}/${SCM_WRAPPER_PATH} + DESTINATION ${CMAKE_INSTALL_DATADIR}/guile/site/${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}/extent-sampling) + install(FILES ${CMAKE_BINARY_DIR}/${SCM_WRAPPER_GO_PATH} + DESTINATION ${CMAKE_INSTALL_LIBDIR}/guile/site/${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}/site-ccache/extent-sampling) +endif() diff --git a/scm/extent-sampling/load-libs.scm.in b/scm/extent-sampling/load-libs.scm.in new file mode 100644 index 0000000..1b99e53 --- /dev/null +++ b/scm/extent-sampling/load-libs.scm.in @@ -0,0 +1,13 @@ +(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 new file mode 100644 index 0000000..180ac91 --- /dev/null +++ b/scm/extent-sampling/wrap.scm @@ -0,0 +1,192 @@ +(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 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))) + +;; 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)) |