exclglue.lsp

   1 ;;;; exclglue -- Interface to C library
   2 ;;;;
   3 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   4 ;;;; unrestricted use.
   5
   6 (in-package 'lisp-stat-basics)
   7
   8 (require :foreign)
   9
  10 (load "lib/exclglue.o"
  11       :foreign-files '("lib/clib.a")
  12       :system-libraries #+:mips '("m_G0") #-:mips '("m"))
  13
  14 ;;;
  15 ;;; FF Macros
  16 ;;;
  17
  18 (defmacro defforfun (name arg-types return-type)
  19   `(ff:defforeign ',name
  20                   :arguments ',arg-types
  21                   :return-type ,return-type))
  22
  23 (defmacro mkdbl (x) `(float ,x 0.d0))
  24
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;;;
  28 ;;;;                           Basic Utilities
  29 ;;;;
  30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32
  33 ;;;;
  34 ;;;;                   Callback Value Storage
  35 ;;;;
  36
  37 (defforfun excl_set_integer_value (integer) :void)
  38 (defforfun excl_set_double_value (double-float) :void)
  39
  40 ;;;;
  41 ;;;;                Storage Allocation Functions
  42 ;;;;
  43
  44 (defun null-ptr-p (p) (= p 0))
  45 (defun ptr-eq (p q) (= p q))
  46
  47 (defforfun la_base_allocate (integer integer) :integer)
  48 (defun la-base-allocate (n m) (la_base_allocate n m))
  49
  50 (defforfun la_base_free_alloc (integer) :void)
  51 (defun la-base-free (p) (la_base_free_alloc p))
  52
  53 (defforfun la_mode_size (integer) :integer)
  54 (defun la-mode-size (mode) (la_mode_size mode))
  55
  56 ;;;;
  57 ;;;;             Callbacks for Internal Storage
  58 ;;;;
  59
  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))
  65
  66 (ff:defun-c-callable lisp_la_free_alloc ((p :signed-long))
  67   (la-free p))
  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))
  71
  72 ;;;;
  73 ;;;;                Storage Access Functions
  74 ;;;;
  75
  76 (defforfun la_get_integer (integer integer) :integer)
  77 (defun la-get-integer (p i) (la_get_integer p i))
  78
  79 (defforfun la_get_double (integer integer) :double-float)
  80 (defun la-get-double (p i) (la_get_double p i))
  81
  82 (defforfun la_get_complex_real (integer integer) :double-float)
  83 (defun la-get-complex-real (p i) (la_get_complex_real p i))
  84
  85 (defforfun la_get_complex_imag (integer integer) :double-float)
  86 (defun la-get-complex-imag (p i) (la_get_complex_imag p i))
  87
  88 (defun la-get-complex (p i)
  89   (complex (la-get-complex-real p i) (la-get-complex-imag p i)))
  90
  91 (defun la-get-pointer (p i) (la-get-integer p i))
  92
  93 ;;;;
  94 ;;;;                Storage Mutation Functions
  95 ;;;;
  96
  97 (defforfun la_put_integer (integer integer integer) :void)
  98 (defun la-put-integer (p i x) (la_put_integer p i x))
  99
 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)))
 102
 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)))
 105
 106 (defun la-put-pointer (p i x) (la-put-integer p i x))
 107
 108 ;;;;
 109 ;;;; XLISP internal error message emulation
 110 ;;;;
 111
 112 (defvar *buf* (make-string 1000))
 113
 114 (defun set-buf-char (i c) (setf (elt *buf* i) (code-char c)))
 115
 116 (defun get-buf (&optional (n (position (code-char 0) *buf*)))
 117   (subseq *buf* 0 n))
 118
 119 (ff:defun-c-callable excl-set-buf-char ((n :signed-long) (c :signed-long))
 120   (set-buf-char n c))
 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))
 124
 125 (ff:defun-c-callable excl-print-buffer ((n :signed-long) (type :signed-long))
 126   (case type
 127     (0 (princ (get-buf n)))
 128     (1 (error (get-buf n))))
 129   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))
 133
 134 (defforfun stdputstr (string) :void)
 135 (defforfun xlfail (string) :void)
 136
 137 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 139 ;;;;
 140 ;;;;             Lisp Interfaces to Linear Algebra Routines
 141 ;;;;
 142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 144
 145 ;;;;
 146 ;;;; Cholesky Decomposition
 147 ;;;;
 148
 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))
 151
 152 ;;;;
 153 ;;;; LU Decomposition
 154 ;;;;
 155
 156 (defforfun excl_lu_decomp_front
 157   (integer integer integer integer integer)
 158   :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)
 162   :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)
 166   :integer)
 167 (defun lu-inverse-front (x y z u v w) (excl_lu_inverse_front x y z u v w))
 168
 169 ;;;;
 170 ;;;; SV Decomposition
 171 ;;;;
 172
 173 (defforfun excl_sv_decomp_front
 174   (integer integer integer integer integer)
 175   :integer)
 176 (defun sv-decomp-front (x y z u v) (excl_sv_decomp_front x y z u v))
 177
 178 ;;;;
 179 ;;;; QR Decomposition
 180 ;;;;
 181
 182 (defforfun excl_qr_decomp_front
 183   (integer integer integer integer integer integer)
 184   :integer)
 185 (defun qr-decomp-front (x y z u v w) (excl_qr_decomp_front x y z u v w))
 186
 187 ;;;;
 188 ;;;; Estimate of Condition Number for Lower Triangular Matrix
 189 ;;;;
 190
 191 (defforfun excl_rcondest_front (integer integer) :double-float)
 192 (defun rcondest-front (x y) (excl_rcondest_front x y))
 193
 194 ;;;;
 195 ;;;; Make Rotation Matrix
 196 ;;;;
 197
 198 (defforfun excl_make_rotation_front
 199   (integer integer integer integer integer double-float)
 200   :integer)
 201 (defun make-rotation-front (x y z u v w)
 202   (excl_make_rotation_front x y z u v (mkdbl w)))
 203
 204 ;;;;
 205 ;;;; Eigenvalues and Eigenvectors
 206 ;;;;
 207
 208 (defforfun excl_eigen_front
 209   (integer integer integer integer integer)
 210   :integer)
 211 (defun eigen-front (x y z u v) (excl_eigen_front x y z u v))
 212
 213 ;;;;
 214 ;;;; Spline Interpolation
 215 ;;;;
 216
 217 (defforfun excl_range_to_rseq
 218   (integer integer integer integer)
 219   :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)
 223   :integer)
 224 (defun spline-front (x y z u v w a) (excl_spline_front x y z u v w a))
 225
 226 ;;;;
 227 ;;;; Kernel Density Estimators and Smoothers
 228 ;;;;
 229
 230 (defforfun excl_kernel_dens_front
 231   (integer integer double-float integer integer integer integer)
 232   :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))
 235
 236 (defforfun excl_kernel_smooth_front
 237   (integer integer integer double-float integer integer integer integer)
 238   :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))
 241
 242 ;;;;
 243 ;;;; Lowess Smoother Interface
 244 ;;;;
 245
 246 (defforfun excl_base_lowess_front
 247   (integer integer integer double-float integer double-float
 248            integer integer integer)
 249   :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))
 252
 253 ;;;;
 254 ;;;; FFT
 255 ;;;;
 256
 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))
 259
 260 ;;;;
 261 ;;;; Maximization and Numerical Derivatives
 262 ;;;;
 263
 264 (ff:defun-c-callable excl-maximize-callback ((n :signed-long)
 265                                              (px :signed-long)
 266                                              (pfval :signed-long)
 267                                              (pgrad :signed-long)
 268                                              (phess :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))
 274
 275 (defforfun excl_numgrad_front
 276   (integer integer integer double-float integer)
 277   :integer)
 278 (defun numgrad-front (x y z u v) (excl_numgrad_front x y z (mkdbl u) v))
 279
 280 (defforfun excl_numhess_front
 281   (integer integer integer integer integer double-float integer)
 282   :integer)
 283 (defun numhess-front (x y z u v w a)
 284   (excl_numhess_front x y z u v (mkdbl w) a))
 285
 286 (defforfun excl_minfo_maximize
 287   (integer integer integer integer integer integer)
 288   :integer)
 289 (defun base-minfo-maximize (x y z u v w) (excl_minfo_maximize x y z u v w))
 290
 291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 292 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 293 ;;;;
 294 ;;;;                       Probability Distributions
 295 ;;;;
 296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 298
 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))
 304
 305 (defforfun excl_unirand () :double-float)
 306 (defun one-uniform-rand () (excl_unirand))
 307
 308 ;; Log-gamma function
 309 (defforfun excl_gamma (double-float) :double-float)
 310 (defun base-log-gamma (x) (excl_gamma (mkdbl x)))
 311
 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)))
 323
 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))
 333
 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)))
 343
 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)))
 353
 354 ;; beta distribution
 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)))
 363
 364 ;; t distribution
 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)))
 373
 374 ;; F distribution
 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)))
 383
 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)))
 393
 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)))