1 ;;;; exclglue -- Interface to C library
3 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
6 (in-package 'lisp-stat-basics
)
10 (load "lib/exclglue.o"
11 :foreign-files
'("lib/clib.a")
12 :system-libraries
#+:mips
'("m_G0") #-
:mips
'("m"))
18 (defmacro defforfun
(name arg-types return-type
)
19 `(ff:defforeign
',name
20 :arguments
',arg-types
21 :return-type
,return-type
))
23 (defmacro mkdbl
(x) `(float ,x
0.d0
))
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 ;;;; Callback Value Storage
37 (defforfun excl_set_integer_value
(integer) :void
)
38 (defforfun excl_set_double_value
(double-float) :void
)
41 ;;;; Storage Allocation Functions
44 (defun null-ptr-p (p) (= p
0))
45 (defun ptr-eq (p q
) (= p q
))
47 (defforfun la_base_allocate
(integer integer
) :integer
)
48 (defun la-base-allocate (n m
) (la_base_allocate n m
))
50 (defforfun la_base_free_alloc
(integer) :void
)
51 (defun la-base-free (p) (la_base_free_alloc p
))
53 (defforfun la_mode_size
(integer) :integer
)
54 (defun la-mode-size (mode) (la_mode_size mode
))
57 ;;;; Callbacks for Internal Storage
60 (ff:defun-c-callable lisp_la_allocate
((n :signed-long
) (m :signed-long
))
61 (excl_set_integer_value (la-allocate n m
)))
62 (defforfun excl_register_la_allocate
(integer) :void
)
63 (multiple-value-bind (ptr index
) (ff:register-function
'lisp_la_allocate
)
64 (excl_register_la_allocate index
))
66 (ff:defun-c-callable lisp_la_free_alloc
((p :signed-long
))
68 (defforfun excl_register_la_free_alloc
(integer) :void
)
69 (multiple-value-bind (ptr index
) (ff:register-function
'lisp_la_free_alloc
)
70 (excl_register_la_free_alloc index
))
73 ;;;; Storage Access Functions
76 (defforfun la_get_integer
(integer integer
) :integer
)
77 (defun la-get-integer (p i
) (la_get_integer p i
))
79 (defforfun la_get_double
(integer integer
) :double-float
)
80 (defun la-get-double (p i
) (la_get_double p i
))
82 (defforfun la_get_complex_real
(integer integer
) :double-float
)
83 (defun la-get-complex-real (p i
) (la_get_complex_real p i
))
85 (defforfun la_get_complex_imag
(integer integer
) :double-float
)
86 (defun la-get-complex-imag (p i
) (la_get_complex_imag p i
))
88 (defun la-get-complex (p i
)
89 (complex (la-get-complex-real p i
) (la-get-complex-imag p i
)))
91 (defun la-get-pointer (p i
) (la-get-integer p i
))
94 ;;;; Storage Mutation Functions
97 (defforfun la_put_integer
(integer integer integer
) :void
)
98 (defun la-put-integer (p i x
) (la_put_integer p i x
))
100 (defforfun la_put_double
(integer integer double-float
) :void
)
101 (defun la-put-double (p i x
) (la_put_double p i
(mkdbl x
)))
103 (defforfun la_put_complex
(integer integer double-float double-float
) :void
)
104 (defun la-put-complex (p i x y
) (la_put_complex p i
(mkdbl x
) (mkdbl y
)))
106 (defun la-put-pointer (p i x
) (la-put-integer p i x
))
109 ;;;; XLISP internal error message emulation
112 (defvar *buf
* (make-string 1000))
114 (defun set-buf-char (i c
) (setf (elt *buf
* i
) (code-char c
)))
116 (defun get-buf (&optional
(n (position (code-char 0) *buf
*)))
119 (ff:defun-c-callable excl-set-buf-char
((n :signed-long
) (c :signed-long
))
121 (defforfun excl_register_set_buf_char
(integer) :void
)
122 (multiple-value-bind (ptr index
) (ff:register-function
'excl-set-buf-char
)
123 (excl_register_set_buf_char index
))
125 (ff:defun-c-callable excl-print-buffer
((n :signed-long
) (type :signed-long
))
127 (0 (princ (get-buf n
)))
128 (1 (error (get-buf n
))))
130 (defforfun excl_register_print_buffer
(integer) :void
)
131 (multiple-value-bind (ptr index
) (ff:register-function
'excl-print-buffer
)
132 (excl_register_print_buffer index
))
134 (defforfun stdputstr
(string) :void
)
135 (defforfun xlfail
(string) :void
)
137 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
140 ;;;; Lisp Interfaces to Linear Algebra Routines
142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
146 ;;;; Cholesky Decomposition
149 (defforfun excl_chol_decomp_front
(integer integer integer
) :integer
)
150 (defun chol-decomp-front (x y z
) (excl_chol_decomp_front x y z
))
153 ;;;; LU Decomposition
156 (defforfun excl_lu_decomp_front
157 (integer integer integer integer integer
)
159 (defun lu-decomp-front (x y z u v
) (excl_lu_decomp_front x y z u v
))
160 (defforfun excl_lu_solve_front
161 (integer integer integer integer integer
)
163 (defun lu-solve-front (x y z u v
) (excl_lu_solve_front x y z u v
))
164 (defforfun excl_lu_inverse_front
165 (integer integer integer integer integer integer
)
167 (defun lu-inverse-front (x y z u v w
) (excl_lu_inverse_front x y z u v w
))
170 ;;;; SV Decomposition
173 (defforfun excl_sv_decomp_front
174 (integer integer integer integer integer
)
176 (defun sv-decomp-front (x y z u v
) (excl_sv_decomp_front x y z u v
))
179 ;;;; QR Decomposition
182 (defforfun excl_qr_decomp_front
183 (integer integer integer integer integer integer
)
185 (defun qr-decomp-front (x y z u v w
) (excl_qr_decomp_front x y z u v w
))
188 ;;;; Estimate of Condition Number for Lower Triangular Matrix
191 (defforfun excl_rcondest_front
(integer integer
) :double-float
)
192 (defun rcondest-front (x y
) (excl_rcondest_front x y
))
195 ;;;; Make Rotation Matrix
198 (defforfun excl_make_rotation_front
199 (integer integer integer integer integer double-float
)
201 (defun make-rotation-front (x y z u v w
)
202 (excl_make_rotation_front x y z u v
(mkdbl w
)))
205 ;;;; Eigenvalues and Eigenvectors
208 (defforfun excl_eigen_front
209 (integer integer integer integer integer
)
211 (defun eigen-front (x y z u v
) (excl_eigen_front x y z u v
))
214 ;;;; Spline Interpolation
217 (defforfun excl_range_to_rseq
218 (integer integer integer integer
)
220 (defun la-range-to-rseq (x y z u
) (excl_range_to_rseq x y z u
))
221 (defforfun excl_spline_front
222 (integer integer integer integer integer integer integer
)
224 (defun spline-front (x y z u v w a
) (excl_spline_front x y z u v w a
))
227 ;;;; Kernel Density Estimators and Smoothers
230 (defforfun excl_kernel_dens_front
231 (integer integer double-float integer integer integer integer
)
233 (defun kernel-dens-front (x y z u v w a
)
234 (excl_kernel_dens_front x y
(mkdbl z
) u v w a
))
236 (defforfun excl_kernel_smooth_front
237 (integer integer integer double-float integer integer integer integer
)
239 (defun kernel-smooth-front (x y z u v w a b
)
240 (excl_kernel_smooth_front x y z
(mkdbl u
) v w a b
))
243 ;;;; Lowess Smoother Interface
246 (defforfun excl_base_lowess_front
247 (integer integer integer double-float integer double-float
248 integer integer integer
)
250 (defun base-lowess-front (x y z u v w a b c
)
251 (excl_base_lowess_front x y z
(mkdbl u
) v
(mkdbl w
) a b c
))
257 (defforfun excl_fft_front
(integer integer integer integer
) :integer
)
258 (defun fft-front (x y z u
) (excl_fft_front x y z u
))
261 ;;;; Maximization and Numerical Derivatives
264 (ff:defun-c-callable excl-maximize-callback
((n :signed-long
)
269 (pderivs :signed-long
))
270 (maximize-callback n px pfval pgrad phess pderivs
))
271 (defforfun excl_register_maximize_callback
(integer) :void
)
272 (multiple-value-bind (ptr index
) (ff:register-function
'excl-maximize-callback
)
273 (excl_register_maximize_callback index
))
275 (defforfun excl_numgrad_front
276 (integer integer integer double-float integer
)
278 (defun numgrad-front (x y z u v
) (excl_numgrad_front x y z
(mkdbl u
) v
))
280 (defforfun excl_numhess_front
281 (integer integer integer integer integer double-float integer
)
283 (defun numhess-front (x y z u v w a
)
284 (excl_numhess_front x y z u v
(mkdbl w
) a
))
286 (defforfun excl_minfo_maximize
287 (integer integer integer integer integer integer
)
289 (defun base-minfo-maximize (x y z u v w
) (excl_minfo_maximize x y z u v w
))
291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
292 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
294 ;;;; Probability Distributions
296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
299 ;; C-Callable Uniform Generator
300 (ff:defun-c-callable uni
() (excl_set_double_value (random 1.d0
)))
301 (defforfun excl_register_uni
(integer) :void
)
302 (multiple-value-bind (ptr index
) (ff:register-function
'uni
)
303 (excl_register_uni index
))
305 (defforfun excl_unirand
() :double-float
)
306 (defun one-uniform-rand () (excl_unirand))
308 ;; Log-gamma function
309 (defforfun excl_gamma
(double-float) :double-float
)
310 (defun base-log-gamma (x) (excl_gamma (mkdbl x
)))
312 ;; normal distribution
313 (defforfun excl_normalcdf
(double-float) :double-float
)
314 (defun base-normal-cdf (x) (excl_normalcdf (mkdbl x
)))
315 (defforfun excl_normalquant
(double-float) :double-float
)
316 (defun base-normal-quant (x) (excl_normalquant (mkdbl x
)))
317 (defforfun excl_normaldens
(double-float) :double-float
)
318 (defun base-normal-dens (x) (excl_normaldens (mkdbl x
)))
319 (defforfun excl_normalrand
() :double-float
)
320 (defun one-normal-rand () (excl_normalrand))
321 (defforfun excl_bnormcdf
(double-float double-float double-float
) :double-float
)
322 (defun base-bivnorm-cdf (x y z
) (excl_bnormcdf (mkdbl x
) (mkdbl y
) (mkdbl z
)))
324 ;; cauchy distribution
325 (defforfun excl_cauchycdf
(double-float) :double-float
)
326 (defun base-cauchy-cdf (x) (excl_cauchycdf (mkdbl x
)))
327 (defforfun excl_cauchyquant
(double-float) :double-float
)
328 (defun base-cauchy-quant (x) (excl_cauchyquant (mkdbl x
)))
329 (defforfun excl_cauchydens
(double-float) :double-float
)
330 (defun base-cauchy-dens (x) (excl_cauchydens (mkdbl x
)))
331 (defforfun excl_cauchyrand
() :double-float
)
332 (defun one-cauchy-rand () (excl_cauchyrand))
334 ;; gamma distribution
335 (defforfun excl_gammacdf
(double-float double-float
) :double-float
)
336 (defun base-gamma-cdf (x y
) (excl_gammacdf (mkdbl x
) (mkdbl y
)))
337 (defforfun excl_gammaquant
(double-float double-float
) :double-float
)
338 (defun base-gamma-quant (x y
) (excl_gammaquant (mkdbl x
) (mkdbl y
)))
339 (defforfun excl_gammadens
(double-float double-float
) :double-float
)
340 (defun base-gamma-dens (x y
) (excl_gammadens (mkdbl x
) (mkdbl y
)))
341 (defforfun excl_gammarand
(double-float) :double-float
)
342 (defun one-gamma-rand (x) (excl_gammarand (mkdbl x
)))
344 ;; chi-square distribution
345 (defforfun excl_chisqcdf
(double-float double-float
) :double-float
)
346 (defun base-chisq-cdf (x y
) (excl_chisqcdf (mkdbl x
) (mkdbl y
)))
347 (defforfun excl_chisqquant
(double-float double-float
) :double-float
)
348 (defun base-chisq-quant (x y
) (excl_chisqquant (mkdbl x
) (mkdbl y
)))
349 (defforfun excl_chisqdens
(double-float double-float
) :double-float
)
350 (defun base-chisq-dens (x y
) (excl_chisqdens (mkdbl x
) (mkdbl y
)))
351 (defforfun excl_chisqrand
(double-float) :double-float
)
352 (defun one-chisq-rand (x) (excl_chisqrand (mkdbl x
)))
355 (defforfun excl_betacdf
(double-float double-float double-float
) :double-float
)
356 (defun base-beta-cdf (x y z
) (excl_betacdf (mkdbl x
) (mkdbl y
) (mkdbl z
)))
357 (defforfun excl_betaquant
(double-float double-float double-float
) :double-float
)
358 (defun base-beta-quant (x y z
) (excl_betaquant (mkdbl x
) (mkdbl y
) (mkdbl z
)))
359 (defforfun excl_betadens
(double-float double-float double-float
) :double-float
)
360 (defun base-beta-dens (x y z
) (excl_betadens (mkdbl x
) (mkdbl y
) (mkdbl z
)))
361 (defforfun excl_betarand
(double-float double-float
) :double-float
)
362 (defun one-beta-rand (x y
) (excl_betarand (mkdbl x
) (mkdbl y
)))
365 (defforfun excl_tcdf
(double-float double-float
) :double-float
)
366 (defun base-t-cdf (x y
) (excl_tcdf (mkdbl x
) (mkdbl y
)))
367 (defforfun excl_tquant
(double-float double-float
) :double-float
)
368 (defun base-t-quant (x y
) (excl_tquant (mkdbl x
) (mkdbl y
)))
369 (defforfun excl_tdens
(double-float double-float
) :double-float
)
370 (defun base-t-dens (x y
) (excl_tdens (mkdbl x
) (mkdbl y
)))
371 (defforfun excl_trand
(double-float) :double-float
)
372 (defun one-t-rand (x) (excl_trand (mkdbl x
)))
375 (defforfun excl_fcdf
(double-float double-float double-float
) :double-float
)
376 (defun base-f-cdf (x y z
) (excl_fcdf (mkdbl x
) (mkdbl y
) (mkdbl z
)))
377 (defforfun excl_fquant
(double-float double-float double-float
) :double-float
)
378 (defun base-f-quant (x y z
) (excl_fquant (mkdbl x
) (mkdbl y
) (mkdbl z
)))
379 (defforfun excl_fdens
(double-float double-float double-float
) :double-float
)
380 (defun base-f-dens (x y z
) (excl_fdens (mkdbl x
) (mkdbl y
) (mkdbl z
)))
381 (defforfun excl_frand
(double-float double-float
) :double-float
)
382 (defun one-f-rand (x y
) (excl_frand (mkdbl x
) (mkdbl y
)))
384 ;; Poisson distribution
385 (defforfun excl_poissoncdf
(double-float double-float
) :double-float
)
386 (defun base-poisson-cdf (x y
) (excl_poissoncdf (mkdbl x
) (mkdbl y
)))
387 (defforfun excl_poissonquant
(double-float double-float
) :integer
)
388 (defun base-poisson-quant (x y
) (excl_poissonquant (mkdbl x
) (mkdbl y
)))
389 (defforfun excl_poissonpmf
(integer double-float
) :double-float
)
390 (defun base-poisson-pmf (x y
) (excl_poissonpmf x
(mkdbl y
)))
391 (defforfun excl_poissonrand
(double-float) :integer
)
392 (defun one-poisson-rand (x) (excl_poissonrand (mkdbl x
)))
394 ;; binomial distribution
395 (defforfun excl_binomialcdf
(double-float integer double-float
) :double-float
)
396 (defun base-binomial-cdf (x y z
) (excl_binomialcdf (mkdbl x
) y
(mkdbl z
)))
397 (defforfun excl_binomialquant
(double-float integer double-float
) :integer
)
398 (defun base-binomial-quant (x y z
) (excl_binomialquant (mkdbl x
) y
(mkdbl z
)))
399 (defforfun excl_binomialpmf
(integer integer double-float
) :double-float
)
400 (defun base-binomial-pmf (x y z
) (excl_binomialpmf x y
(mkdbl z
)))
401 (defforfun excl_binomialrand
(integer double-float
) :integer
)
402 (defun one-binomial-rand (x y
) (excl_binomialrand x
(mkdbl y
)))