1 ;;;; kclglue -- Interface to C library
3 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
6 (in-package 'lisp-stat-basics
)
8 (eval-when (compile load eval
)
11 #'(lambda (stream char
) (values (read-line stream
)))))
15 %
#include
"lib/linalg.h"
16 %extern double rcondest_front
();
17 %extern char
*calloc
();
21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;;; Storage Allocation Functions
33 (defun null-ptr-p (p) (= p 0))
34 (defun ptr-eq (p q) (= p q))
37 %int la_base_allocate(n, m)
40 % char *p = calloc(n, m);
41 % if (p == nil) xlfail("allocation failed");
46 (defentry la-base-allocate (int int) (int "la_base_allocate"))
49 %int la_base_free_alloc(p)
52 % if (p) free((char *) p);
57 (defentry la-base-free (int) (int "la_base_free_alloc"))
60 %static int mode_size(mode)
64 % case IN: return(sizeof(int));
65 % case RE: return(sizeof(double));
66 % case CX: return(sizeof(Complex));
72 (defentry la-mode-size (int) (int "mode_size"))
74 (defCfun "int la_allocate(n, m) int n, m;" 0
77 ((la-allocate (int "n") (int "m")) (int "p"))
82 (defCfun "la_free_alloc(p) int p;" 0
88 (defentry al (int int) (int "la_allocate"))
89 (defentry fr (int) (int "la_free_alloc"))
92 ;;;; Storage Access Functions
96 %static int get_integer(p, i)
99 % return(*(((int *) p) + i));
103 (defentry la-get-integer (int int) (int "get_integer"))
106 %static double get_double(p, i)
109 % return(*(((double *) p) + i));
113 (defentry la-get-double (int int) (double "get_double"))
116 %static double get_complex_real(p, i)
119 % Complex *c = ((Complex *) p) + i;
124 (defentry la-get-complex-real (int int) (double "get_complex_real"))
127 %static double get_complex_imag(p, i)
130 % Complex *c = ((Complex *) p) + i;
135 (defentry la-get-complex-imag (int int) (double "get_complex_imag"))
137 (defun la-get-complex (p i)
138 (complex (la-get-complex-real p i) (la-get-complex-imag p i)))
140 (defun la-get-pointer (p i) (la-get-integer p i))
143 ;;;; Storage Mutation Functions
147 %static int put_integer(p, i, x)
150 % *(((int *) p) + i) = x;
155 (defentry la-put-integer (int int int) (int "put_integer"))
158 %static int put_double(p, i, x)
162 % *(((double *) p) + i) = x;
167 (defentry la-put-double (int int double) (int "put_double"))
170 %static int put_complex(p, i, x, y)
174 % Complex *c = ((Complex *) p) + i;
181 (defentry la-put-complex (int int double double) (int "put_complex"))
183 (defun la-put-pointer (p i x) (la-put-integer p i x))
186 ;;;; XLISP internal error message emulation
189 (defvar *buf* (make-string 1000))
191 (defun set-buf-char (i c) (setf (elt *buf* i) (code-char c)))
193 (defun get-buf (&optional (n (position (code-char 0) *buf*)))
197 %static int bufpos = 0;
199 %static resetbuf() { bufpos = 0; }
203 (defCfun "static prbuf(s) char *s;" 0
209 % for (i = 0; i <n; i++, bufpos++) {
210 (set-buf-char (int "bufpos") (int "(int) s[i]"))
212 (set-buf-char (int "bufpos") (int "(int) 0"))
216 (defCfun "xlfail(s) char *s;" 0
222 ((get-buf (int "bufpos")) "buf")
227 (defCfun "stdputstr(s) char *s;" 0
233 ((get-buf (int "bufpos")) "buf")
249 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
252 ;;;; Lisp Interfaces to Linear Algebra Routines
254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
255 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
258 ;;;; Cholesky Decomposition
261 (defentry chol-decomp-front (int int int) (int "chol_decomp_front"))
264 ;;;; LU Decomposition
267 (defentry lu-decomp-front (int int int int int) (int "lu_decomp_front"))
268 (defentry lu-solve-front (int int int int int) (int "lu_solve_front"))
269 (defentry lu-inverse-front (int int int int int int) (int "lu_inverse_front"))
272 ;;;; SV Decomposition
275 (defentry sv-decomp-front (int int int int int) (int "sv_decomp_front"))
278 ;;;; QR Decomposition
281 (defentry qr-decomp-front (int int int int int int) (int "qr_decomp_front"))
284 ;;;; Estimate of Condition Number for Lower Triangular Matrix
287 (defentry rcondest-front (int int) (double "rcondest_front"))
290 ;;;; Make Rotation Matrix
293 (defentry make-rotation-front
294 (int int int int int double)
295 (int "make_rotation_front"))
298 ;;;; Eigenvalues and Eigenvectors
301 (defentry eigen-front (int int int int int) (int "eigen_front"))
304 ;;;; Spline Interpolation
307 (defentry la-range-to-rseq (int int int int) (int "range_to_rseq"))
308 (defentry spline-front (int int int int int int int) (int "spline_front"))
311 ;;;; Kernel Density Estimators and Smoothers
314 (defentry kernel-dens-front
315 (int int double int int int int)
316 (int "kernel_dens_front"))
318 (defentry kernel-smooth-front
319 (int int int double int int int int)
320 (int "kernel_smooth_front"))
323 ;;;; Lowess Smoother Interface
326 (defentry base-lowess-front
327 (int int int double int double int int int)
328 (int "base_lowess_front"))
334 (defentry fft-front (int int int int) (int "fft_front"))
337 ;;;; Maximization and Numerical Derivatives
340 (defCfun "maximize_callback(n, px, pfval, pgrad, phess, pderivs)
341 int n, pderivs, px, pfval, pgrad, phess;" 0
343 (maximize-callback (int "n")
352 (defentry numgrad-front (int int int double int) (int "numgrad_front"))
353 (defentry numhess-front (int int int int int double int) (int "numhess_front"))
354 (defentry base-minfo-maximize (int int int int int int) (int "minfo_maximize"))
356 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
357 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
359 ;;;; Probability Distributions
361 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
365 % extern double unirand(), gamma();
366 % extern double normalcdf(), normalquant(), normaldens(), normalrand();
367 % extern double bnormcdf();
368 % extern double cauchycdf(), cauchyquant(), cauchydens(), cauchyrand();
369 % extern double gammacdf(), gammaquant(), gammadens(), gammarand();
370 % extern double chisqcdf(), chisqquant(), chisqdens(), chisqrand();
371 % extern double betacdf(), betaquant(), betadens(), betarand();
372 % extern double tcdf(), tquant(), tdens(), trand();
373 % extern double fcdf(), fquant(), fdens(), frand();
374 % extern double poissoncdf(), poissonpmf();
375 % extern int poissonquant(), poissonrand();
376 % extern double binomialcdf(), binomialpmf();
377 % extern int binomialquant(), binomialrand();
380 (defCfun "double uni()" 0
383 ((random (double "1.0")) (double "x"))
388 (defentry one-uniform-rand () (double "unirand"))
389 (defentry base-log-gamma (double) (double "gamma"))
391 (defentry base-normal-cdf (double) (double "normalcdf"))
392 (defentry base-normal-quant (double) (double "normalquant"))
393 (defentry base-normal-dens (double) (double "normaldens"))
394 (defentry one-normal-rand () (double "normalrand"))
395 (defentry base-bivnorm-cdf (double double double) (double "bnormcdf"))
397 (defentry base-cauchy-cdf (double) (double "cauchycdf"))
398 (defentry base-cauchy-quant (double) (double "cauchyquant"))
399 (defentry base-cauchy-dens (double) (double "cauchydens"))
400 (defentry one-cauchy-rand () (double "cauchyrand"))
402 (defentry base-gamma-cdf (double double) (double "gammacdf"))
403 (defentry base-gamma-quant (double double) (double "gammaquant"))
404 (defentry base-gamma-dens (double double) (double "gammadens"))
405 (defentry one-gamma-rand (double) (double "gammarand"))
407 (defentry base-chisq-cdf (double double) (double "chisqcdf"))
408 (defentry base-chisq-quant (double double) (double "chisqquant"))
409 (defentry base-chisq-dens (double double) (double "chisqdens"))
410 (defentry one-chisq-rand (double) (double "chisqrand"))
412 (defentry base-beta-cdf (double double double) (double "betacdf"))
413 (defentry base-beta-quant (double double double) (double "betaquant"))
414 (defentry base-beta-dens (double double double) (double "betadens"))
415 (defentry one-beta-rand (double double) (double "betarand"))
417 (defentry base-t-cdf (double double) (double "tcdf"))
418 (defentry base-t-quant (double double) (double "tquant"))
419 (defentry base-t-dens (double double) (double "tdens"))
420 (defentry one-t-rand (double) (double "trand"))
422 (defentry base-f-cdf (double double double) (double "fcdf"))
423 (defentry base-f-quant (double double double) (double "fquant"))
424 (defentry base-f-dens (double double double) (double "fdens"))
425 (defentry one-f-rand (double double) (double "frand"))
427 (defentry base-poisson-cdf (double double) (double "poissoncdf"))
428 (defentry base-poisson-quant (double double) (int "poissonquant"))
429 (defentry base-poisson-pmf (int double) (double "poissonpmf"))
430 (defentry one-poisson-rand (double) (int "poissonrand"))
432 (defentry base-binomial-cdf (double int double) (double "binomialcdf"))
433 (defentry base-binomial-quant (double int double) (int "binomialquant"))
434 (defentry base-binomial-pmf (int int double) (double "binomialpmf"))
435 (defentry one-binomial-rand (int double) (int "binomialrand"))