3 ;;;; cffiglue -- Interface to C library
5 ;;;; Copyright (c) 1991, by Luke Tierney.
6 ;;;; Copyright (c) 2007, by Carlos Ungil.
7 ;;;; Permission is granted for unrestricted use.
9 ;;;; Tested (but the results have not been checked):
10 ;;;; Probability Distributions
11 ;;;; Internal Error Message Emulation
12 ;;;; Matrix Manipulation
15 ;;;; numgrad numhess minfo-maximize
17 (in-package :lisp-stat-basics
)
19 (cffi:load-foreign-library
21 (namestring cl-user
::*lispstat-home-dir
*)
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;;;; Callback Support Functions
30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 (cffi:defcfun
("ccl_store_integer" ccl-store-integer
)
34 (cffi:defcfun
("ccl_store_double" ccl-store-double
)
36 (cffi:defcfun
("ccl_store_ptr" ccl-store-ptr
)
40 ;;;; Lisp-Managed Calloc/Free
43 ;;;; this section is commented out in mclglue.lsp
44 ;;;; and the relevant fragment in cffi-glue.c is not compiled (ifdef DODO)
47 ;;;; Storage Allocation Functions
51 (defun null-ptr-p (p) (cffi:null-pointer-p p
))
52 (defun ptr-eq (p q
) (cffi:pointer-eq p q
))
55 (cffi:defcfun
("la_base_allocate" ccl-la-base-allocate
)
56 :pointer
(n :int
) (m :int
))
57 (defun la-base-allocate (n m
)
58 (ccl-la-base-allocate n m
))
60 (cffi:defcfun
("la_base_free_alloc" ccl-la-base-free-alloc
)
62 (defun la-base-free (p)
63 (ccl-la-base-free-alloc p
))
65 (cffi:defcfun
("la_mode_size" ccl-la-mode-size
)
68 (defun la-mode-size (mode)
69 (ccl-la-mode-size mode
))
72 ;;;; Callbacks for Internal Storage
75 (cffi:defcallback lisp-la-allocate
:void
((n :long
) (m :long
))
76 (ccl-store-ptr (la-allocate n m
)))
77 (cffi:defcfun
("register_la_allocate" register-la-allocate
)
79 (register-la-allocate (cffi:callback lisp-la-allocate
))
80 (cffi:defcfun
("la_allocate" la
)
81 :pointer
(x :int
) (y :int
))
83 (cffi:defcallback lisp-la-free-alloc
:void
((p :pointer
))
85 (cffi:defcfun
("register_la_free_alloc" register-la-free-alloc
)
87 (register-la-free-alloc (cffi:callback lisp-la-free-alloc
))
88 (cffi:defcfun
("la_free_alloc" lf
)
92 ;;;; Storage Access Functions
95 (cffi:defcfun
("la_get_integer" ccl-la-get-integer
)
96 :int
(p :pointer
) (i :int
))
97 (defun la-get-integer (p i
)
98 (ccl-la-get-integer p i
))
100 (cffi:defcfun
("la_get_double" ccl-la-get-double
)
101 :double
(p :pointer
) (i :int
))
102 (defun la-get-double (p i
)
103 (ccl-la-get-double p i
))
105 (cffi:defcfun
("la_get_complex_real" ccl-la-get-complex-real
)
106 :double
(p :pointer
) (i :int
))
107 (defun la-get-complex-real (p i
)
108 (ccl-la-get-complex-real p i
))
110 (cffi:defcfun
("la_get_complex_imag" ccl-la-get-complex-imag
)
111 :double
(p :pointer
) (i :int
))
112 (defun la-get-complex-imag (p i
)
113 (ccl-la-get-complex-imag p i
))
115 (defun la-get-complex (p i
)
116 (complex (la-get-complex-real p i
) (la-get-complex-imag p i
)))
118 (cffi:defcfun
("la_get_pointer" ccl-la-get-pointer
)
119 :pointer
(p :pointer
) (i :int
))
120 (defun la-get-pointer (p i
)
121 (ccl-la-get-pointer p i
))
124 ;;;; Storage Mutation Functions
127 (cffi:defcfun
("la_put_integer" ccl-la-put-integer
)
128 :void
(p :pointer
) (i :int
) (x :int
))
129 (defun la-put-integer (p i x
)
130 (ccl-la-put-integer p i x
))
132 (cffi:defcfun
("la_put_double" ccl-la-put-double
)
133 :void
(p :pointer
) (i :int
) (x :double
))
134 (defun la-put-double (p i x
)
135 (ccl-la-put-double p i
(float x
1d0
)))
137 (cffi:defcfun
("la_put_complex" ccl-la-put-complex
)
138 :void
(p :pointer
) (i :int
) (x :double
) (y :double
))
139 (defun la-put-complex (p i x y
)
140 (ccl-la-put-complex p i
(float x
1d0
) (float y
1d0
)))
142 (cffi:defcfun
("la_put_pointer" ccl-la-put-pointer
)
143 :void
(p :pointer
) (i :int
) (q :pointer
))
144 (defun la-put-pointer (p i q
)
145 (ccl-la-put-pointer p i q
))
147 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
149 ;;;; XLISP Internal Error Message Emulation
151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153 (defvar *buf
* (make-string 1000))
155 (defun set-buf-char (i c
) (setf (elt *buf
* i
) (code-char c
)))
157 (defun get-buf (&optional
(n (position (code-char 0) *buf
*)))
160 (cffi:defcfun
("register_set_buf_char" register-set-buf-char
)
162 (cffi:defcallback ccl-set-buf-char
:void
((n :int
) (c :int
))
164 (register-set-buf-char (cffi:callback ccl-set-buf-char
))
166 (cffi:defcfun
("register_print_buffer" register-print-buffer
)
168 (cffi:defcallback ccl-print-buffer
:void
((n :int
) (type :int
))
170 (0 (princ (get-buf n
)))
171 (1 (error (get-buf n
))))
173 (register-print-buffer (cffi:callback ccl-print-buffer
))
175 (cffi:defcfun
("stdputstr" stdputstr
)
176 :void
(string :string
))
177 (cffi:defcfun
("xlfail" xlfail
)
178 :void
(string :string
))
180 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
182 ;;; Lisp Interfaces to Linear Algebra Routines
184 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
187 ;;; Cholesky Decomposition
190 (cffi:defcfun
("ccl_chol_decomp_front" ccl-chol-decomp-front
)
191 :int
(x :pointer
) (y :int
) (z :pointer
))
192 (defun chol-decomp-front (x y z
)
193 (ccl-chol-decomp-front x y z
))
196 ;;;; LU Decomposition
199 (cffi:defcfun
("ccl_lu_decomp_front" ccl-lu-decomp-front
)
200 :int
(x :pointer
) (y :int
) (z :pointer
) (u :int
) (v :pointer
))
201 (defun lu-decomp-front (x y z u v
)
202 (ccl-lu-decomp-front x y z u v
))
204 (cffi:defcfun
("ccl_lu_solve_front" ccl-lu-solve-front
)
205 :int
(x :pointer
) (y :int
) (z :pointer
) (u :pointer
) (v :int
))
206 (defun lu-solve-front (x y z u v
)
207 (ccl-lu-solve-front x y z u v
))
209 (cffi:defcfun
("ccl_lu_inverse_front" ccl-lu-inverse-front
)
210 :int
(x :pointer
) (y :int
) (z :pointer
) (u :pointer
) (v :int
) (w :pointer
))
211 (defun lu-inverse-front (x y z u v w
)
212 (ccl-lu-inverse-front x y z u v w
))
215 ;;;; SV Decomposition
218 (cffi:defcfun
("ccl_sv_decomp_front" ccl-sv-decomp-front
)
219 :int
(x :pointer
) (y :int
) (z :int
) (u :pointer
) (v :pointer
))
220 (defun sv-decomp-front (x y z u v
)
221 (ccl-sv-decomp-front x y z u v
))
224 ;;;; QR Decomposition
227 (cffi:defcfun
("ccl_qr_decomp_front" ccl-qr-decomp-front
)
228 :int
(x :pointer
) (y :int
) (z :int
) (u :pointer
) (v :pointer
) (w :int
))
229 (defun qr-decomp-front (x y z u v w
)
230 (ccl-qr-decomp-front x y z u v w
))
233 ;;;; Estimate of Condition Number for Lower Triangular Matrix
236 (cffi:defcfun
("ccl_rcondest_front" ccl-rcondest-front
)
237 :double
(x :pointer
) (y :int
))
238 (defun rcondest-front (x y
)
239 (ccl-rcondest-front x y
))
242 ;;;; Make Rotation Matrix
245 (cffi:defcfun
("ccl_make_rotation_front" ccl-make-rotation-front
)
246 :int
(x :int
) (y :pointer
) (z :pointer
) (u :pointer
) (v :int
) (w :double
))
247 (defun make-rotation-front (x y z u v w
)
248 (ccl-make-rotation-front x y z u v
(float w
1d0
)))
251 ;;;; Eigenvalues and Eigenvectors
254 (cffi:defcfun
("ccl_eigen_front" ccl-eigen-front
)
255 :int
(x :pointer
) (y :int
) (z :pointer
) (u :pointer
) (v :pointer
))
256 (defun eigen-front (x y z u v
)
257 (ccl-eigen-front x y z u v
))
260 ;;;; Spline Interpolation
263 (cffi:defcfun
("ccl_range_to_rseq" ccl-range-to-rseq
)
264 :int
(x :int
) (y :pointer
) (z :int
) (u :pointer
))
265 (defun la-range-to-rseq (x y z u
)
266 (ccl-range-to-rseq x y z u
))
268 (cffi:defcfun
("ccl_spline_front" ccl-spline-front
)
269 :int
(x :int
) (y :pointer
) (z :pointer
) (u :int
) (v :pointer
) (w :pointer
) (a :pointer
))
270 (defun spline-front (x y z u v w a
)
271 (ccl-spline-front x y z u v w a
))
274 ;;;; Kernel Density Estimators and Smoothers
277 (cffi:defcfun
("ccl_kernel_dens_front" ccl-kernel-dens-front
)
278 :int
(x :pointer
) (y :int
) (z :double
) (u :pointer
) (v :pointer
) (w :int
) (a :int
))
279 (defun kernel-dens-front (x y z u v w a
)
280 (ccl-kernel-dens-front x y
(float z
1d0
) u v w a
))
282 (cffi:defcfun
("ccl_kernel_smooth_front" ccl-kernel-smooth-front
)
283 :int
(x :pointer
) (y :pointer
) (z :int
) (u :double
) (v :pointer
) (w :pointer
) (a :int
) (b :int
))
284 (defun kernel-smooth-front (x y z u v w a b
)
285 (ccl-kernel-smooth-front x y z
(float u
1d0
) v w a b
))
288 ;;;; Lowess Smoother Interface
291 (cffi:defcfun
("ccl_base_lowess_front" ccl-base-lowess-front
)
292 :int
(x :pointer
) (y :pointer
) (z :int
) (u :double
) (v :int
) (w :double
) (a :pointer
) (b :pointer
) (c :pointer
))
293 (defun base-lowess-front (x y z u v w a b c
)
294 (ccl-base-lowess-front x y z
(float u
1d0
) v
(float w
1d0
) a b c
))
300 (cffi:defcfun
("ccl_fft_front" ccl-fft-front
)
301 :int
(x :int
) (y :pointer
) (z :pointer
) (u :int
))
302 (defun fft-front (x y z u
)
303 (ccl-fft-front x y z u
))
306 ;;;; Maximization and Numerical Derivatives
309 (cffi:defcallback ccl-maximize-callback
:void
((n :int
)
315 (lisp-stat-optimize::maximize-callback n px pfval pgrad phess pderivs
))
317 (cffi:defcfun
("register_maximize_callback" register-maximize-callback
)
319 (register-maximize-callback (cffi:callback ccl-maximize-callback
))
321 (cffi:defcfun
("ccl_numgrad_front" ccl-numgrad-front
)
322 :int
(x :int
) (y :pointer
) (z :pointer
) (u :double
) (v :pointer
))
323 (defun numgrad-front (x y z u v
)
324 (ccl-numgrad-front x y z
(float u
1d0
) v
))
326 (cffi:defcfun
("ccl_numhess_front" ccl-numhess-front
)
327 :int
(x :int
) (y :pointer
) (z :pointer
) (u :pointer
) (v :pointer
) (w :double
) (a :pointer
))
328 (defun numhess-front (x y z u v w a
)
329 (ccl-numhess-front x y z u v
(float w
1d0
) a
))
331 (cffi:defcfun
("ccl_minfo_maximize" ccl-minfo-maximize
)
332 :int
(x :pointer
) (y :pointer
) (z :pointer
) (u :pointer
) (v :pointer
) (w :int
))
333 (defun base-minfo-maximize (x y z u v w
)
334 (ccl-minfo-maximize x y z u v w
))
336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
337 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
339 ;;;; Probability Distributions
341 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
345 ;;;; C-callable uniform generator
348 (cffi:defcfun
("register_uni" register-uni
)
350 (cffi:defcallback ccl-uni
:int
() (ccl-store-double (random 1.0)) 0)
351 (register-uni (cffi:callback ccl-uni
))
353 (defun one-uniform-rand () (random 1.0))
356 ;;;; Log-gamma function
359 (cffi:defcfun
("ccl_gamma" ccl-base-log-gamma
)
361 (defun base-log-gamma (x)
362 (ccl-base-log-gamma (float x
1d0
)))
365 ;;;; Normal distribution
368 (cffi:defcfun
("ccl_normalcdf" ccl-base-normal-cdf
)
370 (defun base-normal-cdf (x)
371 (ccl-base-normal-cdf (float x
1d0
)))
373 (cffi:defcfun
("ccl_normalquant" ccl-base-normal-quant
)
375 (defun base-normal-quant (x)
376 (ccl-base-normal-quant (float x
1d0
)))
378 (cffi:defcfun
("ccl_normaldens" ccl-base-normal-dens
)
380 (defun base-normal-dens (x)
381 (ccl-base-normal-dens (float x
1d0
)))
383 (cffi:defcfun
("ccl_normalrand" one-normal-rand
)
386 (cffi:defcfun
("ccl_bnormcdf" ccl-base-bivnorm-cdf
)
387 :double
(x :double
) (y :double
) (z :double
))
388 (defun base-bivnorm-cdf (x y z
)
389 (ccl-base-bivnorm-cdf (float x
1d0
) (float y
1d0
) (float z
1d0
)))
392 ;;;; Cauchy distribution
395 (cffi:defcfun
("ccl_cauchycdf" ccl-base-cauchy-cdf
)
397 (defun base-cauchy-cdf (x)
398 (ccl-base-cauchy-cdf (float x
1d0
)))
400 (cffi:defcfun
("ccl_cauchyquant" ccl-base-cauchy-quant
)
402 (defun base-cauchy-quant (x)
403 (ccl-base-cauchy-quant (float x
1d0
)))
405 (cffi:defcfun
("ccl_cauchydens" ccl-base-cauchy-dens
)
407 (defun base-cauchy-dens (x)
408 (ccl-base-cauchy-dens (float x
1d0
)))
410 (cffi:defcfun
("ccl_cauchyrand" one-cauchy-rand
)
414 ;;;; Gamma distribution
417 (cffi:defcfun
("ccl_gammacdf" ccl-base-gamma-cdf
)
418 :double
(x :double
) (y :double
))
419 (defun base-gamma-cdf (x y
)
420 (ccl-base-gamma-cdf (float x
1d0
) (float y
1d0
)))
422 (cffi:defcfun
("ccl_gammaquant" ccl-base-gamma-quant
)
423 :double
(x :double
) (y :double
))
424 (defun base-gamma-quant (x y
)
425 (ccl-base-gamma-quant (float x
1d0
) (float y
1d0
)))
427 (cffi:defcfun
("ccl_gammadens" ccl-base-gamma-dens
)
428 :double
(x :double
) (y :double
))
429 (defun base-gamma-dens (x y
)
430 (ccl-base-gamma-dens (float x
1d0
) (float y
1d0
)))
432 (cffi:defcfun
("ccl_gammarand" ccl-gamma-rand
)
434 (defun one-gamma-rand (x)
435 (ccl-gamma-rand (float x
1d0
)))
438 ;;;; Chi-square distribution
441 (cffi:defcfun
("ccl_chisqcdf" ccl-base-chisq-cdf
)
442 :double
(x :double
) (y :double
))
443 (defun base-chisq-cdf (x y
)
444 (ccl-base-chisq-cdf (float x
1d0
) (float y
1d0
)))
446 (cffi:defcfun
("ccl_chisqquant" ccl-base-chisq-quant
)
447 :double
(x :double
) (y :double
))
448 (defun base-chisq-quant (x y
)
449 (ccl-base-chisq-quant (float x
1d0
) (float y
1d0
)))
451 (cffi:defcfun
("ccl_chisqdens" ccl-base-chisq-dens
)
452 :double
(x :double
) (y :double
))
453 (defun base-chisq-dens (x y
)
454 (ccl-base-chisq-dens (float x
1d0
) (float y
1d0
)))
456 (cffi:defcfun
("ccl_chisqrand" ccl-chisq-rand
)
458 (defun one-chisq-rand (x)
459 (ccl-chisq-rand (float x
1d0
)))
462 ;;;; Beta distribution
465 (cffi:defcfun
("ccl_betacdf" ccl-base-beta-cdf
)
466 :double
(x :double
) (y :double
) (z :double
))
467 (defun base-beta-cdf (x y z
)
468 (ccl-base-beta-cdf (float x
1d0
) (float y
1d0
) (float z
1d0
)))
470 (cffi:defcfun
("ccl_betaquant" ccl-base-beta-quant
)
471 :double
(x :double
) (y :double
) (z :double
))
472 (defun base-beta-quant (x y z
)
473 (ccl-base-beta-quant (float x
1d0
) (float y
1d0
) (float z
1d0
)))
475 (cffi:defcfun
("ccl_betadens" ccl-base-beta-dens
)
476 :double
(x :double
) (y :double
) (z :double
))
477 (defun base-beta-dens (x y z
)
478 (ccl-base-beta-dens (float x
1d0
) (float y
1d0
) (float z
1d0
)))
480 (cffi:defcfun
("ccl_betarand" ccl-beta-rand
)
481 :double
(x :double
) (y :double
))
482 (defun one-beta-rand (x y
)
483 (ccl-beta-rand (float x
1d0
) (float y
1d0
)))
489 (cffi:defcfun
("ccl_tcdf" ccl-base-t-cdf
)
490 :double
(x :double
) (y :double
))
491 (defun base-t-cdf (x y
)
492 (ccl-base-t-cdf (float x
1d0
) (float y
1d0
)))
494 (cffi:defcfun
("ccl_tquant" ccl-base-t-quant
)
495 :double
(x :double
) (y :double
))
496 (defun base-t-quant (x y
)
497 (ccl-base-t-quant (float x
1d0
) (float y
1d0
)))
499 (cffi:defcfun
("ccl_tdens" ccl-base-t-dens
)
500 :double
(x :double
) (y :double
))
501 (defun base-t-dens (x y
)
502 (ccl-base-t-dens (float x
1d0
) (float y
1d0
)))
504 (cffi:defcfun
("ccl_trand" ccl-t-rand
)
506 (defun one-t-rand (x)
507 (ccl-t-rand (float x
1d0
)))
513 (cffi:defcfun
("ccl_fcdf" ccl-base-f-cdf
)
514 :double
(x :double
) (y :double
) (z :double
))
515 (defun base-f-cdf (x y z
)
516 (ccl-base-f-cdf (float x
1d0
) (float y
1d0
) (float z
1d0
)))
518 (cffi:defcfun
("ccl_fquant" ccl-base-f-quant
)
519 :double
(x :double
) (y :double
) (z :double
))
520 (defun base-f-quant (x y z
)
521 (ccl-base-f-quant (float x
1d0
) (float y
1d0
) (float z
1d0
)))
523 (cffi:defcfun
("ccl_fdens" ccl-base-f-dens
)
524 :double
(x :double
) (y :double
) (z :double
))
525 (defun base-f-dens (x y z
)
526 (ccl-base-f-dens (float x
1d0
) (float y
1d0
) (float z
1d0
)))
528 (cffi:defcfun
("ccl_frand" ccl-f-rand
)
529 :double
(x :double
) (y :double
))
530 (defun one-f-rand (x y
) (ccl-f-rand (float x
1d0
) (float y
1d0
)))
533 ;;;; Poisson distribution
536 (cffi:defcfun
("ccl_poissoncdf" ccl-base-poisson-cdf
)
537 :double
(x :double
) (y :double
))
538 (defun base-poisson-cdf (x y
)
539 (ccl-base-poisson-cdf (float x
1d0
) (float y
1d0
)))
541 (cffi:defcfun
("ccl_poissonquant" ccl-base-poisson-quant
)
542 :int
(x :double
) (y :double
))
543 (defun base-poisson-quant (x y
)
544 (ccl-base-poisson-quant (float x
1d0
) (float y
1d0
)))
546 (cffi:defcfun
("ccl_poissonpmf" ccl-base-poisson-pmf
)
547 :double
(x :int
) (y :double
))
548 (defun base-poisson-pmf (x y
)
549 (ccl-base-poisson-pmf x
(float y
1d0
)))
551 (cffi:defcfun
("ccl_poissonrand" ccl-poisson-rand
)
553 (defun one-poisson-rand (x)
554 (ccl-poisson-rand (float x
1d0
)))
557 ;;;; Binomial distribution
560 (cffi:defcfun
("ccl_binomialcdf" ccl-base-binomial-cdf
)
561 :double
(x :double
) (y :int
) (z :double
))
562 (defun base-binomial-cdf (x y z
)
563 (ccl-base-binomial-cdf (float x
1d0
) y
(float z
1d0
)))
565 (cffi:defcfun
("ccl_binomialquant" ccl-base-binomial-quant
)
566 :int
(x :double
) (y :int
) (z :double
))
567 (defun base-binomial-quant (x y z
)
568 (ccl-base-binomial-quant (float x
1d0
) y
(float z
1d0
)))
570 (cffi:defcfun
("ccl_binomialpmf" ccl-base-binomial-pmf
)
571 :double
(x :int
) (y :int
) (z :double
))
572 (defun base-binomial-pmf (x y z
)
573 (ccl-base-binomial-pmf x y
(float z
1d0
)))
575 (cffi:defcfun
("ccl_binomialrand" ccl-binomial-rand
)
576 :int
(x :int
) (y :double
))
577 (defun one-binomial-rand (x y
)
578 (ccl-binomial-rand x
(float y
1d0
)))