lib/mclglue.c

   1 #include "linalg.h"
   2
   3 typedef char *PTR;
   4
   5 extern double unirand(), gamma();
   6 extern double normalcdf(), normalquant(), normaldens(), normalrand();
   7 extern double bnormcdf();
   8 extern double cauchycdf(), cauchyquant(), cauchydens(), cauchyrand();
   9 extern double gammacdf(), gammaquant(), gammadens(), gammarand();
  10 extern double chisqcdf(), chisqquant(), chisqdens(), chisqrand();
  11 extern double betacdf(), betaquant(), betadens(), betarand();
  12 extern double tcdf(), tquant(), tdens(), trand();
  13 extern double fcdf(), fquant(), fdens(), frand();
  14 extern double poissoncdf(), poissonpmf();
  15 extern int poissonquant(), poissonrand();
  16 extern double binomialcdf(), binomialpmf();
  17 extern int binomialquant(), binomialrand();
  18
  19 /***********************************************************************/
  20 /***********************************************************************/
  21 /****                                                               ****/
  22 /****                        Basic Utilities                        ****/
  23 /****                                                               ****/
  24 /***********************************************************************/
  25 /***********************************************************************/
  26
  27 /***********************************************************************/
  28 /**                                                                   **/
  29 /**                    Callback Support Functions                     **/
  30 /**                                                                   **/
  31 /***********************************************************************/
  32
  33 static int ccl_integer_value;
  34 static double ccl_double_value;
  35 static PTR ccl_ptr_value;
  36 ccl_store_integer(x) int x; { ccl_integer_value = x; }
  37 ccl_store_double(x) double x; { ccl_double_value = x; }
  38 ccl_store_ptr(x) PTR x; { ccl_ptr_value = x; }
  39
  40 /***************************************************************************/
  41 /**                                                                       **/
  42 /**                       Lisp-Managed Calloc/Free                        **/
  43 /**                                                                       **/
  44 /***************************************************************************/
  45
  46 #ifdef DODO
  47 static void (*new_ptr)();
  48 static void (*free_ptr)();
  49
  50 register_new_ptr(f) void (*f)(); { new_ptr = f; }
  51 register_free_ptr(f) void (*f)(); { free_ptr = f; }
  52
  53 char *calloc(n, m)
  54         int n, m;
  55 {
  56   int i, N = n * m;
  57   char *p;
  58
  59   (*new_ptr)(N);
  60   p = (char *) ccl_ptr_value;
  61   for (i = 0; i < N; i++) p[i] = 0;
  62   return(p);
  63 }
  64
  65 malloc() { xlfail("malloc not available yet"); }
  66 realloc() { xlfail("realloc not available yet"); }
  67
  68 void free(p)
  69         char *p;
  70 {
  71   (*free_ptr)(p);
  72 }
  73 #endif DODO
  74
  75 /***************************************************************************/
  76 /**                                                                       **/
  77 /**                     Storage Allocation Functions                      **/
  78 /**                                                                       **/
  79 /***************************************************************************/
  80
  81 PTR la_base_allocate(n, m)
  82         unsigned n, m;
  83 {
  84   char *p = calloc(n, m);
  85   if (p == nil) xlfail("allocation failed");
  86   return((PTR) p);
  87 }
  88
  89 int la_base_free_alloc(p)
  90         PTR p;
  91 {
  92   if (p) free((char *) p);
  93   return(0);
  94 }
  95
  96 int la_mode_size(mode)
  97         int mode;
  98 {
  99   switch (mode) {
 100   case IN: return(sizeof(int));
 101   case RE: return(sizeof(double));
 102   case CX: return(sizeof(Complex));
 103   }
 104   return(0);
 105 }
 106
 107 /***************************************************************************/
 108 /**                                                                       **/
 109 /**                    Callbacks for Internal Storage                     **/
 110 /**                                                                       **/
 111 /***************************************************************************/
 112
 113 int (*ccl_la_allocate)(), (*ccl_la_free_alloc)();
 114
 115 register_la_allocate(f) int (*f)(); { ccl_la_allocate = f; }
 116 register_la_free_alloc(f) int (*f)(); { ccl_la_free_alloc = f; }
 117
 118 PTR la_allocate(n, m)
 119      int n, m;
 120 {
 121   (*ccl_la_allocate)(n, m);
 122   return(ccl_ptr_value);
 123 }
 124
 125 la_free_alloc(p)
 126      PTR p;
 127 {
 128   (*ccl_la_free_alloc)(p);
 129 }
 130
 131 /***************************************************************************/
 132 /**                                                                       **/
 133 /**                     Storage Access Functions                          **/
 134 /**                                                                       **/
 135 /***************************************************************************/
 136
 137 int la_get_integer(p, i)
 138      PTR p;
 139      int i;
 140 {
 141   return(*(((int *) p) + i));
 142 }
 143
 144 double la_get_double(p, i)
 145      PTR p;
 146      int i;
 147 {
 148   return(*(((double *) p) + i));
 149 }
 150
 151 double la_get_complex_real(p, i)
 152      PTR p;
 153      int i;
 154 {
 155   Complex *c = ((Complex *) p) + i;
 156   return(c->real);
 157 }
 158
 159 double la_get_complex_imag(p, i)
 160      PTR p;
 161      int i;
 162 {
 163   Complex *c = ((Complex *) p) + i;
 164   return(c->imag);
 165 }
 166
 167 PTR la_get_pointer(p, i)
 168      PTR p;
 169          int i;
 170 {
 171   return(*(((PTR *) p) + i));
 172 }
 173
 174 /***************************************************************************/
 175 /**                                                                       **/
 176 /**                     Storage Mutation Functions                        **/
 177 /**                                                                       **/
 178 /***************************************************************************/
 179
 180 int la_put_integer(p, i, x)
 181      PTR p;
 182      int i, x;
 183 {
 184   *(((int *) p) + i) = x;
 185   return(0);
 186 }
 187
 188 int la_put_double(p, i, x)
 189      PTR p;
 190      int i;
 191      double x;
 192 {
 193   *(((double *) p) + i) = x;
 194   return(0);
 195 }
 196
 197 int la_put_complex(p, i, x, y)
 198      PTR p;
 199      int i;
 200      double x, y;
 201 {
 202   Complex *c = ((Complex *) p) + i;
 203   c->real = x;
 204   c->imag = y;
 205   return(0);
 206 }
 207
 208 int la_put_pointer(p, i, x)
 209      PTR p, x;
 210          int i;
 211 {
 212   *(((PTR *) p) + i) = x;
 213   return(0);
 214 }
 215
 216 /***********************************************************************/
 217 /**                                                                   **/
 218 /**               XLISP Internal Error Message Emulation              **/
 219 /**                                                                   **/
 220 /***********************************************************************/
 221
 222 char buf[1000];
 223
 224 static int (*ccl_set_buf_char_fptr)();
 225 register_set_buf_char(f) int (*f)(); { ccl_set_buf_char_fptr = f; }
 226 set_buf_char(n, c) int n, c; { (*ccl_set_buf_char_fptr)(n, c); }
 227
 228 static int (*ccl_print_buffer)();
 229 register_print_buffer(f) int (*f)(); { ccl_print_buffer = f; }
 230 print_buffer(n, m) int n, m; { (*ccl_print_buffer)(n, m); }
 231
 232 static int bufpos = 0;
 233
 234 static resetbuf() { bufpos = 0; }
 235
 236 static prbuf(s)
 237     char *s;
 238 {
 239   int i, n;
 240
 241   n = strlen(s);
 242   for (i = 0; i <n; i++, bufpos++) set_buf_char(bufpos, s[i]);
 243   set_buf_char(bufpos, 0);
 244 }
 245
 246 xlfail(s)
 247         char *s;
 248 {
 249   resetbuf();
 250   prbuf(s);
 251   print_buffer(bufpos, 1);
 252 }
 253
 254 stdputstr(s)
 255         char *s;
 256 {
 257   resetbuf();
 258   prbuf(s);
 259   print_buffer(bufpos, 0);
 260 }
 261
 262 bufputstr(s)
 263         char *s;
 264 {
 265   resetbuf();
 266   prbuf(s);
 267 }
 268
 269 /***************************************************************************/
 270 /***************************************************************************/
 271 /****                                                                   ****/
 272 /*****             Lisp Interfaces to Linear Algebra Routines           ****/
 273 /****                                                                   ****/
 274 /***************************************************************************/
 275 /***************************************************************************/
 276
 277 ccl_chol_decomp_front(mat, n, dpars)
 278      PTR mat, dpars;
 279      int n;
 280 {
 281   return(chol_decomp_front(mat, n, dpars));
 282 }
 283
 284 ccl_lu_decomp_front(mat, n, iv, mode, dp)
 285      PTR mat, iv, dp;
 286      int n, mode;
 287 {
 288   return(lu_decomp_front(mat, n, iv, mode, dp));
 289 }
 290
 291 ccl_lu_solve_front(a, n, indx, b, mode)
 292      PTR a, indx, b;
 293      int n, mode;
 294 {
 295   return(lu_solve_front(a, n, indx, b, mode));
 296 }
 297
 298 ccl_lu_inverse_front(pmat, n, piv, pv, mode, pinv)
 299      PTR pmat, piv, pv, pinv;
 300      int n, mode;
 301 {
 302   return(lu_inverse_front(pmat, n, piv, pv, mode, pinv));
 303 }
 304
 305 ccl_sv_decomp_front(mat, m, n, w, v)
 306      PTR mat, w, v;
 307      int m, n;
 308 {
 309   return(sv_decomp_front(mat, m, n, w, v));
 310 }
 311
 312 ccl_qr_decomp_front(mat, m, n, v, jpvt, pivot)
 313      PTR mat, v, jpvt;
 314      int m, n, pivot;
 315 {
 316   return(qr_decomp_front(mat, m, n, v, jpvt, pivot));
 317 }
 318
 319 double ccl_rcondest_front(mat, n)
 320      PTR mat;
 321      int n;
 322 {
 323   return(rcondest_front(mat, n));
 324 }
 325
 326 ccl_make_rotation_front(n, rot, x, y, use_alpha, alpha)
 327      int n, use_alpha;
 328      PTR rot, x, y;
 329      double alpha;
 330 {
 331   return(make_rotation_front(n, rot, x, y, use_alpha, alpha));
 332 }
 333
 334 ccl_eigen_front(a, n, w, z, fv1)
 335      PTR a, w, z, fv1;
 336      int n;
 337 {
 338   return(eigen_front(a, n, w, z, fv1));
 339 }
 340
 341 ccl_range_to_rseq(n, px, ns, pxs)
 342      int n, ns;
 343      PTR px, pxs;
 344 {
 345   return(range_to_rseq(n, px, ns, pxs));
 346 }
 347
 348 ccl_spline_front(n, x, y, ns, xs, ys, work)
 349      PTR x, y, xs, ys, work;
 350      int n, ns;
 351 {
 352   return(spline_front(n, x, y, ns, xs, ys, work));
 353 }
 354
 355 ccl_kernel_dens_front(x, n, width, xs, ys, ns, code)
 356      PTR x, xs, ys;
 357      int n, ns, code;
 358      double width;
 359 {
 360   return(kernel_dens_front(x, n, width, xs, ys, ns, code));
 361 }
 362
 363 ccl_kernel_smooth_front(x, y, n, width, xs, ys, ns, code)
 364      PTR x, y, xs, ys;
 365      int n, ns, code;
 366      double width;
 367 {
 368   return(kernel_smooth_front(x, y, n, width, xs, ys, ns, code));
 369 }
 370
 371 ccl_base_lowess_front(x, y, n, f, nsteps, delta, ys, rw, res)
 372      PTR x, y, ys, rw, res;
 373      int n, nsteps;
 374      double f, delta;
 375 {
 376   return(base_lowess_front(x, y, n, f, nsteps, delta, ys, rw, res));
 377 }
 378
 379 ccl_fft_front(n, x, work, isign)
 380      int n, isign;
 381      PTR x, work;
 382 {
 383   return(fft_front(n, x, work, isign));
 384 }
 385
 386 static int (*ccl_maximize_callback)();
 387 register_maximize_callback(f) int (*f)(); { ccl_maximize_callback = f; }
 388 maximize_callback(n, px, pfval, pgrad, phess, pderivs)
 389      int n;
 390      PTR px, pfval, pgrad, phess, pderivs;
 391 {
 392   (*ccl_maximize_callback)(n, px, pfval, pgrad, phess, pderivs);
 393 }
 394
 395 ccl_numgrad_front(n, px, pgrad, h, pscale)
 396      int n;
 397      PTR px, pgrad, pscale;
 398      double h;
 399 {
 400   return(numgrad_front(n, px, pgrad, h, pscale));
 401 }
 402
 403 ccl_numhess_front(n, px, pf, pgrad, phess, h, pscale)
 404      int n;
 405      PTR px, pf, pgrad, phess, pscale;
 406      double h;
 407 {
 408   return(numhess_front(n, px, pf, pgrad, phess, h, pscale));
 409 }
 410
 411 ccl_minfo_maximize(px, pfvals, pscale, pip, pdp, verbose)
 412      PTR px, pfvals, pscale, pip, pdp;
 413      int verbose;
 414 {
 415   return(minfo_maximize(px, pfvals, pscale, pip, pdp, verbose));
 416 }
 417
 418 /***********************************************************************/
 419 /***********************************************************************/
 420 /****                                                               ****/
 421 /****                   Probability Distributions                   ****/
 422 /****                                                               ****/
 423 /***********************************************************************/
 424 /***********************************************************************/
 425
 426 static int (*ccl_uni_fptr)();
 427 register_uni(f) int (*f)(); { ccl_uni_fptr = f; }
 428 double uni() { (*ccl_uni_fptr)(); return(ccl_double_value); }
 429
 430 double ccl_gamma(x) double x; { return(gamma(x)); }
 431
 432 double ccl_normalcdf(x) double x; { return(normalcdf(x)); }
 433 double ccl_normalquant(x) double x; { return(normalquant(x)); }
 434 double ccl_normaldens(x) double x; { return(normaldens(x)); }
 435 double ccl_normalrand() { return(normalrand()); }
 436 double ccl_bnormcdf(x, y, z) double x, y, z; { return(bnormcdf(x,y,z)); }
 437
 438 double ccl_cauchycdf(x) double x; { return(cauchycdf(x)); }
 439 double ccl_cauchyquant(x) double x; { return(cauchyquant(x)); }
 440 double ccl_cauchydens(x) double x; { return(cauchydens(x)); }
 441 double ccl_cauchyrand() { return(cauchyrand()); }
 442
 443 double ccl_gammacdf(x, y) double x, y; { return(gammacdf(x, y)); }
 444 double ccl_gammaquant(x, y) double x, y; { return(gammaquant(x, y)); }
 445 double ccl_gammadens(x, y) double x, y; { return(gammadens(x, y)); }
 446 double ccl_gammarand(x) double x; { return(gammarand(x)); }
 447
 448 double ccl_chisqcdf(x, y) double x, y; { return(chisqcdf(x, y)); }
 449 double ccl_chisqquant(x, y) double x, y; { return(chisqquant(x, y)); }
 450 double ccl_chisqdens(x, y) double x, y; { return(chisqdens(x, y)); }
 451 double ccl_chisqrand(x) double x; { return(chisqrand(x)); }
 452
 453 double ccl_betacdf(x, y, z) double x, y, z; { return(betacdf(x, y, z)); }
 454 double ccl_betaquant(x, y, z) double x, y, z; { return(betaquant(x, y, z)); }
 455 double ccl_betadens(x, y, z) double x, y, z; { return(betadens(x, y, z)); }
 456 double ccl_betarand(x, y) double x, y; { return(betarand(x, y)); }
 457
 458 double ccl_tcdf(x, y) double x, y; { return(tcdf(x, y)); }
 459 double ccl_tquant(x, y) double x, y; { return(tquant(x, y)); }
 460 double ccl_tdens(x, y) double x, y; { return(tdens(x, y)); }
 461 double ccl_trand(x) double x; { return(trand(x)); }
 462
 463 double ccl_fcdf(x, y, z) double x, y, z; { return(fcdf(x, y, z)); }
 464 double ccl_fquant(x, y, z) double x, y, z; { return(fquant(x, y, z)); }
 465 double ccl_fdens(x, y, z) double x, y, z; { return(fdens(x, y, z)); }
 466 double ccl_frand(x, y) double x, y; { return(frand(x, y)); }
 467
 468 double ccl_poissoncdf(x, y) double x, y; { return(poissoncdf(x, y)); }
 469 int ccl_poissonquant(x, y) double x, y; { return(poissonquant(x, y)); }
 470 double ccl_poissonpmf(x, y) int x; double y; { return(poissonpmf(x, y)); }
 471 int ccl_poissonrand(x) double x; { return(poissonrand(x)); }
 472
 473 double ccl_binomialcdf(x, y, z) double x, z; int y; { return(binomialcdf(x, y, z)); }
 474 int ccl_binomialquant(x, y, z) double x, z; int y; { return(binomialquant(x, y, z)); }
 475 double ccl_binomialpmf(x, y, z) int x, y; double z; { return(binomialpmf(x, y, z)); }
 476 int ccl_binomialrand(x, y) int x; double y; { return(binomialrand(x, y)); }