lib/exclglue.c

   1 #include "linalg.h"
   2
   3 extern double rcondest_front();
   4
   5 extern double unirand(), gamma();
   6 extern double normalcdf(), normalquant(), normaldens(), normalrand(),
   7   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 Value Storage                         **/
  30 /**                                                                       **/
  31 /***************************************************************************/
  32
  33 static int excl_integer_value;
  34 static double excl_double_value;
  35
  36 excl_set_integer_value(x)
  37      int x;
  38 {
  39   excl_integer_value = x;
  40 }
  41
  42 excl_set_double_value(x)
  43      double x;
  44 {
  45   excl_double_value = x;
  46 }
  47
  48 /***************************************************************************/
  49 /**                                                                       **/
  50 /**                     Storage Allocation Functions                      **/
  51 /**                                                                       **/
  52 /***************************************************************************/
  53
  54 int la_base_allocate(n, m)
  55         unsigned n, m;
  56 {
  57   char *p = calloc(n, m);
  58   if (p == nil) xlfail("allocation failed");
  59   return((int) p);
  60 }
  61
  62 int la_base_free_alloc(p)
  63         int p;
  64 {
  65   if (p) free((char *) p);
  66   return(0);
  67 }
  68
  69 int la_mode_size(mode)
  70         int mode;
  71 {
  72   switch (mode) {
  73   case IN: return(sizeof(int));
  74   case RE: return(sizeof(double));
  75   case CX: return(sizeof(Complex));
  76   }
  77   return(0);
  78 }
  79
  80 /***************************************************************************/
  81 /**                                                                       **/
  82 /**                    Callbacks for Internal Storage                     **/
  83 /**                                                                       **/
  84 /***************************************************************************/
  85
  86 int la_allocate_index, la_free_alloc_index;
  87
  88 excl_register_la_allocate(f) int f; { la_allocate_index = f; }
  89 excl_register_la_free_alloc(f) int f; { la_free_alloc_index = f; }
  90
  91 int la_allocate(n, m)
  92      int n, m;
  93 {
  94   lisp_call(la_allocate_index, n, m);
  95   return(excl_integer_value);
  96 }
  97
  98 la_free_alloc(p)
  99      int p;
 100 {
 101   lisp_call(la_free_alloc_index, p);
 102 }
 103
 104 /***************************************************************************/
 105 /**                                                                       **/
 106 /**                     Storage Access Functions                          **/
 107 /**                                                                       **/
 108 /***************************************************************************/
 109
 110 int la_get_integer(p, i)
 111         int p, i;
 112 {
 113   return(*(((int *) p) + i));
 114 }
 115
 116 double la_get_double(p, i)
 117         int p, i;
 118 {
 119   return(*(((double *) p) + i));
 120 }
 121
 122 double la_get_complex_real(p, i)
 123         int p, i;
 124 {
 125   Complex *c = ((Complex *) p) + i;
 126   return(c->real);
 127 }
 128
 129 double la_get_complex_imag(p, i)
 130         int p, i;
 131 {
 132   Complex *c = ((Complex *) p) + i;
 133   return(c->imag);
 134 }
 135
 136 /***************************************************************************/
 137 /**                                                                       **/
 138 /**                     Storage Mutation Functions                        **/
 139 /**                                                                       **/
 140 /***************************************************************************/
 141
 142 int la_put_integer(p, i, x)
 143         int p, i, x;
 144 {
 145   *(((int *) p) + i) = x;
 146   return(0);
 147 }
 148
 149 int la_put_double(p, i, x)
 150         int p, i;
 151         double x;
 152 {
 153   *(((double *) p) + i) = x;
 154   return(0);
 155 }
 156
 157 int la_put_complex(p, i, x, y)
 158         int p, i;
 159         double x, y;
 160 {
 161   Complex *c = ((Complex *) p) + i;
 162   c->real = x;
 163   c->imag = y;
 164   return(0);
 165 }
 166
 167 /***************************************************************************/
 168 /**                                                                       **/
 169 /**                XLISP internal error message emulation                 **/
 170 /**                                                                       **/
 171 /***************************************************************************/
 172
 173 char buf[1000];
 174
 175 static int excl_set_buf_char_index;
 176 excl_register_set_buf_char(f) int f; { excl_set_buf_char_index = f; }
 177 set_buf_char(n, c) int n, c; { lisp_call(excl_set_buf_char_index, n, c); }
 178
 179 static int excl_print_buffer_index;
 180 excl_register_print_buffer(f) int f; { excl_print_buffer_index = f; }
 181 print_buffer(n, m) int n, m; { lisp_call(excl_print_buffer_index, n, m); }
 182
 183 static int bufpos = 0;
 184
 185 static resetbuf() { bufpos = 0; }
 186
 187 static prbuf(s)
 188     char *s;
 189 {
 190   int i, n;
 191
 192   n = strlen(s);
 193   for (i = 0; i <n; i++, bufpos++) set_buf_char(bufpos, s[i]);
 194   set_buf_char(bufpos, 0);
 195 }
 196
 197 xlfail(s)
 198      char *s;
 199 {
 200   resetbuf();
 201   prbuf(s);
 202   print_buffer(bufpos, 1);
 203 }
 204
 205 stdputstr(s)
 206      char *s;
 207 {
 208   resetbuf();
 209   prbuf(s);
 210   print_buffer(bufpos, 0);
 211 }
 212
 213 bufputstr(s)
 214         char *s;
 215 {
 216   object buf;
 217
 218   resetbuf();
 219   prbuf(s);
 220 }
 221
 222 /***************************************************************************/
 223 /***************************************************************************/
 224 /****                                                                   ****/
 225 /*****             Lisp Interfaces to Linear Algebra Routines           ****/
 226 /****                                                                   ****/
 227 /***************************************************************************/
 228 /***************************************************************************/
 229
 230 excl_chol_decomp_front(x, y, z)
 231      int x, y, z;
 232 { return(chol_decomp_front(x, y, z)); }
 233
 234 excl_lu_decomp_front(x, y, z, u, v)
 235      int x, y, z, u, v;
 236 { return(lu_decomp_front(x, y, z, u, v)); }
 237 excl_lu_solve_front(x, y, z, u, v)
 238      int x, y, z, u, v;
 239 { return(lu_solve_front(x, y, z, u, v)); }
 240 excl_lu_inverse_front(x, y, z, u, v, w)
 241      int x, y, z, u, v, w;
 242 { return(lu_inverse_front(x, y, z, u, v, w)); }
 243
 244 excl_sv_decomp_front(x, y, z, u, v)
 245      int x, y, z, u, v;
 246 { return(sv_decomp_front(x, y, z, u, v)); }
 247
 248 excl_qr_decomp_front(x, y, z, u, v, w)
 249      int x, y, z, u, v, w;
 250 { return(qr_decomp_front(x, y, z, u, v, w)); }
 251
 252 double excl_rcondest_front(x, y) int x, y; { return(rcondest_front(x, y)); }
 253
 254 excl_make_rotation_front(x, y, z, u, v, w)
 255      int x, y, z, u, v;
 256      double w;
 257 { return(make_rotation_front(x, y, z, u, v, w)); }
 258
 259 excl_eigen_front(x, y, z, u, v)
 260      int x, y, z, u, v;
 261 { return(eigen_front(x, y, z, u, v)); }
 262
 263 excl_range_to_rseq(x, y, z, u)
 264      int x, y, z, u;
 265 { return(range_to_rseq(x, y, z, u)); }
 266 excl_spline_front(x, y, z, u, v, w, a)
 267      int x, y, z, u, v, w, a;
 268 { return(spline_front(x, y, z, u, v, w, a)); }
 269
 270 excl_kernel_dens_front(x, y, z, u, v, w, a)
 271      int x, y, u, v, w, a;
 272      double z;
 273 { return(kernel_dens_front(x, y, z, u, v, w, a)); }
 274
 275 excl_kernel_smooth_front(x, y, z, u, v, w, a, b)
 276      int x, y, z, v, w, a, b;
 277      double u;
 278 { return(kernel_smooth_front(x, y, z, u, v, w, a, b)); }
 279
 280 excl_base_lowess_front(x, y, z, u, v, w, a, b, c)
 281      int x, y, z, v, a, b, c;
 282      double u, w;
 283 { return(base_lowess_front(x, y, z, u, v, w, a, b, c)); }
 284
 285 excl_fft_front(x, y, z, u) int x, y, z, u; { return(fft_front(x, y, z, u)); }
 286
 287 static int excl_maximize_callback_index;
 288 excl_register_maximize_callback(f) int f; { excl_maximize_callback_index = f; }
 289 maximize_callback(n, px, pfval, pgrad, phess, pderivs)
 290      int n, px, pfval, pgrad, phess, pderivs;
 291 {
 292   lisp_call(excl_maximize_callback_index, n, px, pfval, pgrad, phess, pderivs);
 293 }
 294
 295 excl_numgrad_front(x, y, z, u, v)
 296      int x, y, z, v;
 297      double u;
 298 {
 299   return(numgrad_front(x, y, z, u, v));
 300 }
 301
 302 excl_numhess_front(x, y, z, u, v, w, a)
 303      int x, y, z, u, v, a;
 304      double w;
 305 {
 306   return(numhess_front(x, y, z, u, v, w, a));
 307 }
 308
 309 excl_minfo_maximize(x, y, z, u, v, w)
 310      int x, y, z, u, v, w;
 311 {
 312   return(minfo_maximize(x, y, z, u, v, w));
 313 }
 314
 315 /***************************************************************************/
 316 /***************************************************************************/
 317 /****                                                                   ****/
 318 /****                    Probability Distributions                      ****/
 319 /****                                                                   ****/
 320 /***************************************************************************/
 321 /***************************************************************************/
 322
 323 /* Uniform genrator */
 324 static int excl_uni_callback;
 325
 326 excl_register_uni(fun)
 327      int fun;
 328 {
 329   excl_uni_callback = fun;
 330 }
 331
 332 double uni()
 333 {
 334   lisp_call(excl_uni_callback);
 335   return(excl_double_value);
 336 }
 337
 338 double excl_unirand() { return(unirand()); }
 339 double excl_gamma(x) double x; { return(gamma(x)); }
 340
 341 double excl_normalcdf(x) double x; { return(normalcdf(x)); }
 342 double excl_normalquant(x) double x; { return(normalquant(x)); }
 343 double excl_normaldens(x) double x; { return(normaldens(x)); }
 344 double excl_normalrand() { return(normalrand()); }
 345 double excl_bnormcdf(x, y, z) double x, y, z; { return(bnormcdf(x, y, z)); }
 346
 347 double excl_cauchycdf(x) double x; { return(cauchycdf(x)); }
 348 double excl_cauchyquant(x) double x; { return(cauchyquant(x)); }
 349 double excl_cauchydens(x) double x; { return(cauchydens(x)); }
 350 double excl_cauchyrand() { return(cauchyrand()); }
 351
 352 double excl_gammacdf(x, y) double x, y; { return(gammacdf(x, y)); }
 353 double excl_gammaquant(x, y) double x, y; { return(gammaquant(x, y)); }
 354 double excl_gammadens(x, y) double x, y; { return(gammadens(x, y)); }
 355 double excl_gammarand(x) double x; { return(gammarand(x)); }
 356
 357 double excl_chisqcdf(x, y) double x, y; { return(chisqcdf(x, y)); }
 358 double excl_chisqquant(x, y) double x, y; { return(chisqquant(x, y)); }
 359 double excl_chisqdens(x, y) double x, y; { return(chisqdens(x, y)); }
 360 double excl_chisqrand(x) double x; { return(chisqrand(x)); }
 361
 362 double excl_betacdf(x, y, z) double z, y, x; { return(betacdf(x, y, z)); }
 363 double excl_betaquant(x, y, z) double z, y, x; { return(betaquant(x, y, z)); }
 364 double excl_betadens(x, y, z) double z, y, x; { return(betadens(x, y, z)); }
 365 double excl_betarand(x, y) double x, y; { return(betarand(x, y)); }
 366
 367 double excl_tcdf(x, y) double x, y; { return(tcdf(x, y)); }
 368 double excl_tquant(x, y) double x, y; { return(tquant(x, y)); }
 369 double excl_tdens(x, y) double x, y; { return(tdens(x, y)); }
 370 double excl_trand(x) double x; { return(trand(x)); }
 371
 372 double excl_fcdf(x, y, z) double z, y, x; { return(fcdf(x, y, z)); }
 373 double excl_fquant(x, y, z) double z, y, x; { return(fquant(x, y, z)); }
 374 double excl_fdens(x, y, z) double z, y, x; { return(fdens(x, y, z)); }
 375 double excl_frand(x, y) double x, y; { return(frand(x, y)); }
 376
 377 double excl_poissoncdf(x, y) double x, y; { return(poissoncdf(x, y)); }
 378 int excl_poissonquant(x, y) double x, y; { return(poissonquant(x, y)); }
 379 double excl_poissonpmf(x, y) int x; double y; { return(poissonpmf(x, y)); }
 380 int excl_poissonrand(x) double x; { return(poissonrand(x)); }
 381
 382 double excl_binomialcdf(x, y, z) double x, z; int y; {return(binomialcdf(x, y, z));}
 383 int excl_binomialquant(x, y, z) double x, z; int y; {return(binomialquant(x, y, z)); }
 384 double excl_binomialpmf(x, y, z) int x, y; double z; {return(binomialpmf(x, y, z)); }
 385 int excl_binomialrand(x, y) int x; double y; { return(binomialrand(x, y)); }