From ab0c5b6f473c5e8d596e0d8b8390869e7d039ca1 Mon Sep 17 00:00:00 2001 From: AJ Rossini Date: Sun, 28 Jan 2007 18:16:24 +0100 Subject: [PATCH] Pristine Start using Luke's original CLS 1.0 alpha 1 --- Data/absorbtion.lsp | 3 + Data/aircraft.lsp | 22 + Data/book.lsp | 57 +++ Data/car-prices.lsp | 1 + Data/diabetes.lsp | 3 + Data/heating.lsp | 2 + Data/iris.lsp | 2 + Data/leukemia.lsp | 25 ++ Data/metabolism.lsp | 2 + Data/oxygen.lsp | 4 + Data/puromycin.lsp | 24 ++ Data/randu.lsp | 1 + Data/stackloss.lsp | 4 + Data/tutorial.lsp | 35 ++ Examples/fstat.lsp | 10 + Makefile | 76 ++++ README | 44 ++ README.excl | 20 + README.kcl | 42 ++ README.mcl | 50 +++ bayes.lsp | 663 +++++++++++++++++++++++++++++++ cmpinclude.h | 695 ++++++++++++++++++++++++++++++++ compound.lsp | 210 ++++++++++ defsys.lsp | 183 +++++++++ dists.lsp | 257 ++++++++++++ exclglue.lsp | 402 +++++++++++++++++++ fastmap.lsp | 95 +++++ kclglue.lsp | 436 ++++++++++++++++++++ kclpatch.lsp | 48 +++ ladata.lsp | 180 +++++++++ lib/Makefile | 25 ++ lib/betabase.c | 289 ++++++++++++++ lib/bivnor.c | 128 ++++++ lib/cbayes.c | 227 +++++++++++ lib/cdists.c | 837 ++++++++++++++++++++++++++++++++++++++ lib/cfft.c | 827 ++++++++++++++++++++++++++++++++++++++ lib/cholesky.c | 81 ++++ lib/clib.make | 134 +++++++ lib/clinalg.c | 211 ++++++++++ lib/complex.c | 115 ++++++ lib/complex.h | 14 + lib/derivatives.c | 67 ++++ lib/eigen.c | 625 +++++++++++++++++++++++++++++ lib/exclglue.c | 385 ++++++++++++++++++ lib/functions.c | 1105 +++++++++++++++++++++++++++++++++++++++++++++++++++ lib/gamln.c | 35 ++ lib/gammabase.c | 288 ++++++++++++++ lib/kernel.c | 83 ++++ lib/linalg.h | 26 ++ lib/linalgdata.c | 89 +++++ lib/lowess.c | 148 +++++++ lib/ludecomp.c | 173 ++++++++ lib/makerotation.c | 59 +++ lib/mclglue.c | 476 ++++++++++++++++++++++ lib/minimize.c | 848 +++++++++++++++++++++++++++++++++++++++ lib/nor.c | 90 +++++ lib/ppnd.c | 60 +++ lib/qrdecomp.c | 186 +++++++++ lib/rcondest.c | 100 +++++ lib/splines.c | 104 +++++ lib/studentbase.c | 120 ++++++ lib/svdecomp.c | 261 ++++++++++++ lib/xlisp.h | 9 + lib/xmath.h | 5 + linalg.lsp | 1074 +++++++++++++++++++++++++++++++++++++++++++++++++ lsbasics.lsp | 717 +++++++++++++++++++++++++++++++++ lsfloat.lsp | 207 ++++++++++ lsmacros.lsp | 105 +++++ lsmath.lsp | 212 ++++++++++ lsobjects.lsp | 816 +++++++++++++++++++++++++++++++++++++ lspackages.lsp | 244 ++++++++++++ lstoplevel.lsp | 145 +++++++ makesys.excl | 13 + makesys.excl.dist | 13 + makesys.kcl | 11 + matrices.lsp | 287 +++++++++++++ maximize.lsp | 326 +++++++++++++++ mclglue.lsp | 468 ++++++++++++++++++++++ nonlin.lsp | 286 +++++++++++++ num_sfun.c | 655 ++++++++++++++++++++++++++++++ numlib.lsp | 197 +++++++++ regression.lsp | 447 +++++++++++++++++++++ statistics.lsp | 326 +++++++++++++++ 83 files changed, 18375 insertions(+) create mode 100644 Data/absorbtion.lsp create mode 100644 Data/aircraft.lsp create mode 100644 Data/book.lsp create mode 100644 Data/car-prices.lsp create mode 100644 Data/diabetes.lsp create mode 100644 Data/heating.lsp create mode 100644 Data/iris.lsp create mode 100644 Data/leukemia.lsp create mode 100644 Data/metabolism.lsp create mode 100644 Data/oxygen.lsp create mode 100644 Data/puromycin.lsp create mode 100644 Data/randu.lsp create mode 100644 Data/stackloss.lsp create mode 100644 Data/tutorial.lsp create mode 100644 Examples/fstat.lsp create mode 100644 Makefile create mode 100644 README create mode 100644 README.excl create mode 100644 README.kcl create mode 100644 README.mcl create mode 100644 bayes.lsp create mode 100644 cmpinclude.h create mode 100644 compound.lsp create mode 100644 defsys.lsp create mode 100644 dists.lsp create mode 100644 exclglue.lsp create mode 100644 fastmap.lsp create mode 100644 kclglue.lsp create mode 100644 kclpatch.lsp create mode 100644 ladata.lsp create mode 100644 lib/Makefile create mode 100644 lib/betabase.c create mode 100644 lib/bivnor.c create mode 100644 lib/cbayes.c create mode 100644 lib/cdists.c create mode 100644 lib/cfft.c create mode 100644 lib/cholesky.c create mode 100644 lib/clib.make create mode 100644 lib/clinalg.c create mode 100644 lib/complex.c create mode 100644 lib/complex.h create mode 100644 lib/derivatives.c create mode 100644 lib/eigen.c create mode 100644 lib/exclglue.c create mode 100644 lib/functions.c create mode 100644 lib/gamln.c create mode 100644 lib/gammabase.c create mode 100644 lib/kernel.c create mode 100644 lib/linalg.h create mode 100644 lib/linalgdata.c create mode 100644 lib/lowess.c create mode 100644 lib/ludecomp.c create mode 100644 lib/makerotation.c create mode 100644 lib/mclglue.c create mode 100644 lib/minimize.c create mode 100644 lib/nor.c create mode 100644 lib/ppnd.c create mode 100644 lib/qrdecomp.c create mode 100644 lib/rcondest.c create mode 100644 lib/splines.c create mode 100644 lib/studentbase.c create mode 100644 lib/svdecomp.c create mode 100644 lib/xlisp.h create mode 100644 lib/xmath.h create mode 100644 linalg.lsp create mode 100644 lsbasics.lsp create mode 100644 lsfloat.lsp create mode 100644 lsmacros.lsp create mode 100644 lsmath.lsp create mode 100644 lsobjects.lsp create mode 100644 lspackages.lsp create mode 100644 lstoplevel.lsp create mode 100644 makesys.excl create mode 100644 makesys.excl.dist create mode 100644 makesys.kcl create mode 100644 matrices.lsp create mode 100644 maximize.lsp create mode 100644 mclglue.lsp create mode 100644 nonlin.lsp create mode 100644 num_sfun.c create mode 100644 numlib.lsp create mode 100644 regression.lsp create mode 100644 statistics.lsp diff --git a/Data/absorbtion.lsp b/Data/absorbtion.lsp new file mode 100644 index 0000000..0722fc5 --- /dev/null +++ b/Data/absorbtion.lsp @@ -0,0 +1,3 @@ +(def iron (list 61 175 111 124 130 173 169 169 160 224 257 333 199)) +(def aluminum (list 13 21 24 23 64 38 33 61 39 71 112 88 54)) +(def absorbtion (list 4 18 14 18 26 26 21 30 28 36 65 62 40)) diff --git a/Data/aircraft.lsp b/Data/aircraft.lsp new file mode 100644 index 0000000..f553b39 --- /dev/null +++ b/Data/aircraft.lsp @@ -0,0 +1,22 @@ +(require "maximize") + +(def failure-times + '((413 14 58 37 100 65 9 169 447 184 36 201 118 34 31 + 18 18 67 57 62 7 22 34) + (90 10 60 186 61 49 14 24 56 20 79 84 44 59 29 118 25 156 + 310 76 26 44 23 62 130 208 70 101 208) + (74 57 48 29 502 12 70 21 29 386 59 27 153 26 326) + (55 320 65 104 220 239 47 246 176 182 33 15 104 35) + (23 261 87 7 120 14 62 47 225 71 246 21 42 20 5 12 120 + 11 3 14 71 11 14 11 16 90 1 16 52 95))) + +(def x (select failure-times 1)) + +(defun gllik (theta) + (let* ((mu (select theta 0)) + (beta (select theta 1)) + (n (length x)) + (bym (* x (/ beta mu)))) + (+ (* n (- (log beta) (log mu) (log-gamma beta))) + (sum (* (- beta 1) (log bym))) + (sum (- bym))))) diff --git a/Data/book.lsp b/Data/book.lsp new file mode 100644 index 0000000..44ae32c --- /dev/null +++ b/Data/book.lsp @@ -0,0 +1,57 @@ +(load-data "tutorial") +(load-data "oxygen") +(load-data "puromycin") +(load-data "aircraft") +(load-data "leukemia") +(load-data "stackloss") +(def precipitation + (list .77 1.74 .81 1.20 1.95 1.20 .47 1.43 3.37 2.20 + 3.00 3.09 1.51 2.10 .52 1.62 1.31 .32 .59 .81 + 2.81 1.87 1.18 1.35 4.75 2.48 .96 1.89 .90 2.05)) +(def urban (list 206 170 155 155 134 239 234 228 330 284 + 201 241 179 244 200 205 279 227 197 242 234)) +(def rural (list 108 152 129 146 174 194 152 223 231 131 + 142 173 155 220 172 148 143 158 108 136)) +(def hc (list .50 .65 .46 .41 .41 .39 .44 .55 .72 .64 .83 .38 + .38 .50 .60 .73 .83 .57 .34 .41 .37 1.02 .87 1.10 + .65 .43 .48 .41 .51 .41 .47 .52 .56 .70 .51 .52 + .57 .51 .36 .48 .52 .61 .58 .46 .47 .55)) +(def co (list 5.01 14.67 8.60 4.42 4.95 7.24 7.51 12.30 + 14.59 7.98 11.53 4.10 5.21 12.10 9.62 14.97 + 15.13 5.04 3.95 3.38 4.12 23.53 19.00 22.92 + 11.20 3.81 3.45 1.85 4.10 2.26 4.74 4.29 + 5.36 14.83 5.69 6.35 6.02 5.79 2.03 4.62 + 6.78 8.43 6.02 3.99 5.22 7.47)) +(def age (list 19 21 24 24 24 25 32 33 35 37 37 44 50 51 52 55 57 62)) +(def cpk (list 520 300 480 1040 1360 580 440 180 490 520 380 640 360 + 240 420 280 400 260)) +(def yield (list 9.2 12.4 5.0 8.9 9.2 6.0 16.3 15.2 9.4 + 12.4 14.5 8.6 12.7 14.0 12.3 18.2 18.0 16.9 + 12.9 16.4 12.1 14.6 16.0 14.7 20.8 20.6 18.7 + 10.9 14.3 9.2 12.6 13.0 13.0 18.3 16.0 13.0)) +(def variety (repeat (repeat (list 1 2 3) (list 3 3 3)) 4)) +(def density (repeat (list 1 2 3 4) (list 9 9 9 9))) +(def abrasion-loss + (list 372 206 175 154 136 112 55 45 221 166 164 113 82 + 32 228 196 128 97 64 249 219 186 155 114 341 340 + 283 267 215 148)) +(def gas1 (list 17.14 12.17 12.22 13.89 16.47 15.88 16.10 16.74 17.54 17.43 + 14.57 12.90 12.81 14.95 16.25 17.13 14.46 14.20 16.90 11.34 + 12.57 13.15 16.53 13.60 13.34 13.67 14.23 15.81 16.63 11.40 + 14.94 13.66 9.79 13.08 14.57 14.93 14.01 14.43 16.35 15.65 + 11.52 17.46 14.67 15.92 16.02 13.46 13.70 14.98 14.57 15.72)) +(def gas2 (list 24.57 24.79 22.21 25.84 25.35 22.19 24.37 21.32 22.74 23.35 + 25.10 28.03 29.09 29.34 24.41 25.12 25.27 27.46 27.65 27.95 + 21.67 22.15 24.36 26.32 24.05 28.27 26.57 26.10 24.35 30.04 + 25.18 27.42 24.50 23.21 25.10 23.59 26.98 22.64 25.27 25.84 + 27.18 24.69 26.35 23.05 23.37 25.46 28.84 22.14 25.42 21.76)) +(def flow (list 5.00 4.81 4.46 4.84 4.46 3.85 3.21 3.25 4.55 + 4.85 4.00 3.62 5.15 3.76 4.90 4.13 5.10 5.05 + 4.27 4.90 4.55 4.39 4.85 4.59 5.00 3.82 3.68 + 5.15 2.94 5.00 4.10 1.15 1.72 4.20 5.00)) +(def moist (list 21 20 16 18 16 18 12 12 13 13 17 24 11 10 17 + 14 14 14 20 12 11 10 16 17 17 17 15 17 21 21 + 21 26 21 17 11)) +(def ratio (list 2.4 2.4 2.4 2.5 3.2 3.1 3.2 2.7 2.7 2.7 2.7 + 2.8 2.5 2.6 2 2 2.0 1.9 2.1 1.9 2 2.0 2.0 2.2 2.4 + 2.4 2.4 2.2 2.2 1.9 2.4 3.5 3 3.5 3.2)) diff --git a/Data/car-prices.lsp b/Data/car-prices.lsp new file mode 100644 index 0000000..38d3121 --- /dev/null +++ b/Data/car-prices.lsp @@ -0,0 +1 @@ +(DEF CAR-PRICES (QUOTE (0.95 1.9 1.3 1.8 1.7 1.5 1.39 1.5 1.5 1.99 1.5 1.75 1.79 1.8 1.1 1.99 1.39 1.8 2.98 2.98 2.9 2.49 2.55 2.6 2.85 2 2.39 2.55 2 2.9 2.99 2.39 2.68 2.48 3.99 3.99 3.3 3.75 3.28 3.92 3.8 3.19 4.88 4.39 4.48 5.2 5.49 5.3 5.3 5.87))) diff --git a/Data/diabetes.lsp b/Data/diabetes.lsp new file mode 100644 index 0000000..8587504 --- /dev/null +++ b/Data/diabetes.lsp @@ -0,0 +1,3 @@ + +(DEF DIABETES (QUOTE ((80 97 105 90 90 86 100 85 97 97 91 87 78 90 86 80 90 99 85 90 90 88 95 90 92 74 98 100 86 98 70 99 75 90 85 99 100 78 106 98 102 90 94 80 93 86 85 96 88 87 94 93 86 86 96 86 89 83 98 100 110 88 100 80 89 91 96 95 82 84 90 100 86 93 107 112 94 93 93 90 99 93 85 89 96 111 107 114 101 108 112 105 103 99 102 110 102 96 95 112 110 92 104 75 92 92 92 93 112 88 114 103 300 303 125 280 216 190 151 303 173 203 195 140 151 275 260 149 233 146 124 213 330 123 130 120 138 188 339 265 353 180 213 328 346) (356 289 319 356 323 381 350 301 379 296 353 306 290 371 312 393 364 359 296 345 378 304 347 327 386 365 365 352 325 321 360 336 352 353 373 376 367 335 396 277 378 360 291 269 318 328 334 356 291 360 313 306 319 349 332 323 323 351 478 398 426 439 429 333 472 436 418 391 390 416 413 385 393 376 403 414 426 364 391 356 398 393 425 318 465 558 503 540 469 486 568 527 537 466 599 477 472 456 517 503 522 476 472 455 442 541 580 472 562 423 643 533 1468 1487 714 1470 1113 972 854 1364 832 967 920 613 857 1373 1133 849 1183 847 538 1001 1520 557 670 636 741 958 1354 1263 1428 923 1025 1246 1568) (124 117 143 199 240 157 221 186 142 131 221 178 136 200 208 202 152 185 116 123 136 134 184 192 279 228 145 172 179 222 134 143 169 263 174 134 182 241 128 222 165 282 94 121 73 106 118 112 157 292 200 220 144 109 151 158 73 81 151 122 117 208 201 131 162 148 130 137 375 146 344 192 115 195 267 281 213 156 221 199 76 490 143 73 237 748 320 188 607 297 232 480 622 287 266 124 297 326 564 408 325 433 180 392 109 313 132 285 139 212 155 120 28 23 232 54 81 87 76 42 102 138 160 131 145 45 118 159 73 103 460 42 13 130 44 314 219 100 10 83 41 77 29 124 15) (3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 2 3 3 2 2 3 2 2 3 3 3 3 2 3 3 3 3 3 2 3 3 3 3 3 2 3 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)))) +(DEF DLABS (QUOTE ("GLUFAST" "GLUTEST" "INSTEST" "CCLASS"))) \ No newline at end of file diff --git a/Data/heating.lsp b/Data/heating.lsp new file mode 100644 index 0000000..7b08ebf --- /dev/null +++ b/Data/heating.lsp @@ -0,0 +1,2 @@ +(DEF GAS-HEAT (QUOTE (25.42 26.12 25.22 23.6 27.77 28.52 21.6 29.49 26.22 25.52 20.19 23.99 26.32 23.38 26.77 31.56 25.54 22.72 27.58 29.96 26.2 23.97 28.17 18.01 22.98))) +(DEF ELECTRIC-HEAT (QUOTE (33.52 51.01 41.99 33.8 25.93 30.32 32.06 39.86 24.62 31.8 48.58 44.65 31.3 35.4 19.24 40.78 43.39 34.78 25.43 33.82 26.47 34.62 32.02 27.98 30.92))) diff --git a/Data/iris.lsp b/Data/iris.lsp new file mode 100644 index 0000000..1fea4f8 --- /dev/null +++ b/Data/iris.lsp @@ -0,0 +1,2 @@ +(DEF VARNAMES (QUOTE ("Sepal Length" "Sepal Width" "Petal Length" "Petal Width"))) +(DEF IRIS (QUOTE ((5.1 4.9 4.7 4.6 5 5.4 4.6 5 4.4 4.9 5.4 4.8 4.8 4.3 5.8 5.7 5.4 5.1 5.7 5.1 5.4 5.1 4.6 5.1 4.8 5 5 5.2 5.2 4.7 4.8 5.4 5.2 5.5 4.9 5 5.5 4.9 4.4 5.1 5 4.5 4.4 5 5.1 4.8 5.1 4.6 5.3 5 7 6.4 6.9 5.5 6.5 5.7 6.3 4.9 6.6 5.2 5 5.9 6 6.1 5.6 6.7 5.6 5.8 6.2 5.6 5.9 6.1 6.3 6.1 6.4 6.6 6.8 6.7 6 5.7 5.5 5.5 5.8 6 5.4 6 6.7 6.3 5.6 5.5 5.5 6.1 5.8 5 5.6 5.7 5.7 6.2 5.1 5.7 6.3 5.8 7.1 6.3 6.5 7.6 4.9 7.3 6.7 7.2 6.5 6.4 6.8 5.7 5.8 6.4 6.5 7.7 7.7 6 6.9 5.6 7.7 6.3 6.7 7.2 6.2 6.1 6.4 7.2 7.4 7.9 6.4 6.3 6.1 7.7 6.3 6.4 6 6.9 6.7 6.9 5.8 6.8 6.7 6.7 6.3 6.5 6.2 5.9) (3.5 3 3.2 3.1 3.6 3.9 3.4 3.4 2.9 3.1 3.7 3.4 3 3 4 4.4 3.9 3.5 3.8 3.8 3.4 3.7 3.6 3.3 3.4 3 3.4 3.5 3.4 3.2 3.1 3.4 4.1 4.2 3.1 3.2 3.5 3.6 3 3.4 3.5 2.3 3.2 3.5 3.8 3 3.8 3.2 3.7 3.3 3.2 3.2 3.1 2.3 2.8 2.8 3.3 2.4 2.9 2.7 2 3 2.2 2.9 2.9 3.1 3 2.7 2.2 2.5 3.2 2.8 2.5 2.8 2.9 3 2.8 3 2.9 2.6 2.4 2.4 2.7 2.7 3 3.4 3.1 2.3 3 2.5 2.6 3 2.6 2.3 2.7 3 2.9 2.9 2.5 2.8 3.3 2.7 3 2.9 3 3 2.5 2.9 2.5 3.6 3.2 2.7 3 2.5 2.8 3.2 3 3.8 2.6 2.2 3.2 2.8 2.8 2.7 3.3 3.2 2.8 3 2.8 3 2.8 3.8 2.8 2.8 2.6 3 3.4 3.1 3 3.1 3.1 3.1 2.7 3.2 3.3 3 2.5 3 3.4 3) (1.4 1.4 1.3 1.5 1.4 1.7 1.4 1.5 1.4 1.5 1.5 1.6 1.4 1.1 1.2 1.5 1.3 1.4 1.7 1.5 1.7 1.5 1 1.7 1.9 1.6 1.6 1.5 1.4 1.6 1.6 1.5 1.5 1.4 1.5 1.2 1.3 1.4 1.3 1.5 1.3 1.3 1.3 1.6 1.9 1.4 1.6 1.4 1.5 1.4 4.7 4.5 4.9 4 4.6 4.5 4.7 3.3 4.6 3.9 3.5 4.2 4 4.7 3.6 4.4 4.5 4.1 4.5 3.9 4.8 4 4.9 4.7 4.3 4.4 4.8 5 4.5 3.5 3.8 3.7 3.9 5.1 4.5 4.5 4.7 4.4 4.1 4 4.4 4.6 4 3.3 4.2 4.2 4.2 4.3 3 4.1 6 5.1 5.9 5.6 5.8 6.6 4.5 6.3 5.8 6.1 5.1 5.3 5.5 5 5.1 5.3 5.5 6.7 6.9 5 5.7 4.9 6.7 4.9 5.7 6 4.8 4.9 5.6 5.8 6.1 6.4 5.6 5.1 5.6 6.1 5.6 5.5 4.8 5.4 5.6 5.1 5.1 5.9 5.7 5.2 5 5.2 5.4 5.1) (0.2 0.2 0.2 0.2 0.2 0.4 0.3 0.2 0.2 0.1 0.2 0.2 0.1 0.1 0.2 0.4 0.4 0.3 0.3 0.3 0.2 0.4 0.2 0.5 0.2 0.2 0.4 0.2 0.2 0.2 0.2 0.4 0.1 0.2 0.2 0.2 0.2 0.1 0.2 0.2 0.3 0.3 0.2 0.6 0.4 0.3 0.2 0.2 0.2 0.2 1.4 1.5 1.5 1.3 1.5 1.3 1.6 1 1.3 1.4 1 1.5 1 1.4 1.3 1.4 1.5 1 1.5 1.1 1.8 1.3 1.5 1.2 1.3 1.4 1.4 1.7 1.5 1 1.1 1 1.2 1.6 1.5 1.6 1.5 1.3 1.3 1.3 1.2 1.4 1.2 1 1.3 1.2 1.3 1.3 1.1 1.3 2.5 1.9 2.1 1.8 2.2 2.1 1.7 1.8 1.8 2.5 2 1.9 2.1 2 2.4 2.3 1.8 2.2 2.3 1.5 2.3 2 2 1.8 2.1 1.8 1.8 1.8 2.1 1.6 1.9 2 2.2 1.5 1.4 2.3 2.4 1.8 1.8 2.1 2.4 2.3 1.9 2.3 2.5 2.3 1.9 2 2.3 1.8)))) diff --git a/Data/leukemia.lsp b/Data/leukemia.lsp new file mode 100644 index 0000000..8dfcd49 --- /dev/null +++ b/Data/leukemia.lsp @@ -0,0 +1,25 @@ +(require "bayes") + +(def wbc-pos (list 2300 750 4300 2600 6000 10500 10000 17000 5400 7000 + 9400 32000 35000 100000 100000 52000 100000)) + +(def transformed-wbc-pos (- (log wbc-pos) (log 10000))) + +(def times-pos (list 65 156 100 134 16 108 121 4 39 143 56 26 22 1 1 5 65)) + +(defun llik-pos (theta) + (let* ((x transformed-wbc-pos) + (y times-pos) + (theta0 (select theta 0)) + (theta1 (select theta 1)) + (t1x (* theta1 x))) + (- (sum t1x) + (* (length x) (log theta0)) + (/ (sum (* y (exp t1x))) + theta0)))) + +(defun lk-sprob (theta) + (let* ((time 52.0) + (x (log 5)) + (mu (* (select theta 0) (exp (- (* (select theta 1) x)))))) + (exp (- (/ time mu))))) diff --git a/Data/metabolism.lsp b/Data/metabolism.lsp new file mode 100644 index 0000000..81f85a4 --- /dev/null +++ b/Data/metabolism.lsp @@ -0,0 +1,2 @@ +(DEF CPK (QUOTE (180 300 520 480 580 440 380 480 520 1040 1360 640 260 360 400 230 300 400))) +(DEF AGE (QUOTE (33 21 19 24 25 32 36 35 36 24 25 44 51 50 52 55 62 57))) diff --git a/Data/oxygen.lsp b/Data/oxygen.lsp new file mode 100644 index 0000000..097a977 --- /dev/null +++ b/Data/oxygen.lsp @@ -0,0 +1,4 @@ +(def ethanol (list .59 .30 .25 .03 .44 .18 .13 .02 .22 .23 .07 .00 .12 .13 .00 .01)) +(def oxygen (list 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4)) +(def sugar (list 1 1 2 2 1 1 2 2 1 1 2 2 1 1 2 2 )) + diff --git a/Data/puromycin.lsp b/Data/puromycin.lsp new file mode 100644 index 0000000..5fd6b44 --- /dev/null +++ b/Data/puromycin.lsp @@ -0,0 +1,24 @@ +(require "nonlin") + +(def x1 (list 0.02 0.02 0.06 0.06 .11 .11 .22 .22 .56 .56 1.1 1.1)) + +(def x2 (list 0.02 0.02 0.06 0.06 .11 .11 .22 .22 .56 .56 1.1)) + +(def y1 (list 76 47 97 107 123 139 159 152 191 201 207 200)) + +(def y2 (list 67 51 84 86 98 115 131 124 144 158 160)) + +(defun f1 (theta) + "The Michaelis-Menten function for the velocity of an enzymatic reaction +as a function of the substrate concentration. THETA is a parameter +vector of length 2 consisting of the asymptotic velocity and the +concentration at which half the asymptotic velocity is attained." + (/ (* (select theta 0) x1) (+ (select theta 1) x1))) + +(defun f2 (theta) + "The Michaelis-Menten function for the velocity of an enzymatic reaction +as a function of the substrate concentration. THETA is a parameter +vector of length 2 consisting of the asymptotic velocity and the +concentration at which half the asymptotic velocity is attained." + (/ (* (select theta 0) x2) (+ (select theta 1) x2))) + diff --git a/Data/randu.lsp b/Data/randu.lsp new file mode 100644 index 0000000..387f673 --- /dev/null +++ b/Data/randu.lsp @@ -0,0 +1 @@ +(DEF RANDU (QUOTE ((0.044495 0.82244 0.322291 0.393595 0.309097 0.826368 0.729424 0.317649 0.599793 0.647603 0.547048 0.529873 0.90804 0.835195 0.068696 0.984329 0.945783 0.017137 0.772506 0.49308 0.919386 0.964342 0.864672 0.786249 0.123862 0.990535 0.455714 0.345516 0.482433 0.0631 0.494563 0.386052 0.156384 0.99985 0.585455 0.361887 0.350248 0.126752 0.812634 0.369723 0.437286 0.771568 0.697878 0.826174 0.530293 0.968455 0.415824 0.793458 0.622709 0.748484 0.392119 0.32851 0.425048 0.391111 0.409372 0.230546 0.021631 0.011576 0.345928 0.562056 0.47264 0.859244 0.672445 0.31824 0.486482 0.701881 0.831292 0.619876 0.287463 0.670872 0.623757 0.804632 0.803778 0.94237 0.730063 0.79181 0.300808 0.629387 0.487203 0.09553 0.584738 0.259822 0.049581 0.861351 0.901482 0.215425 0.057474 0.301331 0.655918 0.5067 0.938298 0.90252 0.076441 0.258743 0.96569 0.783897 0.949827 0.283024 0.201405 0.576739 0.551408 0.110096 0.44502 0.203431 0.895558 0.858251 0.316456 0.929709 0.431499 0.313108 0.596309 0.065349 0.309409 0.593143 0.948994 0.688282 0.341853 0.776151 0.153704 0.767158 0.785514 0.861648 0.968176 0.057338 0.068251 0.444216 0.750276 0.145329 0.586459 0.472772 0.962394 0.016658 0.697745 0.470791 0.683648 0.522175 0.033916 0.592453 0.254907 0.117803 0.25928 0.889736 0.181619 0.25272 0.399261 0.16544 0.41946 0.780983 0.864323 0.787156) (0.155732 0.873416 0.648545 0.826873 0.92659 0.30854 0.741526 0.393468 0.846041 0.281525 0.94879 0.348011 0.013456 0.814513 0.275943 0.927687 0.689675 0.166494 0.282393 0.943686 0.618783 0.025198 0.711721 0.961377 0.810826 0.706806 0.020492 0.800801 0.160464 0.488463 0.180498 0.482467 0.276557 0.198618 0.129442 0.743469 0.897698 0.190162 0.245063 0.248908 0.268675 0.821389 0.217688 0.623633 0.852871 0.569763 0.696233 0.429293 0.75561 0.903503 0.082637 0.211696 0.233427 0.035974 0.849729 0.743487 0.664288 0.687896 0.75754 0.587138 0.353742 0.982364 0.343048 0.103248 0.552006 0.597679 0.05836 0.029152 0.057 0.302992 0.432338 0.752854 0.778307 0.001763 0.630651 0.407259 0.637073 0.408029 0.789276 0.909727 0.176853 0.480486 0.49643 0.071937 0.260386 0.739384 0.797941 0.90506 0.227307 0.591236 0.101057 0.245249 0.887802 0.786332 0.35169 0.824439 0.727198 0.134077 0.860104 0.911462 0.696489 0.601132 0.150031 0.64847 0.963804 0.917374 0.206234 0.207676 0.001802 0.814661 0.4955 0.893404 0.386023 0.023418 0.136076 0.314449 0.679153 0.15203 0.590536 0.75176 0.776249 0.57405 0.257096 0.846421 0.085886 0.448217 0.334354 0.732954 0.922249 0.996288 0.334478 0.742936 0.483157 0.163685 0.619823 0.80392 0.789033 0.787949 0.337993 0.658675 0.957802 0.400012 0.130337 0.029737 0.190735 0.783277 0.988879 0.854271 0.844219 0.415515) (0.533939 0.838542 0.990648 0.418881 0.777664 0.413932 0.884338 0.501968 0.678107 0.860718 0.769314 0.319211 0.90838 0.370327 0.037394 0.707165 0.626002 0.844727 0.741801 0.224398 0.438229 0.47211 0.488282 0.692023 0.750198 0.326013 0.021528 0.695158 0.620887 0.36288 0.631916 0.420333 0.251881 0.193051 0.507559 0.203826 0.233957 0.000203 0.156666 0.165943 0.676477 0.984216 0.025225 0.306233 0.344595 0.702484 0.434983 0.434638 0.929275 0.684661 0.966753 0.313584 0.575129 0.695843 0.414026 0.386009 0.791052 0.023192 0.431892 0.464327 0.868689 0.16099 0.006286 0.75533 0.933698 0.269141 0.868532 0.596032 0.754833 0.7801 0.98021 0.275437 0.435841 0.529245 0.213333 0.317265 0.115167 0.783687 0.350829 0.598596 0.798474 0.544515 0.532351 0.679465 0.448975 0.49748 0.27038 0.718384 0.460576 0.987116 0.16166 0.348813 0.638839 0.389299 0.418931 0.89156 0.814741 0.257241 0.347981 0.278116 0.216269 0.615928 0.895009 0.059942 0.722801 0.779985 0.389302 0.878674 0.127325 0.06999 0.606222 0.772282 0.53145 0.802219 0.275507 0.692158 0.998243 0.926825 0.159884 0.606141 0.587872 0.689467 0.828997 0.562486 0.901061 0.691361 0.253643 0.089762 0.255363 0.722781 0.345322 0.307697 0.61924 0.744991 0.566103 0.123949 0.428958 0.395616 0.733798 0.891827 0.413294 0.39245 0.14745 0.903937 0.551055 0.210702 0.158136 0.09678 0.286411 0.408684)))) diff --git a/Data/stackloss.lsp b/Data/stackloss.lsp new file mode 100644 index 0000000..7383b97 --- /dev/null +++ b/Data/stackloss.lsp @@ -0,0 +1,4 @@ +(DEF LOSS (QUOTE (42 37 37 28 18 18 19 20 15 14 14 13 11 12 8 7 8 8 9 15 15))) +(DEF AIR (QUOTE (80 80 75 62 62 62 62 62 58 58 58 58 58 58 50 50 50 50 50 56 70))) +(DEF TEMP (QUOTE (27 27 25 24 22 23 24 24 23 18 18 17 18 19 18 18 19 19 20 20 20))) +(DEF CONC (QUOTE (89 88 90 87 87 87 93 93 87 80 89 88 82 93 89 86 72 79 80 82 91))) diff --git a/Data/tutorial.lsp b/Data/tutorial.lsp new file mode 100644 index 0000000..5499c51 --- /dev/null +++ b/Data/tutorial.lsp @@ -0,0 +1,35 @@ +; Section 3.1 +(def purchases (list 0 2 5 0 3 1 8 0 3 1 1 9 2 4 0 2 9 3 0 1 9 8)) + +; Section 3.2 +(def precipitation (list .77 1.74 .81 1.20 1.95 1.20 .47 1.43 3.37 2.20 3.30 3.09 1.51 2.10 .52 1.62 1.31 .32 .59 .81 2.81 1.87 1.18 1.35 4.75 2.48 .96 1.89 .90 2.05)) + +(def urban (list 184 196 217 284 184 236 189 206 179 170 205 190 204 330 217 242 222 242 249 241)) +(def rural (list 166 146 144 204 158 143 158 180 223 194 194 175 171 155 143 145 131 181 148 144 220 129)) + +; Section 3.3 +(def hc '(.5 .46 .41 .44 .72 .83 .38 .60 .83 .34 .37 .87 .65 .48 .51 .47 .56 .51 .57 .36 .52 .58 .47 .65 .41 .39 .55 .64 .38 .50 .73 .57 .41 1.02 1.10 .43 .41 .41 .52 .70 .52 .51 .49 .61 .46 .55)) +(def co '(5.01 8.60 4.95 7.51 14.59 11.53 5.21 9.62 15.13 3.95 4.12 19.00 11.20 3.45 4.10 4.74 5.36 5.69 6.02 2.03 6.78 6.02 5.22 14.67 4.42 7.24 12.30 7.98 4.10 12.10 14.97 5.04 3.38 23.53 22.92 3.81 1.85 2.26 4.29 14.93 6.35 5.79 4.62 8.43 3.99 7.47)) + +; Section 6.1 +(def iron (list 61 175 111 124 130 173 169 169 160 224 257 333 199)) +(def aluminum (list 13 21 24 23 64 38 33 61 39 71 112 88 54)) +(def absorption (list 4 18 14 18 26 26 21 30 28 36 65 62 40)) + +(def strength (list 14.7 48.0 25.6 10.0 16.0 16.8 20.7 38.8 16.9 27.0 16.0 24.9 7.3 12.8)) +(def depth (list 8.9 36.6 36.8 6.1 6.9 6.9 7.3 8.4 6.5 8.0 4.5 9.9 2.9 2.0)) +(def water (list 31.5 27.0 25.9 39.1 39.2 38.3 33.9 33.8 27.9 33.1 26.3 37.8 34.6 36.4)) + +; Section 6.2 +(def hardness (list 45 55 61 66 71 71 81 86 53 60 64 68 79 81 56 68 75 83 88 59 71 80 82 89 51 59 65 74 81 86)) +(def tensile-strength (list 162 233 232 231 231 237 224 219 203 189 210 210 196 180 200 173 188 161 119 161 151 165 151 128 161 146 148 144 134 127)) +(def abrasion-loss (list 372 206 175 154 136 112 55 45 221 166 164 113 82 32 228 196 128 97 64 249 219 186 155 114 341 340 284 267 215 148)) + +(def yield (list 7.9 9.2 10.5 11.2 12.8 13.3 12.1 12.6 14.0 9.1 10.8 12.5 8.1 8.6 10.1 11.5 12.7 13.7 13.7 14.4 15.5 11.3 12.5 14.5 15.3 16.1 17.5 16.6 18.5 19.2 18.0 20.8 21 17.2 18.4 18.9 )) +(def density (list 1 1 1 2 2 2 3 3 3 4 4 4 1 1 1 2 2 2 3 3 3 4 4 4 1 1 1 2 2 2 3 3 3 4 4 4)) +(def variety (list 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3)) + +; Section 6.5 +(def travel-space (list 12.8 12.9 12.9 13.6 14.5 14.6 15.1 17.5 19.5 20.8)) +(def separation (list 5.5 6.2 6.3 7.0 7.8 8.3 7.1 10.0 10.8 11.0)) + diff --git a/Examples/fstat.lsp b/Examples/fstat.lsp new file mode 100644 index 0000000..4b3a00b --- /dev/null +++ b/Examples/fstat.lsp @@ -0,0 +1,10 @@ +(defun f-statistic (m1 m2) +" +Args: (m1 m2) +Computes the F statistic for testing model m1 within model m2." + (let ((ss1 (send m1 :sum-of-squares)) + (df1 (send m1 :df)) + (ss2 (send m2 :sum-of-squares)) + (df2 (send m2 :df))) + (/ (/ (- ss1 ss2) (- df1 df2)) (/ ss2 df2)))) + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..14ff1f3 --- /dev/null +++ b/Makefile @@ -0,0 +1,76 @@ +.SUFFIXES: .o .lsp + +# +# Modify according to your system's needs for dynamic loading +# +CFLAGS = -O -G 0 -DINTPTR +# +# AKCL directory and executable +# +AKCLDIR=/WAR/usr/users/mikem/Software/Kcl/akcl +AKCL=${AKCLDIR}/unixport/saved_kcl ${AKCLDIR}/unixport/ +# +# EXCL (Allegro) batch command +# +EXCL=/CHAGRIN/usr/users/luke/LS/KCL/ACLS/cl -batch +# +# Directory for Examples and Data -- MUST end in a / if not null +# For now, you have to install the Examples and Data directories by hand. +# +LSLIB=/usr/statlocal/lib/xlispstat/ +# +# Directory for saved_kcls binary +# +KCLSDIR=/CHAGRIN/usr/users/luke/LS/KCL/KCLS/ + +kcl: Makefile saved_kcls + echo "#!/bin/csh -f" > kcls + echo "set KCLSDIR=${KCLSDIR}" >> kcls + echo "setenv LSLIB ${LSLIB}" >> kcls + echo '$${KCLSDIR}saved_kcls $${KCLSDIR}' >> kcls + chmod +x kcls + +excl: Makefile lib/clib.a lib/exclglue.o + echo '(load "defsys") (ls::compile-stats)' | ${EXCL} + sed "s?./?${LSLIB}?" makesys.excl.dist > makesys.excl + cat makesys.excl | ${EXCL} + +saved_kcls: lib/clib.a + echo '(load "defsys") (ls::compile-stats)' | ${AKCL} + cat makesys.kcl | ${AKCL} + +lib/clib.a: + (cd lib; make CFLAGS="${CFLAGS}") + +lib/exclglue.o: + (cd lib; make CFLAGS="${CFLAGS}" exclglue.o) + +clean: + (cd lib; make clean) + rm -f *.o *.fasl kclcmplr + +cleanall: + (cd lib; make cleanall) + rm -f *.o *.fasl kclcmplr saved_kcls kcls cls + +# +# This lets you use 'make objects' to make .o files for changed .lsp +# files for kcl. If you use this approach, use 'cat makesys.kcl | kcl' +# to make the executable. +# + +OBJECTS=bayes.o compound.o dists.o fastmap.o kclglue.o \ + kclpatch.o ladata.o linalg.o lsbasics.o lsfloat.o lsmath.o \ + lsobjects.o lstoplevel.o matrices.o maximize.o nonlin.o \ + regression.o statistics.o + +.lsp.o: + ./kclcmplr ./ $*.lsp $*.lsp S1000 + +kclcmplr: Makefile defsys.lsp lsmacros.lsp lspackages.lsp + rm -f cmpinclude.h + ln -s ${AKCLDIR}/h/cmpinclude.h cmpinclude.h + echo '(load "defsys.lsp") (load "kclpatch.lsp") (load "lsobjects.lsp") (load "lsbasics.lsp") (load "ladata.lsp") (si:save-system "kclcmplr")' | ${AKCL} + + +objects: kclcmplr ${OBJECTS} diff --git a/README b/README new file mode 100644 index 0000000..611ed29 --- /dev/null +++ b/README @@ -0,0 +1,44 @@ +This is Lisp-Stat 1.0 Alpha 1, a first attempt at producing a Common +Lisp version of Lisp-Stat. This version contains NO graphics, but +should implement all the non-graphical facilities of Lisp-Stat. + +The implementation uses C code from XLISP-STAT for linear algebra and +probability distributions, so this code is dependent an a CL's foreign +function interface. At this time, three CL's are supported: AKCL (at +least verision 1-600) for UNIX systems, Franz' Allegro CL for UNIX +systems, and Macintosh CL (version 2.0b1). Separate README files +describe each version + +On A DEC 3100 or 5000 the AKCL version of Lisp-Stat runs about half as +fast as xlispstat on a standard battery of tests if xlispstat is given +an (expand 30) command. I seem to recall that on a sun3 this the AKCL +code and xlispstat code run at about the same speed. I have not yet +confirmed this. If so, then the relative performance of the AKCL +version to xlispstat may be quite hardware-dependent. The Allegro +version on a DEC 5000 is considerably slower and larger than the AKCL +version, but I have not yet figured out how to tune Allegro's memory +management. The Macintosh CL version seems to run at least as fast as +xlispstat on the Macintosh. + +To port this code to another CL, you need to + + Edit defsys.lsp to add any necessary definitions + + Add a top level to lstoplevel.lsp (this is only needed if you + want to recover the history mechanism, which is broken by + shadowing *, etc.) + + Write versions of the lisp and/or C glue files to interface to + the C code in lib. + + Experiment with tuning the memory management to run reasonably + in statistical applications. + +If you do port this code to another CL, please let me know so I can +add it to this distribution. + +Luke Tierney +School of Statistics +University of Minnesota +Minneapolis, MN 55455 +luke@umnstat.stat.umn.edu diff --git a/README.excl b/README.excl new file mode 100644 index 0000000..9031f04 --- /dev/null +++ b/README.excl @@ -0,0 +1,20 @@ +To build the Allegro version, + + Rename all .lsp files to have .lisp extensions + + Edit Makefile and set + + CFLAGS + EXCL + LSDIR + + do 'make excl' + +After building the executable, copy Examples and Data to ${LSLIB}, +saved_kcls to ${KCLSDIR}, and kcls to an appropriate place on your +search path. + +At this point, I have not firgured out how to tune the memory +management in Allagro. If you find good setting for this, you may want +to add them to defsys.lisp. Also please let me know what they are so I +can add them to the distribution. diff --git a/README.kcl b/README.kcl new file mode 100644 index 0000000..6bb2ddd --- /dev/null +++ b/README.kcl @@ -0,0 +1,42 @@ +There are two ways to build the KCL version. The first, and simpler, +approach is to + + Check defsys.lsp to make sure :stat-float-is-double-floatsure + is NOT pushed onto *features* -- just comment out the + appropriate line + + Edit Makefile and set + + CFLAGS + AKCLDIR + KCKSDIR + LSDIR + + do 'make kcl' + +The second approach requires that you + + Rebuild AKCL using the modified versions of c/num_sfun.c and + lsp/numlob.lsp included here. + + Check defsys.lsp to make sure :stat-float-is-double-floatsure + IS pushed onto *features* -- just comment out the appropriate + line if necessary + + Edit Makefile and set + + CFLAGS + AKCLDIR + KCKSDIR + LSDIR + + do 'make kcl' + +The second approach fixes some questionable choices on the handling of +floating point coercion in AKCL and also fixes asin and acos, which I +think are are redefined incorrectly in ACKL. The second approach +produces code that is about 10% faster on a standard set of tests. + +After building the executable, copy Examples and Data to ${LSLIB}, +saved_kcls to ${KCLSDIR}, and kcls to an appropriate place on your +search path. diff --git a/README.mcl b/README.mcl new file mode 100644 index 0000000..0801fa0 --- /dev/null +++ b/README.mcl @@ -0,0 +1,50 @@ +To build Lisp-Stat under Macintosh CL, + + Put the files in a mac folder with the lib, Examples and Data + files in subfolders and rename all .lsp files to have .lisp + endings + + Edit the MPW library specifications in mclglue.lisp if necessary + + Use MPW to build clib.o in the lib folder with the makefile + clib.make + + Start up MCL and from with in MCL + + Load defsys.lisp using the load menu command + + In the listener execute + + (ls::compile-stats) + +This sets up fasl files for all the lisp files. You can then run the system +by + + Starting up MCL + + Loading defsys.lisp with the load menu item + + In the listener executing + + (ls::load-stats) + (ls::use-stats) + +Up to now I have not figured out the right way to write a modified top +level that restores the history mechanism and behaves properly in the +interactive enviroonment. I have also not been able to figure out how +to save an application or image that contains the C code. If anyone +has any hints I would be glad to hear them. Since this part of MCL is +still listed as under development it may be best not to spend too much +time on this until they come out with a proper release. + +The result seems to work but is very unstable on a Mac SE30 with 5M +and system 6.0.7. I don't think the problem is with the C interface +code itself, since it is essentially the same code as for Allegro. I +think the problem is a combination of lack of memory and heap +fragmentation. I have not yet worked out if there ae parameters in mcl +that let you tinker with heap allocation and memory management in +general. If so, these need to be adjusted. More memory would also +help. Finally, it would probably help to write local versions of +calloc/realloc/free that do more heap compacting and garbage +collecting. + diff --git a/bayes.lsp b/bayes.lsp new file mode 100644 index 0000000..26162e4 --- /dev/null +++ b/bayes.lsp @@ -0,0 +1,663 @@ +;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney +;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz +;;;; You may give out copies of this software; for conditions see the file +;;;; COPYING included with this distribution. + +(provide "bayes") + +#+:CLtL2 +(in-package lisp-stat) +#-:CLtL2 +(in-package 'lisp-stat) + +(export '(bayes-model bayes-model-proto bayes-internals)) + +;;;; +;;;; Objects Representing Functions +;;;; + +;; Generic C2 Functions + +(defproto c2-function-proto '(f h num-derivs)) + +(defmeth c2-function-proto :isnew (f &optional (h .001) (num-derivs 0)) + (setf (slot-value 'f) f) + (setf (slot-value 'h) (if (numberp h) (list h h) h)) + (setf (slot-value 'num-derivs) num-derivs)) + +(defmeth c2-function-proto :f (&optional f) + (if f (setf (slot-value 'f) f)) + (slot-value 'f)) + +(defmeth c2-function-proto :grad-h () (first (slot-value 'h))) +(defmeth c2-function-proto :hess-h () (second (slot-value 'h))) +(defmeth c2-function-proto :num-derivs () (slot-value 'num-derivs)) + +(defmeth c2-function-proto :value (x) + (let ((f (send self :f))) + (if (objectp f) + (send f :value x) + (let ((v (funcall f x))) + (if (consp v) (first v) v))))) + +(defmeth c2-function-proto :gradient (x &optional (h (send self :grad-h))) + (let ((f (send self :f))) + (if (objectp f) (send f :gradient x h) (numgrad f x nil h)))) + +(defmeth c2-function-proto :hessian (x &optional (h (send self :hess-h))) + (let ((f (send self :f))) + (if (objectp f) (send f :hessian x h) (numhess f x nil h)))) + +(defmeth c2-function-proto :vals (x &optional (h (send self :hess-h))) + (let ((f (send self :f))) + (if (objectp f) + (send f :vals x h) + (let ((v (funcall f x))) + (if (consp v) + (if (= (length v) 3) + v + (list (first v) (second v) (send self :hessian x h))) + (list v (send self :gradient x h) (send self :hessian x h))))))) + +(defmeth c2-function-proto :vals (x &optional (h (send self :hess-h))) + (let ((f (send self :f))) + (if (objectp f) (send f :vals x h) (numhess f x nil h t)))) + + +;; Scaled C2 Functions + +(defproto scaled-c2-function-proto '(scaling) () c2-function-proto) + +;;**** allow function objects? +(defmeth scaled-c2-function-proto :isnew (f &optional + theta + sigma + (center 0) + (scale 1) + (h 0.001)) + (let* ((value (funcall f theta)) + (num-derivs (if (consp value) (- (length value) 1) -1)) + (sigma-t (if (< 0 num-derivs) (transpose sigma)))) + (labels ((scale (v) + (if v + (case num-derivs + (-1 (/ (- v center) scale)) + (0 (/ (- (first v) center) scale)) + (1 (list (/ (- (first v) center) scale) + (matmult sigma-t (/ (second v) scale)))) + (2 (list (/ (- (first v) center) scale) + (matmult sigma-t (/ (second v) scale)) + (matmult sigma-t (/ (third v) scale) sigma)))))) + (sf (x) (scale (funcall f (ax+y sigma x theta t))))) + (call-next-method #'sf h num-derivs)))) + +;; Tilted C2 Functions +;; **** allow nil values? +(defproto tilt-function-proto '(tilt exptilt) () c2-function-proto) + +(defmeth tilt-function-proto :isnew (&optional f (tilt .1) (h .001)) + (call-next-method f h) + (setf (slot-value 'exptilt) t) + (setf (slot-value 'tilt) tilt)) + +(defmeth tilt-function-proto :tilt (&optional tilt) + (if tilt (setf (slot-value 'tilt) tilt)) + (slot-value 'tilt)) + +(defmeth tilt-function-proto :exptilt (&optional (new nil set)) + (if set (setf (slot-value 'exptilt) new)) + (slot-value 'exptilt)) + +(defmeth tilt-function-proto :value (x) + (let ((f (send self :f)) + (tilt (send self :tilt)) + (exptilt (send self :exptilt))) + (flet ((value (f) + (let ((v (send f :value x))) + (if exptilt v (log v))))) + (* tilt (if (consp f) (apply #'+ (mapcar #'value f)) (value f)))))) + +(defmeth tilt-function-proto :gradient (x &optional (h (send self :grad-h))) + (let ((f (send self :f)) + (tilt (send self :tilt)) + (exptilt (send self :exptilt))) + (flet ((gradient (f) + (if exptilt + (send f :gradient x h) + (let ((v (send f :value x)) + (grad (send f :gradient x h))) + (/ grad v))))) + (* tilt + (if (consp f) (apply #'+ (mapcar #'gradient f)) (gradient f)))))) + +(defmeth tilt-function-proto :hessian (x &optional (h (send self :hess-h))) + (let ((f (send self :f)) + (tilt (send self :tilt)) + (exptilt (send self :exptilt))) + (flet ((hessian (f) + (let* ((vals (send f :vals x h)) + (v (first vals)) + (grad (if exptilt (second vals) (/ (second vals) v))) + (hess (if exptilt (third vals) (/ (third vals) v)))) + (if exptilt hess (- hess (outer-product grad grad)))))) + (* tilt (if (consp f) (apply #'+ (mapcar #'hessian f)) (hessian f)))))) + +(defmeth tilt-function-proto :vals (x &optional (h (send self :hess-h))) + (let ((f (send self :f)) + (tilt (send self :tilt)) + (exptilt (send self :exptilt))) + (flet ((vals (f) + (let ((vals (send f :vals x h))) + (if exptilt + vals + (let* ((v (first vals)) + (grad (/ (second vals) v)) + (hess (- (/ (third vals) v) + (outer-product grad grad)))) + (list (log v) grad hess)))))) + (let ((v (if (consp f) (mapcar #'vals f) (vals f)))) + (* tilt (if (consp f) (apply #'+ v) v)))))) + +;; scaled log posterior prototype + +(defproto scaled-logpost-proto + '(tilt-object init-pars) () scaled-c2-function-proto) + +(defmeth scaled-logpost-proto :isnew (f &optional + theta sigma + (center 0) (scale 1) (h .001)) + (let* ((n (length theta)) + (m (repeat 0 n)) + (m-grad (repeat 0 n)) + (m-hess (- (identity-matrix n))) + (pars (list m m-grad m-hess))) + (call-next-method f theta sigma center scale h) + (setf (slot-value 'init-pars) pars) + (setf (slot-value 'tilt-object) (send tilt-function-proto :new)))) + +(defmeth scaled-logpost-proto :log-laplace (g &optional + (count-limit 2) det-only (h .1)) + (let* ((x (send self :tilt-newton g count-limit)) + (vals (send self :vals x h)) + (gvals (if g (send g :vals x h))) + (hess (if g (+ (third vals) (third gvals)) (third vals))) + (det (- (sum (log (diagonal (first (chol-decomp (- hess))))))))) + (if det-only + det + (if g (+ (first vals) (first gvals) det) (+ (first vals) det))))) + +(defmeth scaled-logpost-proto :tilt-newton (tilt &optional (count-limit 2)) + (let* ((pars (slot-value 'init-pars)) + (mode (first pars)) + (mode-grad (second pars)) + (mode-hess (third pars))) + (flet ((gradhess (x initial) + (let ((gh (if (and initial mode-grad mode-hess) + (list mode-grad mode-hess) + (rest (send self :vals x))))) + (if tilt (+ gh (rest (send tilt :vals x))) gh))) + (newton-step (x gh) (- x (solve (second gh) (first gh))))) + (do* ((count 1 (+ count 1)) + (gradhess (gradhess mode t) (gradhess x nil)) + (x (newton-step mode gradhess) (newton-step x gradhess))) + ((>= count count-limit) x))))) + +(defmeth scaled-logpost-proto :tilt-laplace (g tilt &optional + (exptilt t) maxiter det-only h) + (let ((tilt-object (slot-value 'tilt-object))) + (send tilt-object :exptilt exptilt) + (send tilt-object :f g) + (send tilt-object :tilt tilt) + (send self :log-laplace tilt-object maxiter det-only h))) + +(defmeth scaled-logpost-proto :tilt-mode (g tilt &key (exptilt t) (maxiter 2)) + (let ((tilt-object (slot-value 'tilt-object))) + (send tilt-object :exptilt exptilt) + (send tilt-object :f g) + (send tilt-object :tilt tilt) + (send self :tilt-newton tilt-object maxiter))) + +;;;; +;;;; Bayes Model Prototype +;;;; + +(defproto bayes-model-proto '(bayes-internals)) + +;; initialization methods and constructor function + +(defmeth bayes-model-proto :isnew (logpost mode &key + scale + (derivstep .001) + (verbose t) + (maximize t) + domain) + (send self :set-bayes-internals + logpost mode scale derivstep nil nil t domain) + (if maximize (send self :maximize verbose))) + +(defun bayes-model (logpost mode &rest args &key (quick t) (print t)) +"Args: (logpost mode &key scale derivstep (verbose t) + (quick t) (print t))) +LOGPOST computes the logposterior density. It should return the +function, or a list of the function value and gradient, or a list of +the function value, gradient and Hessian. MODE is an initial guess for +the mode. SCALE and DERIVSTEP are used for numerical derivatives and +scaling. VERBOSE controls printing of iteration information during +optimization, PRINT controls printing of summary information. If QUICK +is T the summary is based on first order approximations." + (let ((m (apply #'send bayes-model-proto :new logpost mode args))) + (if print (send m :display :quick quick)) + m)) + +;; display method + +(defmeth bayes-model-proto :display (&key (quick t)) + (let* ((moments (send self (if quick :1stmoments :moments))) + (means (first moments)) + (stdevs (second moments)) + (p-names (send self :parameter-names))) + (if quick + (format t "~2%First Order Approximations to Posterior Moments:~2%") + (format t "~2%Approximate Posterior Moments:~2%")) + (mapcar #'(lambda (name mu sd) + (format t "~22a ~10g (~a)~%" name mu sd)) + p-names + means + stdevs) + (format t "~%"))) + +(defmeth bayes-model-proto :parameter-names () + (let ((n (length (send self :mode)))) + (mapcar #'(lambda (x) (format nil "Parameter ~d" x)) (iseq 0 (- n 1))))) + +;; implementation-dependent access methods + +(defmeth bayes-model-proto :set-bayes-internals (lp m s h mval ch max dom) + (setf (slot-value 'bayes-internals) + (vector lp m s h mval ch max dom))) + +(defmeth bayes-model-proto :logpost (&optional new) + (let ((internals (slot-value 'bayes-internals))) + (when new + (setf (select internals 0) new) + (send self :needs-maximizing t)) + (select internals 0))) + +(defmeth bayes-model-proto :domain (&optional new) + (let ((internals (slot-value 'bayes-internals))) + (if new (setf (select internals 7) new)) + (select internals 7))) + +(defmeth bayes-model-proto :mode-values (&optional mode mval ch) + (let ((internals (slot-value 'bayes-internals))) + (when mode + (setf (select internals 1) mode) + (setf (select internals 4) mval) + (setf (select internals 5) ch)) + (list (select internals 1) + (select internals 4) + (select internals 5)))) + +(defmeth bayes-model-proto :parameter-scale (&optional new) + (let ((internals (slot-value 'bayes-internals))) + (if new (setf (select internals 2) new)) + (select internals 2))) + +(defmeth bayes-model-proto :parameter-dimension () + (length (select (slot-value 'bayes-internals) 1))) + +(defmeth bayes-model-proto :derivstep () + (select (slot-value 'bayes-internals) 3)) + +(defmeth bayes-model-proto :needs-maximizing (&optional (new nil set)) + (let ((internals (slot-value 'bayes-internals))) + (if set (setf (select internals 6) new)) + (select internals 6))) + +;; Transformation-Related Methods +;; (These should be the only ones needing to be changed to handle +;; an internal parameter transformation; perhaps also :logpost) + +;; **** fix to be more careful about use of functionp +(defun function-list (g &optional n) + (cond + ((or (functionp g) (objectp g)) (list g)) + ((integerp g) + (if (null n) + (list #'(lambda (x) (elt x g))) + (let ((grad (make-array n :initial-element 0)) + (hess (make-array (list n n) :initial-element 0))) + (setf (aref grad g) 1) + (list #'(lambda (x) (list (elt x g) grad hess)))))) + (t (mapcar #'(lambda (x) (car (function-list x n))) g)))) + +(defmeth bayes-model-proto :mode () + (if (send self :needs-maximizing) (send self :maximize)) + (first (send self :mode-values))) + +(defmeth bayes-model-proto :new-mode-guess (new) + (send self :needs-maximizing t) + (send self :mode-values new)) + +(defmeth bayes-model-proto :transformed-logpost () + (if (send self :needs-maximizing) (send self :maximize)) + (let* ((m-values (send self :mode-values)) + (mode (first m-values)) + (mval (second m-values)) + (ch (third m-values)) + (h (send self :derivstep)) + (f (send self :logpost))) + (send scaled-logpost-proto :new f mode ch mval 1 h))) + +;;**** need transformed domain here + +(defmeth bayes-model-proto :transformed-functions (&optional g (c 0) (s 1)) + (if (send self :needs-maximizing) (send self :maximize)) + (let* ((m-values (send self :mode-values)) + (mode (first m-values)) + (mval (second m-values)) + (ch (third m-values)) + (h (send self :derivstep)) + (n (length mode)) + (g (function-list (if g g (iseq n)) n)) + (c (if (numberp c) (repeat c (length g)) c)) + (s (if (numberp s) (repeat s (length g)) s))) + (mapcar #'(lambda (g c s) + (send scaled-c2-function-proto :new g mode ch c s h)) + g c s))) + +;; computing methods + +(defmeth bayes-model-proto :maximize (&optional (verbose 0)) + (let* ((lp (send self :logpost)) + (x (first (send self :mode-values))) + (scale (send self :parameter-scale)) + (h (send self :derivstep)) + (minfo (newtonmax lp x + :scale scale + :derivstep h + :verbose verbose + :return-derivs t)) + (mode (first minfo)) + (mval (second minfo)) + (ch (first (chol-decomp (inverse (- (fourth minfo))))))) + (send self :mode-values mode mval ch) + (send self :needs-maximizing nil) + (send self :check-derivatives verbose))) + +(defmeth bayes-model-proto :check-derivatives (&optional + (verbose 0) + (epsilon .00001)) + (let* ((verbose (if (numberp verbose) (< 0 verbose) verbose)) + (n (send self :parameter-dimension)) + (tlp (send self :transformed-logpost)) + (hess (send tlp :hessian (repeat 0 n))) + (needs-max (send self :needs-maximizing))) + (when (> (max (abs (+ hess (identity-matrix n)))) epsilon) + (if verbose (format t "Adjusting derivatives...~%")) + (let* ((ch (first (chol-decomp (- (inverse hess))))) + (mvals (send self :mode-values)) + (m (matmult (third mvals) ch))) + (send self :mode-values (first mvals) (second mvals) m) + (if (not needs-max) (send self :needs-maximizing nil)) + (if verbose + (let* ((tlp (send self :transformed-logpost)) + (hess (send tlp :hessian (repeat 0 n)))) + (if (> (max (abs (+ hess (identity-matrix n)))) epsilon) + (format t + "Derivatives may not be well-behaved.~%")))))))) + +;; moments + +(defmeth bayes-model-proto :1stmoments (&optional gfuns &key covar) +"Args: (&optional gfuns &key covar) +Computes first order approximations to posterior moments. GFUNS can be +a parameter index, list of indices, a function of the parameters or a +list of such functions. Returns a the list of first order approximate +means and standard deviations if COVAR is NIL. If COVAR is T the +covaraince is appended to the end of the result as well." + (if (send self :needs-maximizing) (send self :maximize)) + (let* ((n (send self :parameter-dimension)) + (x (repeat 0 n)) + (g (send self :transformed-functions gfuns 0 1)) + (grads (apply #'bind-columns + (mapcar #'(lambda (g) (send g :gradient x)) g))) + (mean (mapcar #'(lambda (g) (send g :value x)) g)) + (cov (matmult (transpose grads) grads))) + (if covar + (list mean (sqrt (diagonal cov)) cov) + (list mean (sqrt (diagonal cov)))))) + +(defmeth bayes-model-proto :mgfmoments (&optional g &key covar + (mgfdel .1) + ((:derivstep h) .1) + (maxiter 2)) + (let* ((moms1 (send self :1stmoments g :covar covar)) + (mean1 (first moms1)) + (stdev1 (second moms1)) + (cov1 (if covar (third moms1))) + (l-object (send self :transformed-logpost)) + (g-objects (send self :transformed-functions g mean1 stdev1)) + (ldet0 (send l-object :log-laplace nil maxiter t h))) + (labels ((lapdet (g tilt) + (- (send l-object :tilt-laplace g tilt t maxiter t h) ldet0)) + (moms2 (m s g) + (let ((ldet1 (lapdet g mgfdel)) + (ldet2 (lapdet g (- mgfdel)))) + (list (+ m (* s (/ (- ldet1 ldet2) (* 2 mgfdel)))) + (* s (sqrt (+ 1 (/ (+ ldet1 ldet2) (^ mgfdel 2)))))))) + (covar (g mean-sd) + (let* ((mu (first mean-sd)) + (sd (second mean-sd)) + (cov (diagonal (^ sd 2))) + (var1 (^ stdev1 2)) + (var (^ sd 2)) + (rvdiff (/ (- var var1) var)) + (tilt mgfdel) + (2tilt2 (* 2 (^ tilt 2))) + (negtilt (- tilt))) + (dotimes (i (length g) cov) + (dotimes (j i) + (let* ((g (select g (list i j))) + (rvdi (select rvdiff i)) + (rvdj (select rvdiff j)) + (sdi (select sd i)) + (sdj (select sd j)) + (ldt1 (lapdet g tilt)) + (ldt2 (lapdet g negtilt)) + (del2 (/ (+ ldt1 ldt2) 2tilt2)) + (d (- del2 (* 0.5 rvdi) (* 0.5 rvdj))) + (c (+ (aref cov1 i j) (* d sdi sdj)))) + (setf (aref cov i j) c) + (setf (aref cov j i) c))))))) + (let ((mean-sd (transpose (mapcar #'moms2 mean1 stdev1 g-objects)))) + (if covar + (append mean-sd (list (covar g-objects mean-sd))) + mean-sd))))) + +(defmeth bayes-model-proto :fullmoments (&optional g &key covar + ((:derivstep h) .1) + (maxiter 2)) + (let* ((moms1 (send self :1stmoments g)) + (mean1 (first moms1)) + (stdev1 (second moms1)) + (l-object (send self :transformed-logpost)) + (g-objects (send self :transformed-functions g 0 mean1)) + (loglap0 (send l-object :log-laplace nil maxiter nil h))) + (labels ((loglap (g tilt) + (- (send l-object :tilt-laplace g tilt nil maxiter nil h) + loglap0)) + (moms2 (g mu) + (let ((mu1 (exp (loglap g 1.0))) + (mu2 (exp (loglap g 2.0)))) + (* mu (list mu1 (sqrt (- mu2 (^ mu1 2))))))) + (covar (g mean-sd) + (let* ((mu (/ (first mean-sd) mean1)) + (sd (second mean-sd)) + (cov (diagonal (^ sd 2)))) + (dotimes (i (length g) cov) + (dotimes (j i) + (let* ((g (select g (list i j))) + (muij (exp (loglap g 1.0))) + (mui (select mu i)) + (muj (select mu j)) + (mu1i (select mean1 i)) + (mu1j (select mean1 j)) + (c (* (- muij (* mui muj)) mu1i mu1j))) + (setf (aref cov i j) c) + (setf (aref cov j i) c))))))) + (let ((mean-sd (transpose (mapcar #'moms2 g-objects mean1)))) + (if covar + (append mean-sd (list (covar g-objects mean-sd))) + mean-sd))))) + +(defmeth bayes-model-proto :2ndmoments (&rest args) + (apply #'send self :mgfmoments args)) + +(defmeth bayes-model-proto :moments (&rest args) +"Args: (&optional gfuns &key covar) +Computes second order approximations to posterior moments. GFUNS can be +a parameter index, list of indices, a function of the parameters or a +list of such functions. Returns a the list of second order approximate +means and standard deviations if COVAR is NIL. If COVAR is T the +covaraince is appended to the end of the result as well." + (apply #'send self :2ndmoments args)) + +;; margins + +(defproto laplace-margin-proto '(logpost g x val i j a grad gval lu h)) + +(defmeth laplace-margin-proto :isnew (logpost g n k h) + (setf (slot-value 'logpost) logpost) + (setf (slot-value 'g) g) + (setf (slot-value 'x) (repeat 0 (+ n k))) + (setf (slot-value 'i) (iseq n)) + (setf (slot-value 'j) (+ n (iseq k))) + (setf (slot-value 'a) + (make-array (list (+ n k) (+ n k)) :initial-element 0)) + (setf (slot-value 'h) h) + (send self :adjust-internals t)) + +(defmeth laplace-margin-proto :adjust-internals (&optional initial) + (let* ((logpost (slot-value 'logpost)) + (g (slot-value 'g)) + (i (slot-value 'i)) + (j (slot-value 'j)) + (x (slot-value 'x)) + (a (slot-value 'a)) + (h (slot-value 'h)) + (y (select x i)) + (lambda (select x j)) + (n (length y)) + (vals (if initial + (list 0 (repeat 0 n) (- (identity-matrix n))) + (send logpost :vals y h))) + (val (first vals)) + (grad (second vals)) + (hess (third vals)) + (gvals (mapcar #'(lambda (x) (send x :vals y h)) g)) + (gval (mapcar #'first gvals)) + (ggrad (mapcar #'second gvals)) + (ghess (mapcar #'third gvals)) + (ggradmat (apply #' bind-columns ggrad))) + (setf (slot-value 'val) val) + (setf (slot-value 'grad) (apply #'+ grad (* lambda ggrad))) + (setf (slot-value 'gval) gval) + (setf (select a i i) (apply #'+ hess (* lambda ghess))) + (setf (select a i j) ggradmat) + (setf (select a j i) (transpose ggradmat)) + (setf (slot-value 'lu) (lu-decomp a)))) + +;; **** test for nonsingularity? +(defmeth laplace-margin-proto :move-to (target) + (let* ((x (slot-value 'x)) + (grad (slot-value 'grad)) + (gval (slot-value 'gval)) + (lu (slot-value 'lu)) + (next-x (- x (lu-solve lu (combine grad (- gval target)))))) + (setf (slot-value 'x) next-x) + (send self :adjust-internals))) + +(defmeth laplace-margin-proto :log-density (&optional profile) + (let ((val (slot-value 'val))) + (if profile + val + (let* ((lu (slot-value 'lu)) + (nonsing (null (fourth lu)))) + (if nonsing + (+ (* -0.5 (sum (log (abs (diagonal (first lu)))))) + val)))))) + +;; ***** fix step choice +;; ***** Cut off at first nil? +(defmeth bayes-model-proto :log-margin1 (g x &key + ((:derivstep h) .05) + (spline t) + profile) + (let* ((moms1 (send self :1stmoments g)) + (mean1 (select (first moms1) 0)) + (stdev1 (select (second moms1) 0)) + (n (send self :parameter-dimension)) + (l-ob (send self :transformed-logpost)) + (g-obs (send self :transformed-functions g mean1 stdev1)) + (xs (/ (- x mean1) stdev1)) + (xlow (coerce (sort-data (select xs (which (<= xs 0)))) 'list)) + (xhigh (coerce (sort-data (select xs (which (> xs 0)))) 'list))) + (flet ((margin (x) + (let ((margin (send laplace-margin-proto :new l-ob g-obs n 1 h))) + (flet ((nextmargin (x) + (send margin :move-to x) + (send margin :log-density profile))) + (mapcar #'nextmargin x))))) + (let* ((ylow (reverse (margin (reverse xlow)))) + (yhigh (margin xhigh)) + (x (append xlow xhigh)) + (y (append ylow yhigh)) + (i (which (mapcar #'numberp y))) + (xi (select x i)) + (yi (select y i)) + (xy (if spline (spline xi yi) (list xi yi)))) + (list (+ mean1 (* stdev1 (first xy))) + (- (second xy) (log stdev1) (* 0.5 (log (* 2 pi))))))))) + +(defmeth bayes-model-proto :margin1 (g x &key + (derivstep .05) + (spline t) + profile) +"Args: (g x &key (:derivstep .05) (spline t) profile) +Computes Laplace approximation to marginal posterior density of G at +points X. G can be an index or a function of the parameter vector. X +is a sequence that should include the modal value of G. If SPLINE is +true the log density is splined. If PROFILE is true, a profile of the +posterior is returned." + (let* ((logmar (send self :log-margin1 g x + :derivstep derivstep + :spline spline + :profile profile))) + (list (first logmar) (exp (second logmar))))) + +;;**** allow domain test function +(defmeth bayes-model-proto :impsample (&optional g &key (n 100) (df 2)) + (let* ((l-ob (send self :transformed-logpost)) + (g-obs (send self :transformed-functions g)) + (k (send self :parameter-dimension)) + (v (chisq-rand n df)) + (z (* (normal-rand (repeat k n)) (sqrt (/ df v)))) + (c (- (log-gamma (/ (+ k df) 2)) + (log-gamma (/ df 2)) + (* (/ k 2) (log (/ df 2)))))) + (flet ((w (z) + (let ((lp (send l-ob :value z)) + (lt (* -0.5 (+ k df) (log (+ 1 (/ (sum (* z z)) df)))))) + (if (realp lp) (exp (- lp lt c)) 0))) + (gvals (z) (mapcar #'(lambda (g) (send g :value z)) g-obs))) + (list (mapcar #'gvals z) (mapcar #'w z))))) + +(defmeth bayes-model-proto :impmoments (&optional g &key (n 100) (df 2)) + (let* ((impsample (send self :impsample g :n n :df df)) + (means (/ (reduce #'+ (* (first impsample) (second impsample))) + (reduce #'+ (second impsample)))) + (x (mapcar #'(lambda (z) (^ (- z means) 2)) (first impsample))) + (vars (/ (reduce #'+ (* x (second impsample))) + (reduce #'+ (second impsample))))) + (list means (sqrt vars)))) diff --git a/cmpinclude.h b/cmpinclude.h new file mode 100644 index 0000000..f7945de --- /dev/null +++ b/cmpinclude.h @@ -0,0 +1,695 @@ + + +/* Begin for cmpinclude */ + + +/* #define SGC */ + + +/* End for cmpinclude */ +/* +(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. +Copying of this file is authorized to users who have executed the true and +proper "License Agreement for Kyoto Common LISP" with SIGLISP. +*/ +#include +#include +#include +#define TRUE 1 +#define FALSE 0 +#ifdef SGC +#define FIRSTWORD short t; char s,m +#define SGC_TOUCH(x) x->d.m=0 +#else +#define FIRSTWORD short t; short m +#define SGC_TOUCH(x) +#endif +#define STSET(type,x,i,val) do{SGC_TOUCH(x);STREF(type,x,i) = (val);} while(0) +#ifndef VOL +#define VOL +#endif +#ifndef COM_LENG +#define COM_LENG +#endif +#ifndef CHAR_SIZE +#define CHAR_SIZE 8 +#endif +typedef int bool; +typedef int fixnum; +typedef float shortfloat; +typedef double longfloat; +typedef unsigned short fatchar; +#define SIGNED_CHAR(x) (((char ) -1) < (char )0 ? (char) x \ + : (x >= (1<<(CHAR_SIZE-1)) ? \ + x - (((int)(1<<(CHAR_SIZE-1))) << 1) \ + : (char ) x)) +typedef union lispunion *object; +typedef union int_object iobject; +union int_object {int i; object o;}; + +#define OBJNULL ((object)NULL) +struct fixnum_struct { + FIRSTWORD; + fixnum FIXVAL; +}; +#define fix(x) (x)->FIX.FIXVAL +#define SMALL_FIXNUM_LIMIT 1024 +extern struct fixnum_struct small_fixnum_table[COM_LENG]; +#define small_fixnum(i) (object)(small_fixnum_table+SMALL_FIXNUM_LIMIT+(i)) + +struct bignum { + FIRSTWORD; + long *big_self; /* bignum body */ + int big_length; /* bignum length */ +}; +#define MP(x) ((GEN)(x)->big.big_self) +struct shortfloat_struct { + FIRSTWORD; + shortfloat SFVAL; +}; +#define sf(x) (x)->SF.SFVAL +struct longfloat_struct { + FIRSTWORD; + longfloat LFVAL; +}; +#define lf(x) (x)->LF.LFVAL +struct character { + FIRSTWORD; + unsigned short ch_code; + unsigned char ch_font; + unsigned char ch_bits; +}; +struct character character_table1[256+128]; +#define character_table (character_table1+128) +#define code_char(c) (object)(character_table+(c)) +#define char_code(x) (x)->ch.ch_code +#define char_font(x) (x)->ch.ch_font +#define char_bits(x) (x)->ch.ch_bits +enum stype { + stp_ordinary, + stp_constant, + stp_special +}; +struct symbol { + FIRSTWORD; + object s_dbind; + int (*s_sfdef)(); +#define s_fillp st_fillp +#define s_self st_self + int s_fillp; + char *s_self; + object s_gfdef; + object s_plist; + object s_hpack; + short s_stype; + short s_mflag; +}; +struct cons { + FIRSTWORD; + object c_cdr; + object c_car; +}; +struct array { + FIRSTWORD; + short a_rank; + short a_adjustable; + int a_dim; + int *a_dims; + object *a_self; + object a_displaced; + short a_elttype; + short a_offset; +}; + + + +struct fat_string { /* vector header */ + FIRSTWORD; + unsigned fs_raw : 24; /* tells if the things in leader are raw */ + unsigned char fs_leader_length; /* leader_Length */ + int fs_dim; /* dimension */ + int fs_fillp; /* fill pointer */ + /* For simple vectors, */ + /* fs_fillp is equal to fs_dim. */ + fatchar *fs_self; /* pointer to the vector Note the leader starts at (int *) *fs_self - fs_leader_length */ +}; + + +struct vector { + FIRSTWORD; + short v_hasfillp; + short v_adjustable; + int v_dim; + int v_fillp; + object *v_self; + object v_displaced; + short v_elttype; + short v_offset; +}; +struct string { + FIRSTWORD; + short st_hasfillp; + short st_adjustable; + int st_dim; + int st_fillp; + char *st_self; + object st_displaced; +}; +struct ustring { + FIRSTWORD; + short ust_hasfillp; + short ust_adjustable; + int ust_dim; + int ust_fillp; + unsigned char + *ust_self; + object ust_displaced; +}; +#define USHORT(x,i) (((unsigned short *)(x)->ust.ust_self)[i]) + +struct bitvector { + FIRSTWORD; + short bv_hasfillp; + short bv_adjustable; + int bv_dim; + int bv_fillp; + char *bv_self; + object bv_displaced; + short bv_elttype; + short bv_offset; +}; +struct fixarray { + FIRSTWORD; + short fixa_rank; + short fixa_adjustable; + int fixa_dim; + int *fixa_dims; + fixnum *fixa_self; + object fixa_displaced; + short fixa_elttype; + short fixa_offset; +}; +struct sfarray { + FIRSTWORD; + short sfa_rank; + short sfa_adjustable; + int sfa_dim; + int *sfa_dims; + shortfloat + *sfa_self; + object sfa_displaced; + short sfa_elttype; + short sfa_offset; +}; +struct lfarray { + FIRSTWORD; + short lfa_rank; + short lfa_adjustable; + int lfa_dim; + int *lfa_dims; + longfloat + *lfa_self; + object lfa_displaced; + short lfa_elttype; + short lfa_offset; +}; + +struct structure { /* structure header */ + FIRSTWORD; + object str_def; /* structure definition (a structure) */ + object *str_self; /* structure self */ +}; + +#define STREF(type,x,i) (*((type *)(((char *)((x)->str.str_self))+(i)))) + +struct cfun { + FIRSTWORD; + object cf_name; + int (*cf_self)(); + object cf_data; +}; + + struct dclosure { /* compiled closure header */ + FIRSTWORD; + int (*dc_self)(); /* entry address */ + object *dc_env; /* environment */ +}; + + struct cclosure { + FIRSTWORD; + + object cc_name; + int (*cc_self)(); + object cc_env; + object cc_data; + object *cc_turbo; +}; + +struct sfun { + FIRSTWORD; + object sfn_name; + int (*sfn_self)(); + object sfn_data; + int sfn_argd; + + }; +struct vfun { + FIRSTWORD; + object vfn_name; + int (*vfn_self)(); + object vfn_data; + unsigned short vfn_minargs; + unsigned short vfn_maxargs; + }; + +struct dummy { + FIRSTWORD; +}; +struct stream { + FIRSTWORD; + FILE *sm_fp; /* file pointer */ + object sm_object0; /* some object */ + object sm_object1; /* some object */ + int sm_int0; /* some int */ + int sm_int1; /* some int */ + char *sm_buffer; /* ptr to BUFSIZE block of storage */ + short sm_mode; /* stream mode */ + /* of enum smmode */ +}; +union lispunion { + struct fixnum_struct + FIX; + struct shortfloat_struct + SF; + struct stream sm; + struct longfloat_struct + LF; + struct character + ch; + struct symbol s; + struct cons c; + struct array a; + struct vector v; + struct string st; + struct ustring ust; + struct bignum big; + struct bitvector + bv; + struct structure + str; + struct cfun cf; + struct cclosure cc; + struct sfun sfn; + struct vfun vfn; + struct dummy d; + struct fat_string fs; + struct dclosure dc; + struct fixarray fixa; + struct sfarray sfa; + struct lfarray lfa; +}; +enum type { + t_cons, + t_start = 0 , /* t_cons, */ + t_fixnum, + t_bignum, + t_ratio, + t_shortfloat, + t_longfloat, + t_complex, + t_character, + t_symbol, + t_package, + t_hashtable, + t_array, + t_vector, + t_string, + t_bitvector, + t_structure, + t_stream, + t_random, + t_readtable, + t_pathname, + t_cfun, + t_cclosure, + t_sfun, + t_gfun, + t_vfun, + t_cfdata, + t_spice, + t_fat_string, + t_dclosure, + t_end, + t_contiguous, + t_relocatable, + t_other +}; +#define type_of(obje) ((enum type)(((object)(obje))->d.t)) +#define endp(obje) endp1(obje) +extern object value_stack[COM_LENG]; +#define vs_org value_stack +object *vs_limit; +object *vs_base; +object *vs_top; +#define vs_push(obje) (*vs_top++ = (obje)) +#define vs_pop (*--vs_top) +#define vs_head vs_top[-1] +#define vs_mark object *old_vs_top = vs_top +#define vs_reset vs_top = old_vs_top +#define vs_check if (vs_top >= vs_limit) \ + vs_overflow(); +#define vs_check_push(obje) \ + (vs_top >= vs_limit ? \ + (object)vs_overflow() : (*vs_top++ = (obje))) +#define check_arg(n) \ + if (vs_top - vs_base != (n)) \ + check_arg_failed(n) +#define MMcheck_arg(n) \ + if (vs_top - vs_base < (n)) \ + too_few_arguments(); \ + else if (vs_top - vs_base > (n)) \ + too_many_arguments() +#define vs_reserve(x) if(vs_base+(x) >= vs_limit) \ + vs_overflow(); +struct bds_bd { + object bds_sym; + object bds_val; +}; +extern struct bds_bd bind_stack[COM_LENG]; +typedef struct bds_bd *bds_ptr; +bds_ptr bds_org; +bds_ptr bds_limit; +bds_ptr bds_top; +#define bds_check \ + if (bds_top >= bds_limit) \ + bds_overflow() +#define bds_bind(sym, val) \ + ((++bds_top)->bds_sym = (sym), \ + bds_top->bds_val = (sym)->s.s_dbind, \ + (sym)->s.s_dbind = (val)) +#define bds_unwind1 \ + ((bds_top->bds_sym)->s.s_dbind = bds_top->bds_val, --bds_top) +typedef struct invocation_history { + object ihs_function; + object *ihs_base; +} *ihs_ptr; +extern struct invocation_history ihs_stack[COM_LENG]; +ihs_ptr ihs_org; +ihs_ptr ihs_limit; +ihs_ptr ihs_top; +#define ihs_check \ + if (ihs_top >= ihs_limit) \ + ihs_overflow() +#define ihs_push(function) \ + (++ihs_top)->ihs_function = (function); \ + ihs_top->ihs_base = vs_base +#define ihs_pop() (ihs_top--) +enum fr_class { + FRS_CATCH, + FRS_CATCHALL, + FRS_PROTECT +}; +struct frame { + jmp_buf frs_jmpbuf; + object *frs_lex; + bds_ptr frs_bds_top; + enum fr_class frs_class; + object frs_val; + ihs_ptr frs_ihs; +}; +typedef struct frame *frame_ptr; +#define alloc_frame_id() alloc_object(t_spice) +extern struct frame frame_stack[COM_LENG]; + +frame_ptr frs_org; +frame_ptr frs_limit; +frame_ptr frs_top; +#define frs_push(class, val) \ + if (++frs_top >= frs_limit) \ + frs_overflow(); \ + frs_top->frs_lex = lex_env;\ + frs_top->frs_bds_top = bds_top; \ + frs_top->frs_class = (class); \ + frs_top->frs_val = (val); \ + frs_top->frs_ihs = ihs_top; \ + setjmp(frs_top->frs_jmpbuf) +#define frs_pop() frs_top-- +bool nlj_active; +frame_ptr nlj_fr; +object nlj_tag; +object *lex_env; +object caar(); +object cadr(); +object cdar(); +object cddr(); +object caaar(); +object caadr(); +object cadar(); +object caddr(); +object cdaar(); +object cdadr(); +object cddar(); +object cdddr(); +object caaaar(); +object caaadr(); +object caadar(); +object caaddr(); +object cadaar(); +object cadadr(); +object caddar(); +object cadddr(); +object cdaaar(); +object cdaadr(); +object cdadar(); +object cdaddr(); +object cddaar(); +object cddadr(); +object cdddar(); +object cddddr(); +#define MMcons(a,d) make_cons((a),(d)) +#define MMcar(x) (x)->c.c_car +#define MMcdr(x) (x)->c.c_cdr +#define CMPcar(x) (x)->c.c_car +#define CMPcdr(x) (x)->c.c_cdr +#define CMPcaar(x) (x)->c.c_car->c.c_car +#define CMPcadr(x) (x)->c.c_cdr->c.c_car +#define CMPcdar(x) (x)->c.c_car->c.c_cdr +#define CMPcddr(x) (x)->c.c_cdr->c.c_cdr +#define CMPcaaar(x) (x)->c.c_car->c.c_car->c.c_car +#define CMPcaadr(x) (x)->c.c_cdr->c.c_car->c.c_car +#define CMPcadar(x) (x)->c.c_car->c.c_cdr->c.c_car +#define CMPcaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car +#define CMPcdaar(x) (x)->c.c_car->c.c_car->c.c_cdr +#define CMPcdadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr +#define CMPcddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr +#define CMPcdddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr +#define CMPcaaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_car +#define CMPcaaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_car +#define CMPcaadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_car +#define CMPcaaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_car +#define CMPcadaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_car +#define CMPcadadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_car +#define CMPcaddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_car +#define CMPcadddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car +#define CMPcdaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_cdr +#define CMPcdaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_cdr +#define CMPcdadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_cdr +#define CMPcdaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_cdr +#define CMPcddaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_cdr +#define CMPcddadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_cdr +#define CMPcdddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_cdr +#define CMPcddddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr +#define CMPfuncall funcall +#define cclosure_call funcall +object simple_lispcall(); +object simple_lispcall_no_event(); +object simple_symlispcall(); +object simple_symlispcall_no_event(); +object CMPtemp; +object CMPtemp1; +object CMPtemp2; +object CMPtemp3; +#define Cnil ((object)&Cnil_body) +#define Ct ((object)&Ct_body) +struct symbol Cnil_body, Ct_body; +object MF(); +object MFnew(); +object MM(); +object Scons; +object siSfunction_documentation; +object siSvariable_documentation; +object siSpretty_print_format; +object Slist; +object keyword_package; +object alloc_object(); +object car(); +object cdr(); +object list(); +object listA(); +object coerce_to_string(); +object elt(); +object elt_set(); +frame_ptr frs_sch(); +frame_ptr frs_sch_catch(); +object make_cclosure(); +object make_cclosure_new(); +object nth(); +object nthcdr(); +object make_cons(); +object append(); +object nconc(); +object reverse(); +object nreverse(); +object number_expt(); +object number_minus(); +object number_negate(); +object number_plus(); +object number_times(); +object one_minus(); +object one_plus(); +object get(); +object getf(); +object putprop(); +object sputprop(); +object remprop(); +object string_to_object(); +object symbol_function(); +object symbol_value(); +object make_fixnum(); +object make_shortfloat(); +object make_longfloat(); +object structure_ref(); +object structure_set(); +object princ(); +object prin1(); +object print(); +object terpri(); +object aref(); +object aset(); +object aref1(); +object aset1(); +void call_or_link(); +object call_proc(); +object call_proc0(); +object call_proc1(); +object call_proc2(); +object ifuncall(); +object ifuncall1(); +object ifuncall2(); +object symbol_name(); +char object_to_char(); +int object_to_int(); +float object_to_float(); +double object_to_double(); +char *object_to_string(); +int FIXtemp; +#define CMPmake_fixnum(x) \ +((((FIXtemp=(x))+1024)&-2048)==0?small_fixnum(FIXtemp):make_fixnum(FIXtemp)) +#define Creturn(v) return((vs_top=vs,(v))) +#define Cexit return((vs_top=vs,0)) +double sin(), cos(), tan(); +object read_byte1(),read_char1(); + +#define fs_leader(ar,i) (((object *)((ar)->fs.fs_self))[-(i+1)]) +#define RPAREN ) +object make_list(); +#ifdef HAVE_ALLOCA +#ifndef alloca +char *alloca(); +#endif +char *alloca_val; +#define ALLOCA_CONS(n) (alloca_val=alloca((n)*sizeof(struct cons))) +#define ON_STACK_CONS(x,y) (alloca_val=alloca(sizeof(struct cons)), on_stack_cons(x,y)) +#define ON_STACK_LIST on_stack_list +#define ON_STACK_LIST_VECTOR on_stack_list_vector +#define ON_STACK_MAKE_LIST on_stack_make_list +object on_stack_cons(); +object on_stack_list(); +object on_stack_list_vector(); +object on_stack_make_list(); +#else +#define ALLOCA_CONS(n) 0 +#define ON_STACK_CONS(x,y) MMcons(x,y) +#define ON_STACK_LIST list +#define ON_STACK_LIST_VECTOR list_vector +#define ON_STACK_MAKE_LIST make_list +#endif + + +struct call_data { object fun; + int argd;}; +struct call_data fcall; +object fcalln(); +object list_vector(); +object MVloc[10]; +#define VARG(min,max) ((min) | (max << 8)) +#define VFUN_NARGS fcall.argd +extern object Cstd_key_defaults[]; +int vfun_wrong_number_of_args(); +int eql(),equal(),eq(); +object sublis1(); +object LVformat(),LVerror(); +#define EQ(x,y) ((x)==(y)) + + + +/* #include "../h/genpari.h"*/ +typedef unsigned long *GEN; +GEN addii(),mulii(),mulsi(),powerii(),shifti(),stoi(),dvmdii(),subii(); +int cmpii(); +#define signe(x) (((GEN)(x))[1]>>24) +#define lg(x) (((GEN)(x))[0]&0xffff) +#define setlg(x,s) (((GEN)(x))[0]=(((GEN)(x))[0]&0xffff0000)+s) +#define lgef(x) (((GEN)(x))[1]&0xffff) +#define setlgef(x,s) (((GEN)(x))[1]=(((GEN)(x))[1]&0xffff0000)+s) + +int in_saved_avma ; +#define ulong unsigned long +/* #define DEBUG_AVMA */ + +#ifdef DEBUG_AVMA +#define save_avma long lvma = (in_saved_avma = 1, avma) +#define restore_avma avma = (in_saved_avma = 0, lvma) +#else +#define save_avma long lvma = avma +#define restore_avma avma = lvma +#endif +unsigned long avma; +GEN gzero; +GEN icopy_x; + +object make_integer(); + /* copy x to y, increasing space by factor of 2 */ + + +GEN otoi(); +/* +object integ_temp; +#define otoi(x) (integ_temp = (x) , (type_of(integ_temp) == t_bignum \ + ? MP(integ_temp) :stoi(fix(integ_temp)))) +*/ + +void isetq_fix(); +#ifdef HAVE_ALLOCA +#define SETQ_II(var,alloc,val) \ + do{GEN _xx =(val) ; \ + int _n = replace_copy1(_xx,var); \ + if(_n) var = replace_copy2(_xx,alloca(_n));}while(0) + +#define SETQ_IO(var,alloc,val) {object _xx =(val) ; \ + int _n = obj_replace_copy1(_xx,var); \ + if(_n) var = obj_replace_copy2(_xx,alloca(_n));} +#define IDECL(a,b,c) ulong b[4];a =(b[0]=0x1010000 +4,b) +#else +GEN setq_io(),setq_ii(); +#define SETQ_IO(x,alloc,val) (x)=setq_io(x,&alloc,val) +#define SETQ_II(x,alloc,val) (x)=setq_ii(x,&alloc,val) +#define IDECL(a,b,c) ulong b[4];a =(b[0]=0x1010000 +4,b);object c +#endif + + +#ifdef __GNUC__ +#define alloca __builtin_alloca +#endif + + diff --git a/compound.lsp b/compound.lsp new file mode 100644 index 0000000..f4eee34 --- /dev/null +++ b/compound.lsp @@ -0,0 +1,210 @@ +;;;; compound -- Compound data and element-wise mapping functions +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. +;;;; + +(provide "compound") + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(in-package lisp-stat-basics) +#-:CLtL2 +(in-package 'lisp-stat-basics) + +(export '(compound-data-p map-elements compound-data-seq + compound-data-length element-seq compound-data-proto)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Internal Support Functions +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Predicate to determine if argument is compound. Most common +;;; non-compound types are checked first. +(defun cmpndp (x) + (declare (inline numberp symbolp stringp consp arrayp array-total-size)) + (cond ((or (numberp x) (symbolp x) (stringp x)) nil) + ((or (consp x) (and (arrayp x) (< 0 (array-total-size x)))) t) + (t (compound-object-p x)))) + +;;; Returns first compound data item in LIST or NIL if there is none. +(defun find-compound-data (list) + (dolist (x list) (if (cmpndp x) (return x)))) + +;;; Checks for a compound element +(defun any-compound-elements (seq) + (cond ((consp seq) (dolist (x seq) (if (cmpndp x) (return x)))) + ((vectorp seq) + (let ((n (length seq))) + (declare (fixnum n)) + (dotimes (i n) + (declare (fixnum i)) + (let ((x (aref seq i))) + (if (cmpndp x) (return x)))))) + (t (error "argument must be a list or vector")))) + + +;;; Returns sequence of data values for X. +(defun compound-data-sequence (x) + (declare (inline consp vectorp arrayp make-array array-total-size)) + (cond + ((or (consp x) (vectorp x)) x) + ((arrayp x) (make-array (array-total-size x) :displaced-to x)) + (t (send x :data-seq)))) + +(defmacro sequence-type (x) `(if (consp ,x) 'list 'vector)) + +;;;; Construct a compound data item to match the shape of the first argument. +(defun make-compound-data (shape sequence) + (let ((n (length (compound-data-sequence shape)))) + (if (/= n (length sequence)) (error "compound data not the same shape")) + (cond + ((consp shape) (if (consp sequence) sequence (coerce sequence 'list))) + ((vectorp shape) + (if (vectorp sequence) sequence (coerce sequence 'vector))) + ((arrayp shape) + (make-array (array-dimensions shape) + :displaced-to (coerce sequence 'vector))) + (t (send shape :make-data sequence))))) + +;;; Make a circular list of one element +(defun make-circle (x) + (declare (inline cons rplacd)) + (let ((x (cons x nil))) + (rplacd x x) + x)) + +;;; Signals an error if X is not compound +(defun check-compound (x) + (if (not (cmpndp x)) (error "not a compound data item - ~a" x))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; MAP-ELEMENTS function +;;; Applies a function to arguments. If all arguments are simple (i. e. +;;; not compound) then MAP-ELEMENTS acts like funcall. Otherwise all +;;; compound arguments must be of the same shape and simple arguments +;;; are treated as if they were compound arguments of the appropriate +;;; shape. This is implemented by replacin all simple arguments by +;;; circular lists of one element. +;;; +;;; This implementation uses FASTMAP, a version of MAP that is assumed +;;; to +;;; +;;; a) work reasonable fast on any combination of lists and vectors +;;; as its arguments +;;; +;;; b) not hang if at least one of its arguments is not a circular +;;; list. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun fixup-map-elements-arglist (args) + (do* ((args args (rest args)) + (x (car args) (car args))) + ((null args)) + (declare (inline car)) + (setf (car args) + (if (cmpndp x) (compound-data-sequence x) (make-circle x))))) + +(defun map-elements (fcn &rest args) +"Args: (fcn &rest args) +Applies FCN elementwise. If no arguments are compound MAP-ELEMENTS +acts like FUNCALL. Compound arguments must all be the same shape. Non +compound arguments, in the presence of compound ones, are treated as +if they were of the same shape as the compound items with constant data +values." + (let ((first-compound (find-compound-data args))) + (cond ((null first-compound) (apply fcn args)) + (t (fixup-map-elements-arglist args) + (let* ((seq (compound-data-sequence first-compound)) + (type (sequence-type seq))) + (make-compound-data first-compound + (apply #'fastmap type fcn args))))))) + +(defun recursive-map-elements (base-fcn fcn &rest args) +"Args: (base-fcn fcn &rest args) +The same idea as MAP-ELEMENTS, except arguments are in a list and the +base and recursive cases can use different functions. Modified to check +for second level of compounding and use base-fcn if there is none." + (let ((first-compound (find-compound-data args))) + (cond ((null first-compound) (apply base-fcn args)) + (t (fixup-map-elements-arglist args) + (let* ((seq (compound-data-sequence first-compound)) + (type (sequence-type seq)) + (f (if (any-compound-elements seq) fcn base-fcn))) + (make-compound-data first-compound + (apply #'fastmap type f args))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Public Predicate and Accessor Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; COMPOUND-DATA-P function +(defun compound-data-p (x) +"Args: (x) +Returns T if X is a compound data item, NIL otherwise." + (cmpndp x)) + +;;; COMPOUND-DATA-SEQ function +(defun compound-data-seq (x) +"Args (x) +Returns data sequence in X." + (check-compound x) + (compound-data-sequence x)) + +;;; COMPOUND-DATA-LENGTH function +(defun compound-data-length (x) +"Args (x) +Returns length of data sequence in X." + (check-compound x) + (length (compound-data-sequence x))) + +;;; ELEMENT-SEQ function +(defun element-list (x) + (cond + ((compound-data-p x) + (let ((x (concatenate 'list (compound-data-seq x)))) ; copies sequence + (cond + ((any-compound-elements x) + (do ((next x (rest next))) + ((not (consp next))) + (setf (first next) (element-list (first next)))) + (do ((result (first x)) + (last (last (first x))) + (next (rest x) (rest next))) + ((not (consp next)) result) + (setf (rest last) (first next)) + (setf last (last (first next))))) + (t x)))) + (t (list x)))) + +(defun element-seq (x) +"Args: (x) +Returns sequence of the elements of compound item X." + (check-compound x) + (let ((seq (compound-data-seq x))) + (if (any-compound-elements seq) (element-list seq) seq))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Compound Data Objects +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defproto compound-data-proto) + +(defmeth compound-data-proto :data-length (&rest args) nil) +(defmeth compound-data-proto :data-seq (&rest args) nil) +(defmeth compound-data-proto :make-data (&rest args) nil) +(defmeth compound-data-proto :select-data (&rest args) nil) + +(defun compound-object-p (x) (kind-of-p x compound-data-proto)) diff --git a/defsys.lsp b/defsys.lsp new file mode 100644 index 0000000..c55e6d3 --- /dev/null +++ b/defsys.lsp @@ -0,0 +1,183 @@ +;;;; defsys -- System setup for CL version of Lisp-Stat +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +;;;; +;;;; CLtL, 2nd Edition, essentially requires that features be keyword +;;;; symbols. To allow for this, the folloing code puts keyword versions +;;;; of all feature symbols on the features list. +;;;; + +#+kcl +(dolist (f *features*) + (if (symbolp f) + (pushnew (intern (symbol-name f) 'keyword) *features*))) + +#-:mcl (require "lspackages") +#-:mcl (require "lsmacros") + +;;;; +;;;; Macintosh CL +;;;; + +#+:mcl (pushnew :CLtL2 *features*) +#+:mcl (def-logical-directory "mcls;" "ccl;:MCLS:") +#+:mcl (setf *break-on-errors* nil) +#+:mcl (set-mac-default-directory "mcls;") +#+:mcl (setf *save-definitions* t) +#+:mcl (defpackage "COMMON-LISP" (:nicknames "CL" "LISP")) +#+:mcl (pushnew :stat-float-is-double-float *features*) +#+:mcl (require :ff) + +;;;; +;;;; AKCL +;;;; + +;#+:kcl (proclaim '(optimize (safety 2) (space 3) (speed 3))) +#+:kcl (setf *break-enable* nil) + +#+:kcl (allocate 'cons 600) +#+:kcl (allocate 'cfun 1000) +#+:kcl (si:allocate-relocatable-pages 100) + +;; **** This feature should only be used if the patches in num_sfun.c +;; **** and numlib.lsp habe been applied to AKCL -- see lsfloat.lsp for +;; **** more details. + +;#+:kcl (pushnew :stat-float-is-double-float *features*) + +;;;; +;;;; EXCL (Allegro) +;;;; + +(setf *read-default-float-format* 'double-float) + +;;;; +;;;; Switch to Lisp-Stat package +;;;; + +#+:mcl (load "lspackages") +#+:mcl (load "lsmacros") + +#+:CLtL2 +(in-package lisp-stat) +#-:CLtL2 +(in-package 'lisp-stat) + +(export '(*default-path* debug nodebug)) + +(defvar *common-lisp-stat-version* "1.0 Alpha 1") + +(defvar *default-path* "./") + +;;;; +;;;; Functions for switching into and out of debug mode +;;;; + +(defun debug () + #+:kcl (setf *break-enable* t) + #+:mcl (setf *break-on-errors* t)) + +(defun nodebug () + #+:kcl (setf *break-enable* nil) + #+:mcl (setf *break-on-errors* nil)) + +;;;; +;;;; MCL definitions +;;;; + +#+:mcl (setf *default-path* ":") + +;;;; +;;;; AKCL definitions +;;;; + +#+:kcl (setf *clibs* + #+:mips "lib/clib.a -lm_G0 -lc_G0" + #-:mips "lib/clib.a -lm -lc") + +;;;; +;;;; EXCL definitions +;;;; + +;;;; +;;;; Compilation and Loading Utilities +;;;; + +(defvar *lsos-files* (list "lsobjects")) + +(defvar *basic-files* + (list #+:kcl "kclpatch" + #+:mcl "mclglue" + #+:excl "exclglue" + "lsbasics" + "lsfloat" + "fastmap" + "compound" + "matrices" + "ladata" + "linalg" + "dists")) + +(defvar *ls-files* + (list "lsmath" +; #-:kcl "help" + "statistics" + "regression" + "nonlin" + "maximize" + "bayes" + "lstoplevel")) + +(defun use-ls-package (name) + (shadowing-import (package-shadowing-symbols name)) + (use-package name)) + +(defun use-stats () + #+:kcl (shadowing-import '(ls::x)) + (use-ls-package 'lisp-stat-object-system) + (use-ls-package 'lisp-stat-basics) + (use-ls-package 'lisp-stat)) + +(defun lispfile (x) + (concatenate 'string x + #+:kcl ".lsp" + #+(or :mcl :excl) ".lisp")) + +(defun load-files (files) + (dolist (f files) (load f :verbose t))) + +(defun compile-load-files (files &optional (load t)) + (dolist (f files) + #+:mcl (format t "compiling ~a~%" f) + #+:excl (load (lispfile f)) + (compile-file f) + (if load (load f)))) + +(defun load-lsos () + (load-files *lsos-files*)) + +(defun load-ls-basics () + (load-lsos) + (load-files *basic-files*) + #+:kcl (if (and (probe-file "kclglue.o") + (probe-file "lib/clib.a")) + (si:faslink "kclglue" *clibs*))) + +(defun load-stats () + (load-ls-basics) + (load-files *ls-files*)) + +(defun compile-lsos () + (compile-load-files *lsos-files*)) + +(defun compile-ls-basics (&optional (compile-all t)) + (if compile-all (compile-lsos) (load-lsos)) + (compile-load-files *basic-files*) + #+:kcl (progn (compile-file "kclglue") + (si:faslink "kclglue" *clibs*))) + +(defun compile-stats (&optional (compile-all t)) + (if compile-all (compile-ls-basics) (load-ls-basics)) + (compile-load-files *ls-files*)) diff --git a/dists.lsp b/dists.lsp new file mode 100644 index 0000000..ac44907 --- /dev/null +++ b/dists.lsp @@ -0,0 +1,257 @@ +;;;; dists -- Lisp-Stat interface to basic probability distribution routines +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(in-package lisp-stat-basics) +#-:CLtL2 +(in-package 'lisp-stat-basics) + +(export '(log-gamma uniform-rand normal-cdf normal-quant normal-dens + normal-rand bivnorm-cdf cauchy-cdf cauchy-quant cauchy-dens + cauchy-rand gamma-cdf gamma-quant gamma-dens gamma-rand + chisq-cdf chisq-quant chisq-dens chisq-rand beta-cdf beta-quant + beta-dens beta-rand t-cdf t-quant t-dens t-rand f-cdf f-quant + f-dens f-rand poisson-cdf poisson-quant poisson-pmf poisson-rand + binomial-cdf binomial-quant binomial-pmf binomial-rand)) + +(defmacro defbaserand (name onefun &rest args) + `(defun ,name (n ,@args) + (let ((result nil)) + (dotimes (i n result) + (declare (fixnum i) (inline ,onefun)) + (setf result (cons (,onefun ,@args) result)))))) + +(defbaserand base-uniform-rand one-uniform-rand) +(defbaserand base-normal-rand one-normal-rand) +(defbaserand base-cauchy-rand one-cauchy-rand) +(defbaserand base-gamma-rand one-gamma-rand a) +(defbaserand base-chisq-rand one-chisq-rand df) +(defbaserand base-beta-rand one-beta-rand a b) +(defbaserand base-t-rand one-t-rand df) +(defbaserand base-f-rand one-f-rand ndf ddf) +(defbaserand base-poisson-rand one-poisson-rand a) +(defbaserand base-binomial-rand one-binomial-rand a b) + +(make-rv-function log-gamma base-log-gamma x) + +(make-rv-function uniform-rand base-uniform-rand n) + +(make-rv-function normal-cdf base-normal-cdf x) +(make-rv-function normal-quant base-normal-quant p) +(make-rv-function normal-dens base-normal-dens x) +(make-rv-function normal-rand base-normal-rand n) +(make-rv-function bivnorm-cdf base-bivnorm-cdf x y r) + +(make-rv-function cauchy-cdf base-cauchy-cdf x) +(make-rv-function cauchy-quant base-cauchy-quant p) +(make-rv-function cauchy-dens base-cauchy-dens x) +(make-rv-function cauchy-rand base-cauchy-rand n) + +(make-rv-function gamma-cdf base-gamma-cdf x a) +(make-rv-function gamma-quant base-gamma-quant p a) +(make-rv-function gamma-dens base-gamma-dens x a) +(make-rv-function gamma-rand base-gamma-rand n a) + +(make-rv-function chisq-cdf base-chisq-cdf x df) +(make-rv-function chisq-quant base-chisq-quant p df) +(make-rv-function chisq-dens base-chisq-dens x df) +(make-rv-function chisq-rand base-chisq-rand n df) + +(make-rv-function beta-cdf base-beta-cdf x a b) +(make-rv-function beta-quant base-beta-quant p a b) +(make-rv-function beta-dens base-beta-dens x a b) +(make-rv-function beta-rand base-beta-rand n a b) + +(make-rv-function t-cdf base-t-cdf x df) +(make-rv-function t-quant base-t-quant p df) +(make-rv-function t-dens base-t-dens x df) +(make-rv-function t-rand base-t-rand n df) + +(make-rv-function f-cdf base-f-cdf x ndf ddf) +(make-rv-function f-quant base-f-quant p ndf ddf) +(make-rv-function f-dens base-f-dens x ndf ddf) +(make-rv-function f-rand base-f-rand n ndf ddf) + +(make-rv-function poisson-cdf base-poisson-cdf x a) +(make-rv-function poisson-quant base-poisson-quant p a) +(make-rv-function poisson-pmf base-poisson-pmf x a) +(make-rv-function poisson-rand base-poisson-rand n a) + +(make-rv-function binomial-cdf base-binomial-cdf x a b) +(make-rv-function binomial-quant base-binomial-quant p a b) +(make-rv-function binomial-pmf base-binomial-pmf x a b) +(make-rv-function binomial-rand base-binomial-rand n a b) + +;;;; +;;;; Documentation +;;;; + +(setf (documentation 'bivnorm-cdf 'function) +"Args: (x y r) +Returns the value of the standard bivariate normal distribution function +with correlation R at (X, Y). Vectorized.") + +(setf (documentation 'normal-cdf 'function) +"Args: (x) +Returns the value of the standard normal distribution function at X. +Vectorized.") + +(setf (documentation 'beta-cdf 'function) +"Args: (x alpha beta) +Returns the value of the Beta(ALPHA, BETA) distribution function at X. +Vectorized.") + +(setf (documentation 'gamma-cdf 'function) +"Args: (x alpha) +Returns the value of the Gamma(alpha, 1) distribution function at X. +Vectorized.") + +(setf (documentation 'chisq-cdf 'function) +"Args: (x df) +Returns the value of the Chi-Square(DF) distribution function at X. Vectorized.") + +(setf (documentation 't-cdf 'function) +"Args: (x df) +Returns the value of the T(DF) distribution function at X. Vectorized.") + +(setf (documentation 'f-cdf 'function) +"Args: (x ndf ddf) +Returns the value of the F(NDF, DDF) distribution function at X. Vectorized.") + +(setf (documentation 'cauchy-cdf 'function) +"Args: (x) +Returns the value of the standard Cauchy distribution function at X. +Vectorized.") + +(setf (documentation 'log-gamma 'function) +"Args: (x) +Returns the log gamma function of X. Vectorized.") + +(setf (documentation 'normal-quant 'function) +"Args (p) +Returns the P-th quantile of the standard normal distribution. Vectorized.") + +(setf (documentation 'cauchy-quant 'function) +"Args (p) +Returns the P-th quantile(s) of the standard Cauchy distribution. Vectorized.") + +(setf (documentation 'beta-quant 'function) +"Args: (p alpha beta) +Returns the P-th quantile of the Beta(ALPHA, BETA) distribution. Vectorized.") + +(setf (documentation 'gamma-quant 'function) +"Args: (p alpha) +Returns the P-th quantile of the Gamma(ALPHA, 1) distribution. Vectorized.") + +(setf (documentation 'chisq-quant 'function) +"Args: (p df) +Returns the P-th quantile of the Chi-Square(DF) distribution. Vectorized.") + +(setf (documentation 't-quant 'function) +"Args: (p df) +Returns the P-th quantile of the T(DF) distribution. Vectorized.") + +(setf (documentation 'f-quant 'function) +"Args: (p ndf ddf) +Returns the P-th quantile of the F(NDF, DDF) distribution. Vectorized.") + +(setf (documentation 'normal-dens 'function) +"Args: (x) +Returns the density at X of the standard normal distribution. Vectorized.") + +(setf (documentation 'cauchy-dens 'function) +"Args: (x) +Returns the density at X of the standard Cauchy distribution. Vectorized.") + +(setf (documentation 'beta-dens 'function) +"Args: (x alpha beta) +Returns the density at X of the Beta(ALPHA, BETA) distribution. Vectorized.") + +(setf (documentation 'gamma-dens 'function) +"Args: (x alpha) +Returns the density at X of the Gamma(ALPHA, 1) distribution. Vectorized.") + +(setf (documentation 'chisq-dens 'function) +"Args: (x alpha) +Returns the density at X of the Chi-Square(DF) distribution. Vectorized.") + +(setf (documentation 't-dens 'function) +"Args: (x alpha) +Returns the density at X of the T(DF) distribution. Vectorized.") + +(setf (documentation 'f-dens 'function) +"Args: (x ndf ddf) +Returns the density at X of the F(NDF, DDF) distribution. Vectorized.") + +(setf (documentation 'uniform-rand 'function) +"Args: (n) +Returns a list of N uniform random variables from the range (0, 1). +Vectorized.") + +(setf (documentation 'normal-rand 'function) +"Args: (n) +Returns a list of N standard normal random numbers. Vectorized.") + +(setf (documentation 'cauchy-rand 'function) +"Args: (n) +Returns a list of N standard Cauchy random numbers. Vectorized.") + +(setf (documentation 't-rand 'function) +"Args: (n df) +Returns a list of N T(DF) random variables. Vectorized.") + +(setf (documentation 'f-rand 'function) +"Args: (n ndf ddf) +Returns a list of N F(NDF, DDF) random variables. Vectorized.") + +(setf (documentation 'gamma-rand 'function) +"Args: (n a) +Returns a list of N Gamma(A, 1) random variables. Vectorized.") + +(setf (documentation 'chisq-rand 'function) +"Args: (n df) +Returns a list of N Chi-Square(DF) random variables. Vectorized.") + +(setf (documentation 'beta-rand 'function) +"Args: (n a b) +Returns a list of N beta(A, B) random variables. Vectorized.") + +(setf (documentation 'binomial-cdf 'function) +"Args (x n p) +Returns value of the Binomial(N, P) distribution function at X. Vectorized.") + +(setf (documentation 'poisson-cdf 'function) +"Args (x mu) +Returns value of the Poisson(MU) distribution function at X. Vectorized.") + +(setf (documentation 'binomial-pmf 'function) +"Args (k n p) +Returns value of the Binomial(N, P) pmf function at integer K. Vectorized.") + +(setf (documentation 'poisson-pmf 'function) +"Args (k mu) +Returns value of the Poisson(MU) pmf function at integer K. Vectorized.") + +(setf (documentation 'binomial-quant 'function) +"Args: (x n p) +Returns x-th quantile (left continuous inverse) of Binomial(N, P) cdf. +Vectorized.") + +(setf (documentation 'poisson-quant 'function) +"Args: (x mu) +Returns x-th quantile (left continuous inverse) of Poisson(MU) cdf. +Vectorized.") + +(setf (documentation 'binomial-rand 'function) +"Args: (k n p) +Returns list of K draws from the Binomial(N, P) distribution. Vectorized.") + +(setf (documentation 'poisson-rand 'function) +"Args: (k mu) +Returns list of K draws from the Poisson(MU) distribution. Vectorized.") diff --git a/exclglue.lsp b/exclglue.lsp new file mode 100644 index 0000000..53bcb92 --- /dev/null +++ b/exclglue.lsp @@ -0,0 +1,402 @@ +;;;; exclglue -- Interface to C library +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +(in-package 'lisp-stat-basics) + +(require :foreign) + +(load "lib/exclglue.o" + :foreign-files '("lib/clib.a") + :system-libraries #+:mips '("m_G0") #-:mips '("m")) + +;;; +;;; FF Macros +;;; + +(defmacro defforfun (name arg-types return-type) + `(ff:defforeign ',name + :arguments ',arg-types + :return-type ,return-type)) + +(defmacro mkdbl (x) `(float ,x 0.d0)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Basic Utilities +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; Callback Value Storage +;;;; + +(defforfun excl_set_integer_value (integer) :void) +(defforfun excl_set_double_value (double-float) :void) + +;;;; +;;;; Storage Allocation Functions +;;;; + +(defun null-ptr-p (p) (= p 0)) +(defun ptr-eq (p q) (= p q)) + +(defforfun la_base_allocate (integer integer) :integer) +(defun la-base-allocate (n m) (la_base_allocate n m)) + +(defforfun la_base_free_alloc (integer) :void) +(defun la-base-free (p) (la_base_free_alloc p)) + +(defforfun la_mode_size (integer) :integer) +(defun la-mode-size (mode) (la_mode_size mode)) + +;;;; +;;;; Callbacks for Internal Storage +;;;; + +(ff:defun-c-callable lisp_la_allocate ((n :signed-long) (m :signed-long)) + (excl_set_integer_value (la-allocate n m))) +(defforfun excl_register_la_allocate (integer) :void) +(multiple-value-bind (ptr index) (ff:register-function 'lisp_la_allocate) + (excl_register_la_allocate index)) + +(ff:defun-c-callable lisp_la_free_alloc ((p :signed-long)) + (la-free p)) +(defforfun excl_register_la_free_alloc (integer) :void) +(multiple-value-bind (ptr index) (ff:register-function 'lisp_la_free_alloc) + (excl_register_la_free_alloc index)) + +;;;; +;;;; Storage Access Functions +;;;; + +(defforfun la_get_integer (integer integer) :integer) +(defun la-get-integer (p i) (la_get_integer p i)) + +(defforfun la_get_double (integer integer) :double-float) +(defun la-get-double (p i) (la_get_double p i)) + +(defforfun la_get_complex_real (integer integer) :double-float) +(defun la-get-complex-real (p i) (la_get_complex_real p i)) + +(defforfun la_get_complex_imag (integer integer) :double-float) +(defun la-get-complex-imag (p i) (la_get_complex_imag p i)) + +(defun la-get-complex (p i) + (complex (la-get-complex-real p i) (la-get-complex-imag p i))) + +(defun la-get-pointer (p i) (la-get-integer p i)) + +;;;; +;;;; Storage Mutation Functions +;;;; + +(defforfun la_put_integer (integer integer integer) :void) +(defun la-put-integer (p i x) (la_put_integer p i x)) + +(defforfun la_put_double (integer integer double-float) :void) +(defun la-put-double (p i x) (la_put_double p i (mkdbl x))) + +(defforfun la_put_complex (integer integer double-float double-float) :void) +(defun la-put-complex (p i x y) (la_put_complex p i (mkdbl x) (mkdbl y))) + +(defun la-put-pointer (p i x) (la-put-integer p i x)) + +;;;; +;;;; XLISP internal error message emulation +;;;; + +(defvar *buf* (make-string 1000)) + +(defun set-buf-char (i c) (setf (elt *buf* i) (code-char c))) + +(defun get-buf (&optional (n (position (code-char 0) *buf*))) + (subseq *buf* 0 n)) + +(ff:defun-c-callable excl-set-buf-char ((n :signed-long) (c :signed-long)) + (set-buf-char n c)) +(defforfun excl_register_set_buf_char (integer) :void) +(multiple-value-bind (ptr index) (ff:register-function 'excl-set-buf-char) + (excl_register_set_buf_char index)) + +(ff:defun-c-callable excl-print-buffer ((n :signed-long) (type :signed-long)) + (case type + (0 (princ (get-buf n))) + (1 (error (get-buf n)))) + n) +(defforfun excl_register_print_buffer (integer) :void) +(multiple-value-bind (ptr index) (ff:register-function 'excl-print-buffer) + (excl_register_print_buffer index)) + +(defforfun stdputstr (string) :void) +(defforfun xlfail (string) :void) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Lisp Interfaces to Linear Algebra Routines +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; Cholesky Decomposition +;;;; + +(defforfun excl_chol_decomp_front (integer integer integer) :integer) +(defun chol-decomp-front (x y z) (excl_chol_decomp_front x y z)) + +;;;; +;;;; LU Decomposition +;;;; + +(defforfun excl_lu_decomp_front + (integer integer integer integer integer) + :integer) +(defun lu-decomp-front (x y z u v) (excl_lu_decomp_front x y z u v)) +(defforfun excl_lu_solve_front + (integer integer integer integer integer) + :integer) +(defun lu-solve-front (x y z u v) (excl_lu_solve_front x y z u v)) +(defforfun excl_lu_inverse_front + (integer integer integer integer integer integer) + :integer) +(defun lu-inverse-front (x y z u v w) (excl_lu_inverse_front x y z u v w)) + +;;;; +;;;; SV Decomposition +;;;; + +(defforfun excl_sv_decomp_front + (integer integer integer integer integer) + :integer) +(defun sv-decomp-front (x y z u v) (excl_sv_decomp_front x y z u v)) + +;;;; +;;;; QR Decomposition +;;;; + +(defforfun excl_qr_decomp_front + (integer integer integer integer integer integer) + :integer) +(defun qr-decomp-front (x y z u v w) (excl_qr_decomp_front x y z u v w)) + +;;;; +;;;; Estimate of Condition Number for Lower Triangular Matrix +;;;; + +(defforfun excl_rcondest_front (integer integer) :double-float) +(defun rcondest-front (x y) (excl_rcondest_front x y)) + +;;;; +;;;; Make Rotation Matrix +;;;; + +(defforfun excl_make_rotation_front + (integer integer integer integer integer double-float) + :integer) +(defun make-rotation-front (x y z u v w) + (excl_make_rotation_front x y z u v (mkdbl w))) + +;;;; +;;;; Eigenvalues and Eigenvectors +;;;; + +(defforfun excl_eigen_front + (integer integer integer integer integer) + :integer) +(defun eigen-front (x y z u v) (excl_eigen_front x y z u v)) + +;;;; +;;;; Spline Interpolation +;;;; + +(defforfun excl_range_to_rseq + (integer integer integer integer) + :integer) +(defun la-range-to-rseq (x y z u) (excl_range_to_rseq x y z u)) +(defforfun excl_spline_front + (integer integer integer integer integer integer integer) + :integer) +(defun spline-front (x y z u v w a) (excl_spline_front x y z u v w a)) + +;;;; +;;;; Kernel Density Estimators and Smoothers +;;;; + +(defforfun excl_kernel_dens_front + (integer integer double-float integer integer integer integer) + :integer) +(defun kernel-dens-front (x y z u v w a) + (excl_kernel_dens_front x y (mkdbl z) u v w a)) + +(defforfun excl_kernel_smooth_front + (integer integer integer double-float integer integer integer integer) + :integer) +(defun kernel-smooth-front (x y z u v w a b) + (excl_kernel_smooth_front x y z (mkdbl u) v w a b)) + +;;;; +;;;; Lowess Smoother Interface +;;;; + +(defforfun excl_base_lowess_front + (integer integer integer double-float integer double-float + integer integer integer) + :integer) +(defun base-lowess-front (x y z u v w a b c) + (excl_base_lowess_front x y z (mkdbl u) v (mkdbl w) a b c)) + +;;;; +;;;; FFT +;;;; + +(defforfun excl_fft_front (integer integer integer integer) :integer) +(defun fft-front (x y z u) (excl_fft_front x y z u)) + +;;;; +;;;; Maximization and Numerical Derivatives +;;;; + +(ff:defun-c-callable excl-maximize-callback ((n :signed-long) + (px :signed-long) + (pfval :signed-long) + (pgrad :signed-long) + (phess :signed-long) + (pderivs :signed-long)) + (maximize-callback n px pfval pgrad phess pderivs)) +(defforfun excl_register_maximize_callback (integer) :void) +(multiple-value-bind (ptr index) (ff:register-function 'excl-maximize-callback) + (excl_register_maximize_callback index)) + +(defforfun excl_numgrad_front + (integer integer integer double-float integer) + :integer) +(defun numgrad-front (x y z u v) (excl_numgrad_front x y z (mkdbl u) v)) + +(defforfun excl_numhess_front + (integer integer integer integer integer double-float integer) + :integer) +(defun numhess-front (x y z u v w a) + (excl_numhess_front x y z u v (mkdbl w) a)) + +(defforfun excl_minfo_maximize + (integer integer integer integer integer integer) + :integer) +(defun base-minfo-maximize (x y z u v w) (excl_minfo_maximize x y z u v w)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Probability Distributions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; C-Callable Uniform Generator +(ff:defun-c-callable uni () (excl_set_double_value (random 1.d0))) +(defforfun excl_register_uni (integer) :void) +(multiple-value-bind (ptr index) (ff:register-function 'uni) + (excl_register_uni index)) + +(defforfun excl_unirand () :double-float) +(defun one-uniform-rand () (excl_unirand)) + +;; Log-gamma function +(defforfun excl_gamma (double-float) :double-float) +(defun base-log-gamma (x) (excl_gamma (mkdbl x))) + +;; normal distribution +(defforfun excl_normalcdf (double-float) :double-float) +(defun base-normal-cdf (x) (excl_normalcdf (mkdbl x))) +(defforfun excl_normalquant (double-float) :double-float) +(defun base-normal-quant (x) (excl_normalquant (mkdbl x))) +(defforfun excl_normaldens (double-float) :double-float) +(defun base-normal-dens (x) (excl_normaldens (mkdbl x))) +(defforfun excl_normalrand () :double-float) +(defun one-normal-rand () (excl_normalrand)) +(defforfun excl_bnormcdf (double-float double-float double-float) :double-float) +(defun base-bivnorm-cdf (x y z) (excl_bnormcdf (mkdbl x) (mkdbl y) (mkdbl z))) + +;; cauchy distribution +(defforfun excl_cauchycdf (double-float) :double-float) +(defun base-cauchy-cdf (x) (excl_cauchycdf (mkdbl x))) +(defforfun excl_cauchyquant (double-float) :double-float) +(defun base-cauchy-quant (x) (excl_cauchyquant (mkdbl x))) +(defforfun excl_cauchydens (double-float) :double-float) +(defun base-cauchy-dens (x) (excl_cauchydens (mkdbl x))) +(defforfun excl_cauchyrand () :double-float) +(defun one-cauchy-rand () (excl_cauchyrand)) + +;; gamma distribution +(defforfun excl_gammacdf (double-float double-float) :double-float) +(defun base-gamma-cdf (x y) (excl_gammacdf (mkdbl x) (mkdbl y))) +(defforfun excl_gammaquant (double-float double-float) :double-float) +(defun base-gamma-quant (x y) (excl_gammaquant (mkdbl x) (mkdbl y))) +(defforfun excl_gammadens (double-float double-float) :double-float) +(defun base-gamma-dens (x y) (excl_gammadens (mkdbl x) (mkdbl y))) +(defforfun excl_gammarand (double-float) :double-float) +(defun one-gamma-rand (x) (excl_gammarand (mkdbl x))) + +;; chi-square distribution +(defforfun excl_chisqcdf (double-float double-float) :double-float) +(defun base-chisq-cdf (x y) (excl_chisqcdf (mkdbl x) (mkdbl y))) +(defforfun excl_chisqquant (double-float double-float) :double-float) +(defun base-chisq-quant (x y) (excl_chisqquant (mkdbl x) (mkdbl y))) +(defforfun excl_chisqdens (double-float double-float) :double-float) +(defun base-chisq-dens (x y) (excl_chisqdens (mkdbl x) (mkdbl y))) +(defforfun excl_chisqrand (double-float) :double-float) +(defun one-chisq-rand (x) (excl_chisqrand (mkdbl x))) + +;; beta distribution +(defforfun excl_betacdf (double-float double-float double-float) :double-float) +(defun base-beta-cdf (x y z) (excl_betacdf (mkdbl x) (mkdbl y) (mkdbl z))) +(defforfun excl_betaquant (double-float double-float double-float) :double-float) +(defun base-beta-quant (x y z) (excl_betaquant (mkdbl x) (mkdbl y) (mkdbl z))) +(defforfun excl_betadens (double-float double-float double-float) :double-float) +(defun base-beta-dens (x y z) (excl_betadens (mkdbl x) (mkdbl y) (mkdbl z))) +(defforfun excl_betarand (double-float double-float) :double-float) +(defun one-beta-rand (x y) (excl_betarand (mkdbl x) (mkdbl y))) + +;; t distribution +(defforfun excl_tcdf (double-float double-float) :double-float) +(defun base-t-cdf (x y) (excl_tcdf (mkdbl x) (mkdbl y))) +(defforfun excl_tquant (double-float double-float) :double-float) +(defun base-t-quant (x y) (excl_tquant (mkdbl x) (mkdbl y))) +(defforfun excl_tdens (double-float double-float) :double-float) +(defun base-t-dens (x y) (excl_tdens (mkdbl x) (mkdbl y))) +(defforfun excl_trand (double-float) :double-float) +(defun one-t-rand (x) (excl_trand (mkdbl x))) + +;; F distribution +(defforfun excl_fcdf (double-float double-float double-float) :double-float) +(defun base-f-cdf (x y z) (excl_fcdf (mkdbl x) (mkdbl y) (mkdbl z))) +(defforfun excl_fquant (double-float double-float double-float) :double-float) +(defun base-f-quant (x y z) (excl_fquant (mkdbl x) (mkdbl y) (mkdbl z))) +(defforfun excl_fdens (double-float double-float double-float) :double-float) +(defun base-f-dens (x y z) (excl_fdens (mkdbl x) (mkdbl y) (mkdbl z))) +(defforfun excl_frand (double-float double-float) :double-float) +(defun one-f-rand (x y) (excl_frand (mkdbl x) (mkdbl y))) + +;; Poisson distribution +(defforfun excl_poissoncdf (double-float double-float) :double-float) +(defun base-poisson-cdf (x y) (excl_poissoncdf (mkdbl x) (mkdbl y))) +(defforfun excl_poissonquant (double-float double-float) :integer) +(defun base-poisson-quant (x y) (excl_poissonquant (mkdbl x) (mkdbl y))) +(defforfun excl_poissonpmf (integer double-float) :double-float) +(defun base-poisson-pmf (x y) (excl_poissonpmf x (mkdbl y))) +(defforfun excl_poissonrand (double-float) :integer) +(defun one-poisson-rand (x) (excl_poissonrand (mkdbl x))) + +;; binomial distribution +(defforfun excl_binomialcdf (double-float integer double-float) :double-float) +(defun base-binomial-cdf (x y z) (excl_binomialcdf (mkdbl x) y (mkdbl z))) +(defforfun excl_binomialquant (double-float integer double-float) :integer) +(defun base-binomial-quant (x y z) (excl_binomialquant (mkdbl x) y (mkdbl z))) +(defforfun excl_binomialpmf (integer integer double-float) :double-float) +(defun base-binomial-pmf (x y z) (excl_binomialpmf x y (mkdbl z))) +(defforfun excl_binomialrand (integer double-float) :integer) +(defun one-binomial-rand (x y) (excl_binomialrand x (mkdbl y))) diff --git a/fastmap.lsp b/fastmap.lsp new file mode 100644 index 0000000..30b7849 --- /dev/null +++ b/fastmap.lsp @@ -0,0 +1,95 @@ +;;;; fastmap -- Fast version of MAP +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. +;;;; +;;;; The FASTMAP function is a version of MAP that is assumed to +;;;; +;;;; a) be reasonable fast on any combination of lists and vectors +;;;; as its arguments +;;;; +;;;; b) not hang if at least one of its arguments is not a circular +;;;; list. +;;;; +;;;; This function is the core of the vectorized arithmetic system, so it +;;;; may be worth optimizing for each CL implementation. I tried to improve +;;;; it for (A)KCL but have not yet been able to obtain a significant +;;;; increase in speed. + +(provide "fastmap") + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(in-package lisp-stat-basics) +#-:CLtL2 +(in-package 'lisp-stat-basics) + + +;;;; +;;;; Functions +;;;; + +(defun cdr-lists (args) + (do ((list args (cdr list))) ((null list)) + (if (consp (car list)) (rplaca list (cdar list))))) + +(defun get-result-size (args) + (macrolet ((any-nulls (ls) `(dolist (x ,ls) (if (null x) (return t))))) + (let ((lists nil) + (n nil)) + (dolist (x args) + (if (consp x) + (push x lists) + (setf n (if n (min n (length x)) (length x))))) + (cond + ((and n lists) + (let ((m 0)) + (loop + (if (or (<= n m) (any-nulls lists)) (return)) + (cdr-lists lists) + (incf m)) + (min n m))) + (lists + (let ((m 0)) + (loop + (if (any-nulls lists) (return)) + (cdr-lists lists) + (incf m)) + m)) + (t n))))) + +(defun fastmap (type fcn &rest args) + (cond ((and (eq type 'list) (every #'listp args)) + (apply #'mapcar fcn args)) + ((and (eq type 'vector) (every #'vectorp args)) + (apply #'map 'vector fcn args)) + ((every #'sequencep args) + (let* ((n (get-result-size args)) + (result (make-sequence type n)) + (farg (make-list (length args)))) + (declare (fixnum n)) + (macrolet ((fill-arglist () + `(do ((f farg (cdr f)) + (a args (cdr a))) + ((null f)) + (rplaca f + (if (consp (car a)) + (caar a) + (aref (car a) i)))))) + (if (consp result) + (let ((r result)) + (dotimes (i n result) + (declare (fixnum i)) + (fill-arglist) + (rplaca r (apply fcn farg)) + (setf r (cdr r)) + (cdr-lists args))) + (dotimes (i n result) + (declare (fixnum i)) + (fill-arglist) + (setf (aref result i) (apply fcn farg)) + (cdr-lists args)))))) + (t (error "not all sequences")))) diff --git a/kclglue.lsp b/kclglue.lsp new file mode 100644 index 0000000..5badb2c --- /dev/null +++ b/kclglue.lsp @@ -0,0 +1,436 @@ +;;;; kclglue -- Interface to C library +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +(in-package 'lisp-stat-basics) + +(eval-when (compile load eval) + (set-macro-character + #\% + #'(lambda (stream char) (values (read-line stream))))) + +(Clines +%#define IN_KCL_GLUE +%#include "lib/linalg.h" +%extern double rcondest_front(); +%extern char *calloc(); +%char buf[1000]; +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Basic Utilities +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; Storage Allocation Functions +;;;; + +(defun null-ptr-p (p) (= p 0)) +(defun ptr-eq (p q) (= p q)) + +(Clines +%int la_base_allocate(n, m) +% unsigned n, m; +%{ +% char *p = calloc(n, m); +% if (p == nil) xlfail("allocation failed"); +% return((int) p); +%} +) + +(defentry la-base-allocate (int int) (int "la_base_allocate")) + +(Clines +%int la_base_free_alloc(p) +% int p; +%{ +% if (p) free((char *) p); +% return(0); +%} +) + +(defentry la-base-free (int) (int "la_base_free_alloc")) + +(Clines +%static int mode_size(mode) +% int mode; +%{ +% switch (mode) { +% case IN: return(sizeof(int)); +% case RE: return(sizeof(double)); +% case CX: return(sizeof(Complex)); +% } +% return(0); +%} +) + +(defentry la-mode-size (int) (int "mode_size")) + +(defCfun "int la_allocate(n, m) int n, m;" 0 +%{ +% int p; + ((la-allocate (int "n") (int "m")) (int "p")) +% return(p); +%} +) + +(defCfun "la_free_alloc(p) int p;" 0 +%{ + (la-free (int "p")) +%} +) + +(defentry al (int int) (int "la_allocate")) +(defentry fr (int) (int "la_free_alloc")) + +;;;; +;;;; Storage Access Functions +;;;; + +(Clines +%static int get_integer(p, i) +% int p, i; +%{ +% return(*(((int *) p) + i)); +%} +) + +(defentry la-get-integer (int int) (int "get_integer")) + +(Clines +%static double get_double(p, i) +% int p, i; +%{ +% return(*(((double *) p) + i)); +%} +) + +(defentry la-get-double (int int) (double "get_double")) + +(Clines +%static double get_complex_real(p, i) +% int p, i; +%{ +% Complex *c = ((Complex *) p) + i; +% return(c->real); +%} +) + +(defentry la-get-complex-real (int int) (double "get_complex_real")) + +(Clines +%static double get_complex_imag(p, i) +% int p, i; +%{ +% Complex *c = ((Complex *) p) + i; +% return(c->imag); +%} +) + +(defentry la-get-complex-imag (int int) (double "get_complex_imag")) + +(defun la-get-complex (p i) + (complex (la-get-complex-real p i) (la-get-complex-imag p i))) + +(defun la-get-pointer (p i) (la-get-integer p i)) + +;;;; +;;;; Storage Mutation Functions +;;;; + +(Clines +%static int put_integer(p, i, x) +% int p, i, x; +%{ +% *(((int *) p) + i) = x; +% return(0); +%} +) + +(defentry la-put-integer (int int int) (int "put_integer")) + +(Clines +%static int put_double(p, i, x) +% int p, i; +% double x; +%{ +% *(((double *) p) + i) = x; +% return(0); +%} +) + +(defentry la-put-double (int int double) (int "put_double")) + +(Clines +%static int put_complex(p, i, x, y) +% int p, i; +% double x, y; +%{ +% Complex *c = ((Complex *) p) + i; +% c->real = x; +% c->imag = y; +% return(0); +%} +) + +(defentry la-put-complex (int int double double) (int "put_complex")) + +(defun la-put-pointer (p i x) (la-put-integer p i x)) + +;;;; +;;;; XLISP internal error message emulation +;;;; + +(defvar *buf* (make-string 1000)) + +(defun set-buf-char (i c) (setf (elt *buf* i) (code-char c))) + +(defun get-buf (&optional (n (position (code-char 0) *buf*))) + (subseq *buf* 0 n)) + +(Clines +%static int bufpos = 0; +% +%static resetbuf() { bufpos = 0; } +% +) + +(defCfun "static prbuf(s) char *s;" 0 +%{ +% object ch; +% int i, n; +% +% n = strlen(s); +% for (i = 0; i (y)) ? (x) : (y)) + +static double betai(x, pin, qin) + double x, pin, qin; +{ + /* Translated from FORTRAN + july 1977 edition. w. fullerton, c3, los alamos scientific lab. + based on bosten and battiste, remark on algorithm 179, comm. acm, + v 17, p 153, (1974). + + input arguments -- + x upper limit of integration. x must be in (0,1) inclusive. + p first beta distribution parameter. p must be gt 0.0. + q second beta distribution parameter. q must be gt 0.0. + betai the incomplete beta function ratio is the probability that a + random variable from a beta distribution having parameters + p and q will be less than or equal to x. + */ + double c, finsum, p, ps, q, term, xb, xi, y, dbetai, p1; + static double eps = 0.0, alneps = 0.0, sml = 0.0, alnsml = 0.0; + int i, n, ib; + + /* I'm not sure these tolerances are optimal */ + if (eps == 0.0) { + eps = macheps(); + alneps = log(eps); + sml = macheps(); + alnsml = log(sml); + } + + y = x; + p = pin; + q = qin; + if (q > p || x >= 0.8) + if (x >= 0.2) { + y = 1.0 - y; + p = qin; + q = pin; + } + + if ((p + q) * y / (p + 1.0) < eps) { + dbetai = 0.0; + xb = p * log(Max(y, sml)) - log(p) - logbeta(p, q); + if (xb > alnsml && y != 0.0) dbetai = exp(xb); + if (y != x || p != pin) dbetai = 1.0 - dbetai; + } + else { + /* + * evaluate the infinite sum first. term will equal + * y**p/beta(ps,p) * (1.-ps)-sub-i * y**i / fac(i) . + */ + ps = q - floor(q); + if (ps == 0.0) ps = 1.0; + xb = p * log(y) - logbeta(ps, p) - log(p); + dbetai = 0.0; + if (xb >= alnsml) { + + dbetai = exp(xb); + term = dbetai * p; + if (ps != 1.0) { + n = Max(alneps / log(y), 4.0); + for (i = 1; i <= n; i++) { + xi = i; + term = term * (xi - ps) * y / xi; + dbetai = dbetai + term / (p + xi); + } + } + } + /* + * now evaluate the finite sum, maybe. + */ + if (q > 1.0) { + + xb = p * log(y) + q * log(1.0 - y) - logbeta(p,q) - log(q); + ib = Max(xb / alnsml, 0.0); + term = exp(xb - ((float) ib) * alnsml); + c = 1.0 / (1.0 - y); + p1 = q * c / (p + q - 1.0); + + finsum = 0.0; + n = q; + if (q == (float) n) n = n - 1; + for (i = 1; i <= n; i++) { + if (p1 <= 1.0 && term / eps <= finsum) break; + xi = i; + term = (q - xi + 1.0) * c * term / (p + q - xi); + + if (term > 1.0) ib = ib - 1; + if (term > 1.0) term = term * sml; + + if (ib==0) finsum = finsum + term; + } + + dbetai = dbetai + finsum; + } + if (y != x || p != pin) dbetai = 1.0 - dbetai; + dbetai = Max(Min(dbetai, 1.0), 0.0); + } + return(dbetai); +} + +/* + xinbta.f -- translated by f2c and modified + + algorithm as 109 appl. statist. (1977), vol.26, no.1 + (replacing algorithm as 64 appl. statist. (1973), vol.22, no.3) + + Remark AS R83 has been incorporated in this version. + + Computes inverse of the incomplete beta function + ratio for given positive values of the arguments + p and q, alpha between zero and one. + log of complete beta function, beta, is assumed to be known. + + Auxiliary function required: betai + + SAE below is the most negative decimal exponent which does not + cause an underflow; a value of -308 or thereabouts will often be +*/ + +static double xinbta(p, q, beta, alpha, ifault) + double *p, *q, *beta, *alpha; + int *ifault; +{ + /* Initialized data */ + static double sae = -30.0; /* this should be sufficient */ + static double zero = 0.0; + static double one = 1.0; + static double two = 2.0; + static double three = 3.0; + static double four = 4.0; + static double five = 5.0; + static double six = 6.0; + + /* System generated locals */ + double ret_val, d_1, d_2; + + /* Local variables */ + static int indx; + static double prev, a, g, h, r, s, t, w, y, yprev, pp, qq; + static double sq, tx, adj, acu; + static int iex; + static double fpu, xin; + + /* Define accuracy and initialise. */ + fpu = sae * 10.; + ret_val = *alpha; + + /* test for admissibility of parameters */ + *ifault = 1; + if (*p <= zero || *q <= zero) return ret_val; + *ifault = 2; + if (*alpha < zero || *alpha > one) return ret_val; + *ifault = 0; + if (*alpha == zero || *alpha == one) return ret_val; + + /* change tail if necessary */ + if (*alpha <= .5) { + a = *alpha; + pp = *p; + qq = *q; + indx = FALSE; + } + else { + a = one - *alpha; + pp = *q; + qq = *p; + indx = TRUE; + } + + /* calculate the initial approximation */ + r = sqrt(-log(a * a)); + y = r - (r * .27061 + 2.30753) / (one + (r * .04481 + .99229) * r); + if (pp > one && qq > one) { + r = (y * y - three) / six; + s = one / (pp + pp - one); + t = one / (qq + qq - one); + h = two / (s + t); + d_1 = y * sqrt(h + r) / h; + d_2 = (t - s) * (r + five / six - two / (three * h)); + w = d_1 - d_2; + ret_val = pp / (pp + qq * exp(w + w)); + } + else { + r = qq + qq; + t = one / (qq * 9.); + /* Computing 3rd power */ + d_1 = one - t + y * sqrt(t); + t = r * (d_1 * d_1 * d_1); + if (t <= zero) { + ret_val = one - exp((log((one - a) * qq) + *beta) / qq); + } + else { + t = (four * pp + r - two) / t; + if (t <= one) ret_val = exp((log(a * pp) + *beta) / pp); + else ret_val = one - two / (t + one); + } + } + + + /* + solve for x by a modified newton-raphson method, using the function betai + */ + r = one - pp; + t = one - qq; + yprev = zero; + sq = one; + prev = one; + if (ret_val < 1e-4) ret_val = 1e-4; + if (ret_val > .9999) ret_val = .9999; + /* Computing MAX, two 2nd powers */ + d_1 = -5.0 / (pp * pp) - 1.0 / (a * a) - 13.0; + iex = (sae > d_1) ? sae : d_1; + acu = pow(10.0, (double) iex); + do { + y = betai(ret_val, pp, qq); + if (*ifault != 0) { + *ifault = 3; + return ret_val; + } + xin = ret_val; + y = (y - a) * exp(*beta + r * log(xin) + t * log(one - xin)); + if (y * yprev <= zero) { + prev = (sq > fpu) ? sq : fpu; + } + g = one; + do { + adj = g * y; + sq = adj * adj; + if (sq < prev) { + tx = ret_val - adj; + if (tx >= zero && tx <= one) { + if (prev <= acu || y * y <= acu) { + if (indx) ret_val = one - ret_val; + return ret_val; + } + if (tx != zero && tx != one) break; + } + } + g /= three; + } while (TRUE); + if (tx == ret_val) { + if (indx) ret_val = one - ret_val; + return ret_val; + } + ret_val = tx; + yprev = y; + } while (TRUE); + return ret_val; +} diff --git a/lib/bivnor.c b/lib/bivnor.c new file mode 100644 index 0000000..c0c3ed8 --- /dev/null +++ b/lib/bivnor.c @@ -0,0 +1,128 @@ +#include "xmath.h" + +#define twopi 6.283195307179587 +#define con (twopi / 2.0) * 10.0e-10 + +double bivnor(ah, ak, r) + double ah, ak, r; +{ + /* + based on alg 4628 comm. acm oct 73 + gives the probability that a bivariate normal exceeds (ah,ak). + gh and gk are .5 times the right tail areas of ah, ak under a n(0,1) + + Tranlated from FORTRAN to ratfor using struct; from ratfor to C by hand. + */ + double a2, ap, b, cn, conex, ex, g2, gh, gk, gw, h2, h4, rr, s1, s2, + sgn, sn, sp, sqr, t, temp, w2, wh, wk; + int is; + + temp = -ah; + normbase(&temp, &gh); + gh = gh / 2.0; + temp = -ak; + normbase(&temp, &gk); + gk = gk / 2.0; + + b = 0; + + if (r==0) + b = 4*gh*gk; + else { + rr = 1-r*r; + if (rr<0) + return(-1.0); + if (rr!=0) { + sqr = sqrt(rr); + if (ah!=0) { + b = gh; + if (ah*ak<0) + b = b-.5; + else if (ah*ak==0) + goto label10; + } + else if (ak==0) { + b = atan(r/sqr)/twopi+.25; + goto label50; + } + b = b+gk; + if (ah==0) + goto label20; + label10: + wh = -ah; + wk = (ak/ah-r)/sqr; + gw = 2*gh; + is = -1; + goto label30; + label20: + do { + wh = -ak; + wk = (ah/ak-r)/sqr; + gw = 2*gk; + is = 1; + label30: + sgn = -1; + t = 0; + if (wk!=0) { + if (fabs(wk)>=1) + if (fabs(wk)==1) { + t = wk*gw*(1-gw)/2; + goto label40; + } + else { + sgn = -sgn; + wh = wh*wk; + normbase(&wh, &g2); + wk = 1/wk; + if (wk<0) + b = b+.5; + b = b-(gw+g2)/2+gw*g2; + } + h2 = wh*wh; + a2 = wk*wk; + h4 = h2*.5; + ex = 0; + if (h4<150.0) + ex = exp(-h4); + w2 = h4*ex; + ap = 1; + s2 = ap-ex; + sp = ap; + s1 = 0; + sn = s1; + conex = fabs(con/wk); + do { + cn = ap*s2/(sn+sp); + s1 = s1+cn; + if (fabs(cn)<=conex) + break; + sn = sp; + sp = sp+1; + s2 = s2-w2; + w2 = w2*h4/sp; + ap = -ap*a2; + } while (1); + t = (atan(wk)-wk*s1)/twopi; + label40: + b = b+sgn*t; + } + if (is>=0) + break; + } while(ak!=0); + } + else if (r>=0) + if (ah>=ak) + b = 2*gh; + else + b = 2*gk; + else if (ah+ak<0) + b = 2*(gh+gk)-1; + } + label50: + if (b<0) + b = 0; + if (b>1) + b = 1; + + return(b); +} diff --git a/lib/cbayes.c b/lib/cbayes.c new file mode 100644 index 0000000..40d1d6d --- /dev/null +++ b/lib/cbayes.c @@ -0,0 +1,227 @@ +/* cbayes - Lisp interface to laplace approximation stuff */ +/* Copyright (c) 1990, by Luke Tierney */ + +#include "linalg.h" + +#ifdef INTPTR +typedef int PTR; +#else +typedef char *PTR; +#endif + +extern char *calloc(), *realloc(); + +/************************************************************************/ +/** **/ +/** Definitions and Globals **/ +/** **/ +/************************************************************************/ + +#define MAXALLOC 20 + +static char *mem[MAXALLOC], memcount; + +typedef struct { + int n, m, k, itnlimit, backtrack, verbose, vals_suppl, exptilt; + int count, termcode; +} MaxIPars; + +typedef struct { + double typf, h, gradtol, steptol, maxstep, dflt, tilt, newtilt, hessadd; +} MaxDPars; + +typedef struct { + MaxIPars max; + int full, covar; +} MomIPars; + +typedef struct { + MaxDPars max; + double mgfdel; +} MomDPars; + +/************************************************************************/ +/** **/ +/** Fake Replacements for S Interface **/ +/** **/ +/************************************************************************/ + +static meminit() +{ + static inited = FALSE; + int i; + + if (! inited) { + for (i = 0; i < MAXALLOC; i++) mem[i] = nil; + inited = TRUE; + } + + memcount = 0; +} + +static makespace(pptr, size) + char **pptr; + int size; +{ + if (size <= 0) return; + if (*pptr == nil) *pptr = calloc(size, 1); + else *pptr = realloc(*pptr, size); + if (size > 0 && *pptr == nil) xlfail("memory allocation failed"); +} + +call_S(fun, narg, args, mode, length, names, nvals, values) + char *fun, **args, **mode, **names, **values; + long narg, nvals, *length; +{ + int n = length[0], derivs; + static double *fval = nil, *grad = nil, *hess = nil; + + makespace(&fval, 1 * sizeof(double)); + makespace(&grad, n * sizeof(double)); + makespace(&hess, n * n * sizeof(double)); + + callLminfun(n, args[0], fval, grad, hess, &derivs); + + values[0] = (char *) fval; + values[1] = (derivs > 0) ? (char *) grad : nil; + values[2] = (derivs > 1) ? (char *) hess : nil; +} + +Recover(s, w) + char *s, *w; +{ + xlfail(s); +} + +/************************************************************************/ +/** **/ +/** Callback Function **/ +/** **/ +/************************************************************************/ + +static callLminfun(n, x, fval, grad, hess, derivs) + int n, *derivs; + RVector x, grad, hess; + double *fval; +{ + maximize_callback(n, (PTR) x, + (PTR) fval, (PTR) grad, (PTR) hess, (PTR) derivs); +} + +/************************************************************************/ +/** **/ +/** Numerical Derivatives **/ +/** **/ +/************************************************************************/ + +numgrad_front(n, px, pgrad, h, pscale) + int n; + PTR px, pgrad, pscale; + double h; +{ + LVAL f = nil; + double fval; + + evalfront(&f, &n, (double *) px, + &fval, (double *) pgrad, nil, &h, (double *) pscale); +} + +numhess_front(n, px, pf, pgrad, phess, h, pscale) + int n; + PTR px, pf, pgrad, phess, pscale; + double h; +{ + LVAL f = nil; + + evalfront(&f, &n, (double *) px, + (double *) pf, (double *) pgrad, (double *) phess, + &h, (double *) pscale); +} + +/************************************************************************/ +/** **/ +/** Maximization Interface **/ +/** **/ +/************************************************************************/ + +/* internals array information */ +#define INTLEN 12 +#define F_POS 0 +#define G_POS 1 +#define C_POS 2 +#define X_POS 3 +#define SCALE_POS 4 +#define FVALS_POS 5 +#define CVALS_POS 6 +#define CTARG_POS 7 +#define IPARS_POS 8 +#define DPARS_POS 9 +#define TSCAL_POS 10 +#define MULT_POS 11 + +static MaxIPars getMaxIPars(ipars) + int *ipars; +{ + MaxIPars ip; + + ip.n = ipars[0]; + ip.m = ipars[1]; + ip.k = ipars[2]; + ip.itnlimit = ipars[3]; + ip.backtrack = ipars[4]; + ip.verbose = ipars[5]; + ip.vals_suppl = ipars[6]; + ip.exptilt = ipars[7]; + ip.count = ipars[8]; + ip.termcode = ipars[9]; + + return(ip); +} + +static MaxDPars getMaxDPars(dpars) + double *dpars; +{ + MaxDPars dp; + + dp.typf = dpars[0]; + dp.h = dpars[1]; + dp.gradtol = dpars[2]; + dp.steptol = dpars[3]; + dp.maxstep = dpars[4]; + dp.dflt = dpars[5]; + dp.tilt = dpars[6]; + dp.newtilt = dpars[7]; + dp.hessadd = dpars[8]; + + return(dp); +} + +minfo_maximize(px, pfvals, pscale, pip, pdp, verbose) + PTR px, pfvals, pscale, pip, pdp; + int verbose; +{ + LVAL f = nil; + MaxIPars ip; + MaxDPars dp; + int n, m, k; + static double *dx, *typx, *fvals; + char *msg; + + dx = (double *) px; + typx = (double *) pscale; + fvals = (double *) pfvals; + + ip = getMaxIPars((int *) pip); + dp = getMaxDPars((double *) pdp); + + m = 0; + k = 0; + n = ip.n; + if (verbose >= 0) ip.verbose = verbose; + + meminit(); + maxfront(&f, nil, nil, dx, typx, fvals, nil, nil, nil, + &ip, &dp, nil, &msg); + + bufputstr(msg); +} diff --git a/lib/cdists.c b/lib/cdists.c new file mode 100644 index 0000000..a79f11a --- /dev/null +++ b/lib/cdists.c @@ -0,0 +1,837 @@ +#include "xmath.h" + +extern double ppnd(), gamma(), bivnor(), uni(), ppgamma(), ppbeta(), + ppstudent(); + +/* forward declaration */ +extern double tdens(); + +#ifndef PI +#define PI 3.14159265358979323846 +#endif PI +#define TRUE 1 +#define FALSE 0 + +/* + * Under ULTRIX 3.1 (the cc1.31 compilers in particular) the _G0 math + * library does not really exist! You either need to figure out how + * to get tan() and floor() in at load time for kcl, or use the ones + * here. + */ + +#ifdef mips +#ifdef UX31 +double tan(x) + double x; +{ + return(sin(x) / cos(x)); +} +double floor(x) + double x; +{ + long ix = x; + double dx = ix; + return((dx <= x) ? dx : dx - 1.0); +} +#endif +#endif + +static checkflag(flag) + int flag; +{ + /* do nothing for now */ +} + +static checkexp(a) + double a; +{ + if (a <= 0.0) xlfail("non-positive gamma or beta exponent"); +} + +static checkdf(df) + double df; +{ + if (df <= 0.0) xlfail("non-positive degrees of freedom"); +} + +static checkprob(p, zerostrict, onestrict) + double p; + int zerostrict, onestrict; +{ + if (zerostrict) { + if (p <= 0.0) xlfail("non-positive probability argument"); + } + else { + if (p < 0.0) xlfail("negative probability argument"); + } + if (onestrict) { + if (p >= 1.0) xlfail("probability argument not less than one"); + } + else { + if (p > 1.0) xlfail("probability argument greater than one"); + } +} + +static checkrho(r) + double r; +{ + if (r < -1 || r > 1) xlfail("correlation out of range"); +} + +static checkpoisson(L) + double L; +{ + if (L < 0.0) xlfail("negative Poisson mean"); +} + +static checkbinomial(n, p) + int n; + double p; +{ + if (p < 0.0 || p > 1.0) xlfail("binomial p out of range"); + if (n < 1) xlfail("non-positive binomial n"); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** Uniform Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +/* uniform generator - avoids zero and one */ +double unirand() +{ + double u; + do { + u = uni(); + } while ((u <= 0.0) || (u >= 1.0)); + return(u); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** Normal Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +/* standard normal cdf */ +double normalcdf(x) + double x; +{ + double p; + normbase(&x, &p); + return(p); +} + +/* standard normal quantile function */ +double normalquant(p) + double p; +{ + int flag; + double x; + + checkprob(p, TRUE, TRUE); + x = ppnd(p, &flag); + checkflag(flag); + return(x); +} + +/* standard normal density */ +double normaldens(x) + double x; +{ + return(exp(- 0.5 * x * x) / sqrt(2.0 * PI)); +} + +/* standard normal generator */ +double normalrand() +{ + double x, y, u, u1, v; + static double c = -1.0; + + if (c < 0.0) c = sqrt(2.0 / exp(1.0)); + + /* ratio of uniforms with linear pretest */ + do { + u = unirand(); + u1 = unirand(); + v = c * (2 * u1 - 1); + x = v / u; + y = x * x / 4.0; + } while(y > (1 - u) && y > - log(u)); + return(x); +} + +/* bivariate normal cdf */ +double bnormcdf(x, y, r) + double x, y, r; +{ + checkrho(r); + return(bivnor(-x, -y, r)); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** Cauchy Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +/* Cauchy cdf */ +double cauchycdf(dx) + double dx; +{ + return((atan(dx) + PI / 2) / PI); +} + +/* Cauchy quantile function */ +double cauchyquant(p) + double p; +{ + checkprob(p, TRUE, TRUE); + return(tan(PI * (p - 0.5))); +} + +/* cauchy density */ +double cauchydens(dx) + double dx; +{ + return(tdens(dx, 1.0)); +} + +/* cauchy generator */ +double cauchyrand() +{ + double u1, u2, v1, v2; + + /* ratio of uniforms on half disk */ + do { + u1 = unirand(); + u2 = unirand(); + v1 = 2.0 * u1 - 1.0; + v2 = u2; + } while(v1 * v1 + v2 * v2 > 1.0); + return(v1 / v2); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** Gamma Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +/* gamma cdf */ +double gammacdf(x, a) + double x, a; +{ + double p; + + checkexp(a); + if (x <= 0.0) p = 0.0; + else gammabase(&x, &a, &p); + return(p); +} + +double gammaquant(p, a) + double p, a; +{ + int flag; + double x; + + checkexp(a); + checkprob(p, FALSE, TRUE); + x = ppgamma(p, a, &flag); + checkflag(flag); + return(x); +} + +/* gamma density */ +double gammadens(x, a) + double x, a; +{ + double dens; + + checkexp(a); + if (x <= 0.0) dens = 0.0; + else dens = exp(log(x) * (a - 1) - x - gamma(a)); + return(dens); +} + +/* gamma generator */ +double gammarand(a) + double a; +{ + double x, u0, u1, u2, v, w, c, c1, c2, c3, c4, c5; + static double e = -1.0; + int done; + + checkexp(a); + if (e < 0.0) e = exp(1.0); + + if (a < 1.0) { + /* Ahrens and Dieter algorithm */ + done = FALSE; + c = (a + e) / e; + do { + u0 = unirand(); + u1 = unirand(); + v = c * u0; + if (v <= 1.0) { + x = exp(log(v) / a); + if (u1 <= exp(-x)) done = TRUE; + } + else { + x = -log((c - v) / a); + if (x > 0.0 && u1 < exp((a - 1.0) * log(x))) done = TRUE; + } + } while(! done); + } + else if (a == 1.0) x = -log(unirand()); + else { + /* Cheng and Feast algorithm */ + c1 = a - 1.0; + c2 = (a - 1.0 / (6.0 * a)) / c1; + c3 = 2.0 / c1; + c4 = 2.0 / (a - 1.0) + 2.0; + c5 = 1.0 / sqrt(a); + do { + do { + u1 = unirand(); + u2 = unirand(); + if (a > 2.5) u1 = u2 + c5 * (1.0 - 1.86 * u1); + } while (u1 <= 0.0 || u1 >= 1.0); + w = c2 * u2 / u1; + } while ((c3 * u1 + w + 1.0/w) > c4 && (c3 * log(u1) - log(w) + w) > 1.0); + x = c1 * w; + } + return(x); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** Chi-Square Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +double chisqcdf(x, df) + double x, df; +{ + double p, a; + + checkdf(df); + a = 0.5 * df; x = 0.5 * x; + if (x <= 0.0) p = 0.0; + else gammabase(&x, &a, &p); + return(p); +} + +double chisqquant(p, df) + double p, df; +{ + double x, a; + int flag; + + checkdf(df); + checkprob(p, FALSE, TRUE); + a = 0.5 * df; + x = 2.0 * ppgamma(p, a, &flag); + checkflag(flag); + return(x); +} + +/* chi-square density */ +double chisqdens(dx, da) + double dx, da; +{ + checkdf(da); + da = 0.5 * da; + dx = 0.5 * dx; + return(0.5 * gammadens(dx, da)); +} + +/* chi-square generator */ +double chisqrand(df) + double df; +{ + checkdf(df); + return(2.0 * gammarand(df / 2.0)); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** Beta Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +double betacdf(x, a, b) + double x, a, b; +{ + double p; + int ia, ib; + + checkexp(a); checkexp(b); + ia = a; ib = b; + if (x <= 0.0) p = 0.0; + else if (x >= 1.0) p = 1.0; + else betabase(&x, &a, &b, &ia, &ib, &p); + return(p); +} + +double betaquant(p, a, b) + double p, a, b; +{ + double x; + int flag; + + checkexp(a); checkexp(b); + checkprob(p, FALSE, FALSE); + x = ppbeta(p, a, b, &flag); + checkflag(flag); + return(x); +} + +static double logbeta(a, b) + double a, b; +{ + static double da = 0.0, db = 0.0, lbeta = 0.0; + + if (a != da || b != db) { /* cache most recent call */ + da = a; db = b; + lbeta = gamma(da) + gamma(db) - gamma(da + db); + } + return(lbeta); +} + +/* beta density */ +double betadens(x, a, b) + double x, a, b; +{ + double dens; + + checkexp(a); + checkexp(b); + if (x <= 0.0 || x >= 1.0) dens = 0.0; + else dens = exp(log(x) * (a - 1) + log(1 - x) * (b - 1) - logbeta(a, b)); + return(dens); +} + +/* beta generator */ +double betarand(a, b) + double a, b; +{ + double x, y; + + checkexp(a); + checkexp(b); + x = gammarand(a); + y = gammarand(b); + return(x / (x + y)); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** t Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +/* t cdf */ +double tcdf(x, df) + double x, df; +{ + double p; + + checkdf(df); + studentbase(&x, &df, &p); + return(p); +} + +/* t quantile function */ +double tquant(p, df) + double p, df; +{ + double x; + int flag; + + checkdf(df); + checkprob(p, TRUE, TRUE); + x = ppstudent(p, df, &flag); + checkflag(flag); + return(x); +} + +/* t density */ +double tdens(x, a) + double x, a; +{ + double dens; + + checkdf(a); + dens = (1.0 / sqrt(a * PI)) + * exp(gamma(0.5 * (a + 1)) - gamma(0.5 * a) + - 0.5 * (a + 1) * log(1.0 + x * x / a)); + return(dens); +} + +/* t generator */ +double trand(df) + double df; +{ + checkdf(df); + return(normalrand() / sqrt(chisqrand(df) / df)); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** F Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +/* f cdf */ +double fcdf(x, ndf, ddf) + double x, ndf, ddf; +{ + double p, a, b; + + checkdf(ndf); checkdf(ddf); + a = 0.5 * ddf; + b = 0.5 * ndf; + if (x <= 0.0) p = 0.0; + else { + x = a / (a + b * x); + p = 1.0 - betacdf(x, a, b); + } + return(p); +} + +/* f quantile function */ +double fquant(p, ndf, ddf) + double p, ndf, ddf; +{ + double x, a, b; + int flag; + + checkdf(ndf); checkdf(ddf); + checkprob(p, FALSE, TRUE); + a = 0.5 * ddf; + b = 0.5 * ndf; + if (p == 0.0) x = 0.0; + else { + p = 1.0 - p; + x = ppbeta(p, a, b, &flag); + checkflag(flag); + x = a * (1.0 / x - 1.0) / b; + } + return(x); +} + +/* f density */ +double fdens(dx, da, db) + double dx, da, db; +{ + double dens; + + checkdf(da); + checkdf(db); + if (dx <= 0.0) dens = 0.0; + else dens = exp(0.5 * da * log(da) + 0.5 * db *log(db) + + (0.5 * da - 1.0) * log(dx) + - logbeta(0.5 * da, 0.5 * db) + - 0.5 * (da + db) * log(db + da * dx)); + return(dens); +} + +/* f generator */ +double frand(ndf, ddf) + double ndf, ddf; +{ + checkdf(ndf); + checkdf(ddf); + return((ddf * chisqrand(ndf)) / (ndf * chisqrand(ddf))); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** Poisson Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +static double poisson_cdf(k, L) + int k; + double L; +{ + double dp, dx; + + if (k < 0) dp = 0.0; + else if (L == 0.0) dp = (k < 0) ? 0.0 : 1.0; + else { + dx = k + 1.0; + gammabase(&L, &dx, &dp); + dp = 1.0 - dp; + } + return(dp); +} + +double poissoncdf(k, L) + double k; + double L; +{ + checkpoisson(L); + return(poisson_cdf((int) floor(k), L)); +} + +int poissonquant(x, L) + double x, L; +{ + int k, k1, k2, del, ia; + double m, s, p1, p2, pk; + + checkpoisson(L); + checkprob(x, FALSE, TRUE); + m = L; + s = sqrt(L); + del = max(1, (int) (0.2 * s)); + + if (x == 0.0) k = 0.0; + else k = m + s * ppnd(x, &ia); + k1 = k; k2 = k; + + do { + k1 = k1 - del; k1 = max(0, k1); + p1 = poisson_cdf(k1, L); + } while (k1 > 0 && p1 > x); + if (k1 == 0 && p1 >= x) return(k1); + + do { + k2 = k2 + del; + p2 = poisson_cdf(k2, L); + } while (p2 < x); + + while (k2 - k1 > 1) { + k = (k1 + k2) / 2; + pk = poisson_cdf(k, L); + if (pk < x) { k1 = k; p1 = pk; } + else { k2 = k; p2 = pk; } + } + return(k2); +} + +double poissonpmf(k, L) + int k; + double L; +{ + double dx, dp; + + checkpoisson(L); + dx = k; + if (L == 0.0) dp = (k == 0) ? 1.0 : 0.0; + else if (dx < 0.0) dp = 0.0; + else dp = exp(dx * log(L) - L - gamma(dx + 1.0)); + return(dp); +} + +/* poisson random generator from Numerical Recipes */ +int poissonrand(xm) + double xm; +{ + static double sqrt2xm, logxm, expxm, g, oldxm = -1.0; + double t, y; + int k; + + checkpoisson(xm); + if (xm < 12.0) { + if (xm != oldxm) { expxm = exp(-xm); oldxm = xm; } + k = -1; + t = 1.0; + do { + k++; + t *= uni(); + } while (t > expxm); + } + else { + if (xm != oldxm) { + oldxm = xm; + sqrt2xm = sqrt(2.0 * xm); + logxm = log(xm); + g = xm * logxm - gamma(xm + 1.0); + } + do { + do { + y = tan(PI * uni()); + k = floor(sqrt2xm * y + xm); + } while (k < 0); + t = 0.9 * (1.0 + y * y) * exp(k * logxm - gamma(k + 1.0) - g); + } while (uni() > t); + } + return (k); +} + +/*****************************************************************************/ +/*****************************************************************************/ +/** **/ +/** Binomial Distribution **/ +/** **/ +/*****************************************************************************/ +/*****************************************************************************/ + +static double binomial_cdf(k, n, p) + int k, n; + double p; +{ + double da, db, dp; + int ia, ib; + + if (k < 0) dp = 0.0; + else if (k >= n) dp = 1.0; + else if (p == 0.0) dp = (k < 0) ? 0.0 : 1.0; + else if (p == 1.0) dp = (k < n) ? 0.0 : 1.0; + else { + da = k + 1.0; + db = n - k; + ia = floor(da); ib = floor(db); + betabase(&p, &da, &db, &ia, &ib, &dp); + dp = 1.0 - dp; + } + return(dp); +} + +double binomialcdf(k, n, p) + double k, p; + int n; +{ + checkbinomial(n, p); + return(binomial_cdf((int) floor(k), n, p)); + +} + +int binomialquant(x, n, p) + double x, p; + int n; +{ + int k, k1, k2, del, ia; + double m, s, p1, p2, pk; + + checkbinomial(n, p); + checkprob(x, FALSE, FALSE); + + m = n * p; + s = sqrt(n * p * (1 - p)); + del = max(1, (int) (0.2 * s)); + + if (x == 0.0) k = 0.0; + else if (x == 1.0) k = n; + else k = m + s * ppnd(x, &ia); + k1 = k; k2 = k; + + do { + k1 = k1 - del; k1 = max(0, k1); + p1 = binomial_cdf(k1, n, p); + } while (k1 > 0 && p1 > p); + if (k1 == 0 && p1 >= x) return(k1); + + do { + k2 = k2 + del; k2 = min(n, k2); + p2 = binomial_cdf(k2, n, p); + } while (k2 < n && p2 < x); + if (k2 == n && p2 <= x) return(k2); + + while (k2 - k1 > 1) { + k = (k1 + k2) / 2; + pk = binomial_cdf(k, n, p); + if (pk < x) { k1 = k; p1 = pk; } + else { k2 = k; p2 = pk; } + } + return(k2); +} + +double binomialpmf(k, n, p) + int k, n; + double p; +{ + double dx, dp; + + checkbinomial(n, p); + dx = k; + if (p == 0.0) dp = (k == 0) ? 1.0 : 0.0; + else if (p == 1.0) dp = (k == n) ? 1.0 : 0.0; + else if (dx < 0.0 || dx > n) dp = 0.0; + else dp = exp(gamma(n + 1.0) - gamma(dx + 1.0) - gamma(n - dx + 1.0) + + dx * log(p) + (n - dx) * log(1.0 - p)); + return(dp); +} + +/* binomial random generator from Numerical Recipes */ +int binomialrand(n, pp) + int n; + double pp; +{ + int j, k; + static int nold = -1; + double am, em, g, p, sq, t, y; + static double pold = -1.0, pc, plog, pclog, en, oldg; + + checkbinomial(n, pp); + + p = (pp <= 0.5) ? pp : 1.0 - pp; + + am = n * p; + if (p == 0.0) k = 0; + else if (p == 1.0) k = n; + else if (n < 50) { + k = 0; + for (j = 0; j < n; j++) if (uni() < p) k++; + } + else if (am < 1.0) { + g = exp(-am); + t = 1.0; + k = -1; + do { + k++; + t *= uni(); + } while (t > g); + if (k > n) k = n; + } + else { + if (n != nold) { + en = n; + oldg = gamma(en + 1.0); + nold = n; + } + if (p != pold) { + pc = 1.0 - p; + plog = log(p); + pclog = log(pc); + pold = p; + } + sq = sqrt(2.0 * am * pc); + do { + do { + y = tan(PI * uni()); + em = sq * y + am; + } while (em < 0.0 || em >= en + 1.0); + em = floor(em); + t = 1.2 * sq * (1.0 + y * y) + * exp(oldg - gamma(em + 1.0) - gamma(en - em + 1.0) + + em * plog + (en - em) * pclog); + } while (uni() > t); + k = em; + } + if (p != pp) k = n - k; + return(k); +} diff --git a/lib/cfft.c b/lib/cfft.c new file mode 100644 index 0000000..bbe818e --- /dev/null +++ b/lib/cfft.c @@ -0,0 +1,827 @@ +/* from fftpkg package in cmlib and netlib -- translated by f2c and modified */ + +#include "xmath.h" + +/* + Public Routine +*/ + +/* + * cfft computes the forward or backward complex discrete fourier transform. + * + * Input Parameters: + * + * n The length of the complex sequence c. The method is + * more efficient when n is the product of small primes. + * + * c A complex array of length n which contains the sequence + * + * wsave a real work array which must be dimensioned at least 4n+15 + * in the program that calls cfft. + * isign 1 for transform, -1 for inverse transform. + * A call of cfft with isign = 1 followed by a call of cfft with + * isign = -1 will multiply the sequence by n. + * + * Output Parameters: + * + * c For j=1,...,n + * + * c(j)=the sum from k=1,...,n of + * + * c(k)*exp(-isign*i*(j-1)*(k-1)*2*pi/n) + * + * where i=sqrt(-1) + */ + +int cfft(n, c, wsave, isign) + int n; + double *c, *wsave; + int isign; +{ + int iw1, iw2; + + /* Parameter adjustments */ + --c; + --wsave; + + /* Function Body */ + if (n != 1) { + iw1 = n + n + 1; + iw2 = iw1 + n + n; + cffti1_(&n, &wsave[iw1], &wsave[iw2]); + cfft1_(&n, &c[1], &wsave[1], &wsave[iw1], &wsave[iw2], &isign); + } + return 0; +} + +/* + Internal Routines +*/ + +static int cfft1_(n, c, ch, wa, ifac, isign) + int *n; + double *c, *ch, *wa; + int *ifac; + int *isign; +{ + /* System generated locals */ + int i_1; + + /* Local variables */ + int idot; + int i, k1, l1, l2, n2, na, nf, ip, iw, ix2, ix3, ix4, nac, ido, idl1; + + /* Parameter adjustments */ + --c; + --ch; + --wa; + --ifac; + + /* Function Body */ + nf = ifac[2]; + na = 0; + l1 = 1; + iw = 1; + i_1 = nf; + for (k1 = 1; k1 <= i_1; ++k1) { + ip = ifac[k1 + 2]; + l2 = ip * l1; + ido = *n / l2; + idot = ido + ido; + idl1 = idot * l1; + if (ip == 4) { + ix2 = iw + idot; + ix3 = ix2 + idot; + if (na == 0) { + pass4_(&idot, &l1, &c[1], &ch[1], &wa[iw], &wa[ix2], &wa[ix3], isign); + } + else { + pass4_(&idot, &l1, &ch[1], &c[1], &wa[iw], &wa[ix2], &wa[ix3], isign); + } + na = 1 - na; + } + else if (ip == 2) { + if (na == 0) { + pass2_(&idot, &l1, &c[1], &ch[1], &wa[iw], isign); + } + else { + pass2_(&idot, &l1, &ch[1], &c[1], &wa[iw], isign); + } + na = 1 - na; + } + else if (ip == 3) { + ix2 = iw + idot; + if (na == 0) { + pass3_(&idot, &l1, &c[1], &ch[1], &wa[iw], &wa[ix2], isign); + } + else { + pass3_(&idot, &l1, &ch[1], &c[1], &wa[iw], &wa[ix2], isign); + } + na = 1 - na; + } + else if (ip == 5) { + ix2 = iw + idot; + ix3 = ix2 + idot; + ix4 = ix3 + idot; + if (na == 0) { + pass5_(&idot, &l1, &c[1], &ch[1], &wa[iw], &wa[ix2], &wa[ix3], + &wa[ix4], isign); + } + else { + pass5_(&idot, &l1, &ch[1], &c[1], &wa[iw], &wa[ix2], &wa[ix3], + &wa[ix4], isign); + } + na = 1 - na; + } + else { + if (na == 0) { + pass_(&nac, &idot, &ip, &l1, &idl1, &c[1], &c[1], &c[1], &ch[1], + &ch[1], &wa[iw], isign); + } + else { + pass_(&nac, &idot, &ip, &l1, &idl1, &ch[1], &ch[1], &ch[1], &c[1], + &c[1], &wa[iw], isign); + } + if (nac != 0) { + na = 1 - na; + } + } + l1 = l2; + iw += (ip - 1) * idot; + } + if (na != 0) { + n2 = *n + *n; + i_1 = n2; + for (i = 1; i <= i_1; ++i) { + c[i] = ch[i]; + } + } + return 0; +} + +static int cffti1_(n, wa, ifac) + int *n; + double *wa; + int *ifac; +{ + /* Initialized data */ + static int ntryh[4] = { 3,4,2,5 }; + + /* System generated locals */ + int i_1, i_2, i_3; + + /* Local variables */ + double argh; + int idot, ntry, i, j; + double argld; + int i1, k1, l1, l2, ib; + double fi; + int ld, ii, nf, ip, nl, nq, nr; + double arg; + int ido, ipm; + double tpi; + + /* Parameter adjustments */ + --wa; + --ifac; + + /* Function Body */ + nl = *n; + nf = 0; + j = 0; + + L101: + ++j; + if (j - 4 <= 0) ntry = ntryh[j - 1]; + else ntry += 2; + L104: + nq = nl / ntry; + nr = nl - ntry * nq; + if (nr != 0) goto L101; + ++nf; + ifac[nf + 2] = ntry; + nl = nq; + if (ntry == 2 && nf != 1) { + i_1 = nf; + for (i = 2; i <= i_1; ++i) { + ib = nf - i + 2; + ifac[ib + 2] = ifac[ib + 1]; + } + ifac[3] = 2; + } + if (nl != 1) goto L104; + + ifac[1] = *n; + ifac[2] = nf; + tpi = 6.28318530717959; + argh = tpi / (double) (*n); + i = 2; + l1 = 1; + i_1 = nf; + for (k1 = 1; k1 <= i_1; ++k1) { + ip = ifac[k1 + 2]; + ld = 0; + l2 = l1 * ip; + ido = *n / l2; + idot = ido + ido + 2; + ipm = ip - 1; + i_2 = ipm; + for (j = 1; j <= i_2; ++j) { + i1 = i; + wa[i - 1] = 1.0; + wa[i] = 0.0; + ld += l1; + fi = 0.0; + argld = (double) ld * argh; + i_3 = idot; + for (ii = 4; ii <= i_3; ii += 2) { + i += 2; + fi += 1.0; + arg = fi * argld; + wa[i - 1] = cos(arg); + wa[i] = sin(arg); + } + if (ip > 5) { + wa[i1 - 1] = wa[i - 1]; + wa[i1] = wa[i]; + } + } + l1 = l2; + } + return 0; +} + +static int pass_(nac, ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa, isign) + int *nac; + int *ido, *ip, *l1, *idl1; + double *cc, *c1, *c2, *ch, *ch2, *wa; + int *isign; +{ + /* System generated locals */ + int ch_dim1, ch_dim2, ch_offset, cc_dim1, cc_dim2, cc_offset, c1_dim1, + c1_dim2, c1_offset, c2_dim1, c2_offset, ch2_dim1, ch2_offset, + i_1, i_2, i_3; + + /* Local variables */ + int idij, idlj, idot, ipph, i, j, k, l, jc, lc, ik, idj, idl, inc, idp; + double wai, war; + int ipp2; + + /* Parameter adjustments */ + cc_dim1 = *ido; + cc_dim2 = *ip; + cc_offset = cc_dim1 * (cc_dim2 + 1) + 1; + cc -= cc_offset; + c1_dim1 = *ido; + c1_dim2 = *l1; + c1_offset = c1_dim1 * (c1_dim2 + 1) + 1; + c1 -= c1_offset; + c2_dim1 = *idl1; + c2_offset = c2_dim1 + 1; + c2 -= c2_offset; + ch_dim1 = *ido; + ch_dim2 = *l1; + ch_offset = ch_dim1 * (ch_dim2 + 1) + 1; + ch -= ch_offset; + ch2_dim1 = *idl1; + ch2_offset = ch2_dim1 + 1; + ch2 -= ch2_offset; + --wa; + + /* Function Body */ + idot = *ido / 2; + ipp2 = *ip + 2; + ipph = (*ip + 1) / 2; + idp = *ip * *ido; + + if (*ido >= *l1) { + i_1 = ipph; + for (j = 2; j <= i_1; ++j) { + jc = ipp2 - j; + i_2 = *l1; + for (k = 1; k <= i_2; ++k) { + i_3 = *ido; + for (i = 1; i <= i_3; ++i) { + ch[i + (k + j * ch_dim2) * ch_dim1] = + cc[i + (j + k * cc_dim2) * cc_dim1] + + cc[i + (jc + k * cc_dim2) * cc_dim1]; + ch[i + (k + jc * ch_dim2) * ch_dim1] = + cc[i + (j + k * cc_dim2) * cc_dim1] + - cc[i + (jc + k * cc_dim2) * cc_dim1]; + } + } + } + i_1 = *l1; + for (k = 1; k <= i_1; ++k) { + i_2 = *ido; + for (i = 1; i <= i_2; ++i) { + ch[i + (k + ch_dim2) * ch_dim1] = cc[i + (k * cc_dim2 + 1) * cc_dim1]; + } + } + } + else { + i_1 = ipph; + for (j = 2; j <= i_1; ++j) { + jc = ipp2 - j; + i_2 = *ido; + for (i = 1; i <= i_2; ++i) { + i_3 = *l1; + for (k = 1; k <= i_3; ++k) { + ch[i + (k + j * ch_dim2) * ch_dim1] = + cc[i + (j + k * cc_dim2) * cc_dim1] + + cc[i + (jc + k * cc_dim2) * cc_dim1]; + ch[i + (k + jc * ch_dim2) * ch_dim1] = + cc[i + (j + k * cc_dim2) * cc_dim1] + - cc[i + (jc + k * cc_dim2) * cc_dim1]; + } + } + } + i_1 = *ido; + for (i = 1; i <= i_1; ++i) { + i_2 = *l1; + for (k = 1; k <= i_2; ++k) { + ch[i + (k + ch_dim2) * ch_dim1] = cc[i + (k * cc_dim2 + 1) * cc_dim1]; + } + } + } + idl = 2 - *ido; + inc = 0; + i_1 = ipph; + for (l = 2; l <= i_1; ++l) { + lc = ipp2 - l; + idl += *ido; + i_2 = *idl1; + for (ik = 1; ik <= i_2; ++ik) { + c2[ik + l * c2_dim1] = ch2[ik + ch2_dim1] + wa[idl - 1] + * ch2[ik + (ch2_dim1 << 1)]; + c2[ik + lc * c2_dim1] = - *isign * wa[idl] * ch2[ik + *ip * ch2_dim1]; + } + idlj = idl; + inc += *ido; + i_2 = ipph; + for (j = 3; j <= i_2; ++j) { + jc = ipp2 - j; + idlj += inc; + if (idlj > idp) { + idlj -= idp; + } + war = wa[idlj - 1]; + wai = wa[idlj]; + i_3 = *idl1; + for (ik = 1; ik <= i_3; ++ik) { + c2[ik + l * c2_dim1] += war * ch2[ik + j * ch2_dim1]; + c2[ik + lc * c2_dim1] -= *isign * wai * ch2[ik + jc * ch2_dim1]; + } + } + } + i_1 = ipph; + for (j = 2; j <= i_1; ++j) { + i_2 = *idl1; + for (ik = 1; ik <= i_2; ++ik) { + ch2[ik + ch2_dim1] += ch2[ik + j * ch2_dim1]; + } + } + i_1 = ipph; + for (j = 2; j <= i_1; ++j) { + jc = ipp2 - j; + i_2 = *idl1; + for (ik = 2; ik <= i_2; ik += 2) { + ch2[ik - 1 + j * ch2_dim1] = c2[ik - 1 + j * c2_dim1] + - c2[ik + jc * c2_dim1]; + ch2[ik - 1 + jc * ch2_dim1] = c2[ik - 1 + j * c2_dim1] + + c2[ik + jc * c2_dim1]; + ch2[ik + j * ch2_dim1] = c2[ik + j * c2_dim1] + + c2[ik - 1 + jc * c2_dim1]; + ch2[ik + jc * ch2_dim1] = c2[ik + j * c2_dim1] + - c2[ik - 1 + jc * c2_dim1]; + } + } + *nac = 1; + if (*ido != 2) { + *nac = 0; + i_1 = *idl1; + for (ik = 1; ik <= i_1; ++ik) { + c2[ik + c2_dim1] = ch2[ik + ch2_dim1]; + } + i_1 = *ip; + for (j = 2; j <= i_1; ++j) { + i_2 = *l1; + for (k = 1; k <= i_2; ++k) { + c1[(k + j * c1_dim2) * c1_dim1 + 1] = + ch[(k + j * ch_dim2) * ch_dim1 + 1]; + c1[(k + j * c1_dim2) * c1_dim1 + 2] = + ch[(k + j * ch_dim2) * ch_dim1 + 2]; + } + } + if (idot <= *l1) { + idij = 0; + i_1 = *ip; + for (j = 2; j <= i_1; ++j) { + idij += 2; + i_2 = *ido; + for (i = 4; i <= i_2; i += 2) { + idij += 2; + i_3 = *l1; + for (k = 1; k <= i_3; ++k) { + c1[i - 1 + (k + j * c1_dim2) * c1_dim1] = wa[idij - 1] + * ch[i - 1 + (k + j * ch_dim2) * ch_dim1] + *isign * wa[idij] + * ch[i + (k + j * ch_dim2) * ch_dim1]; + c1[i + (k + j * c1_dim2) * c1_dim1] = wa[idij - 1] + * ch[i + (k + j * ch_dim2) * ch_dim1] - *isign * wa[idij] + * ch[i - 1 + (k + j * ch_dim2) * ch_dim1]; + } + } + } + } + else { + idj = 2 - *ido; + i_1 = *ip; + for (j = 2; j <= i_1; ++j) { + idj += *ido; + i_2 = *l1; + for (k = 1; k <= i_2; ++k) { + idij = idj; + i_3 = *ido; + for (i = 4; i <= i_3; i += 2) { + idij += 2; + c1[i - 1 + (k + j * c1_dim2) * c1_dim1] = wa[idij - 1] + * ch[i - 1 + (k + j * ch_dim2) * ch_dim1] + + *isign * wa[idij] * ch[i + (k + j * ch_dim2) * ch_dim1]; + c1[i + (k + j * c1_dim2) * c1_dim1] = wa[idij - 1] + * ch[i + (k + j * ch_dim2) * ch_dim1] - *isign * wa[idij] + * ch[i - 1 + (k + j * ch_dim2) * ch_dim1]; + } + } + } + } + } + return 0; +} + +static int pass2_(ido, l1, cc, ch, wa1, isign) + int *ido, *l1; + double *cc, *ch, *wa1; + int *isign; +{ + /* System generated locals */ + int cc_dim1, cc_offset, ch_dim1, ch_dim2, ch_offset, i_1, i_2; + + /* Local variables */ + int i, k; + double ti2, tr2; + + /* Parameter adjustments */ + cc_dim1 = *ido; + cc_offset = cc_dim1 * 3 + 1; + cc -= cc_offset; + ch_dim1 = *ido; + ch_dim2 = *l1; + ch_offset = ch_dim1 * (ch_dim2 + 1) + 1; + ch -= ch_offset; + --wa1; + + /* Function Body */ + if (*ido <= 2) { + i_1 = *l1; + for (k = 1; k <= i_1; ++k) { + ch[(k + ch_dim2) * ch_dim1 + 1] = cc[((k << 1) + 1) * cc_dim1 + 1] + + cc[((k << 1) + 2) * cc_dim1 + 1]; + ch[(k + (ch_dim2 << 1)) * ch_dim1 + 1] = cc[((k << 1) + 1) * cc_dim1 + 1] + - cc[((k << 1) + 2) * cc_dim1 + 1]; + ch[(k + ch_dim2) * ch_dim1 + 2] = cc[((k << 1) + 1) * cc_dim1 + 2] + + cc[((k << 1) + 2) * cc_dim1 + 2]; + ch[(k + (ch_dim2 << 1)) * ch_dim1 + 2] = cc[((k << 1) + 1) * cc_dim1 + 2] + - cc[((k << 1) + 2) * cc_dim1 + 2]; + } + } + else { + i_1 = *l1; + for (k = 1; k <= i_1; ++k) { + i_2 = *ido; + for (i = 2; i <= i_2; i += 2) { + ch[i - 1 + (k + ch_dim2) * ch_dim1] + = cc[i - 1 + ((k << 1) + 1) * cc_dim1] + + cc[i - 1 + ((k << 1) + 2) * cc_dim1]; + tr2 = cc[i - 1 + ((k << 1) + 1) * cc_dim1] + - cc[i - 1 + ((k << 1) + 2) * cc_dim1]; + ch[i + (k + ch_dim2) * ch_dim1] = cc[i + ((k << 1) + 1) * cc_dim1] + + cc[i + ((k << 1) + 2) * cc_dim1]; + ti2 = cc[i + ((k << 1) + 1) * cc_dim1] + - cc[i + ((k << 1) + 2) * cc_dim1]; + ch[i + (k + (ch_dim2 << 1)) * ch_dim1] = wa1[i - 1] * ti2 + - *isign * wa1[i] * tr2; + ch[i - 1 + (k + (ch_dim2 << 1)) * ch_dim1] = wa1[i - 1] * tr2 + + *isign * wa1[i] * ti2; + } + } + } + return 0; +} + +static int pass3_(ido, l1, cc, ch, wa1, wa2, isign) + int *ido, *l1; + double *cc, *ch, *wa1, *wa2; + int *isign; +{ + /* System generated locals */ + int cc_dim1, cc_offset, ch_dim1, ch_dim2, ch_offset, i_1, i_2; + + /* Local variables */ + double taui, taur; + int i, k; + double ci2, ci3, di2, di3, cr2, cr3, dr2, dr3, ti2, tr2; + + /* Parameter adjustments */ + cc_dim1 = *ido; + cc_offset = (cc_dim1 << 2) + 1; + cc -= cc_offset; + ch_dim1 = *ido; + ch_dim2 = *l1; + ch_offset = ch_dim1 * (ch_dim2 + 1) + 1; + ch -= ch_offset; + --wa1; + --wa2; + + /* Function Body */ + taur = -.5; + taui = -(*isign) * .866025403784439; + if (*ido == 2) { + i_1 = *l1; + for (k = 1; k <= i_1; ++k) { + tr2 = cc[(k * 3 + 2) * cc_dim1 + 1] + cc[(k * 3 + 3) * cc_dim1 + 1]; + cr2 = cc[(k * 3 + 1) * cc_dim1 + 1] + taur * tr2; + ch[(k + ch_dim2) * ch_dim1 + 1] = cc[(k * 3 + 1) * cc_dim1 + 1] + tr2; + ti2 = cc[(k * 3 + 2) * cc_dim1 + 2] + cc[(k * 3 + 3) * cc_dim1 + 2]; + ci2 = cc[(k * 3 + 1) * cc_dim1 + 2] + taur * ti2; + ch[(k + ch_dim2) * ch_dim1 + 2] = cc[(k * 3 + 1) * cc_dim1 + 2] + ti2; + cr3 = taui * (cc[(k * 3 + 2) * cc_dim1 + 1] + - cc[(k * 3 + 3) * cc_dim1 + 1]); + ci3 = taui * (cc[(k * 3 + 2) * cc_dim1 + 2] + - cc[(k * 3 + 3) * cc_dim1 + 2]); + ch[(k + (ch_dim2 << 1)) * ch_dim1 + 1] = cr2 - ci3; + ch[(k + ch_dim2 * 3) * ch_dim1 + 1] = cr2 + ci3; + ch[(k + (ch_dim2 << 1)) * ch_dim1 + 2] = ci2 + cr3; + ch[(k + ch_dim2 * 3) * ch_dim1 + 2] = ci2 - cr3; + } + } + else { + i_1 = *l1; + for (k = 1; k <= i_1; ++k) { + i_2 = *ido; + for (i = 2; i <= i_2; i += 2) { + tr2 = cc[i - 1 + (k * 3 + 2) * cc_dim1] + + cc[i - 1 + (k * 3 + 3) * cc_dim1]; + cr2 = cc[i - 1 + (k * 3 + 1) * cc_dim1] + taur * tr2; + ch[i - 1 + (k + ch_dim2) * ch_dim1] = cc[i - 1 + (k * 3 + 1) + * cc_dim1] + tr2; + ti2 = cc[i + (k * 3 + 2) * cc_dim1] + cc[i + (k * 3 + 3) * cc_dim1]; + ci2 = cc[i + (k * 3 + 1) * cc_dim1] + taur * ti2; + ch[i + (k + ch_dim2) * ch_dim1] = cc[i + (k * 3 + 1) * cc_dim1] + ti2; + cr3 = taui * (cc[i - 1 + (k * 3 + 2) * cc_dim1] + - cc[i - 1 + (k * 3 + 3) * cc_dim1]); + ci3 = taui * (cc[i + (k * 3 + 2) * cc_dim1] + - cc[i + (k * 3 + 3) * cc_dim1]); + dr2 = cr2 - ci3; + dr3 = cr2 + ci3; + di2 = ci2 + cr3; + di3 = ci2 - cr3; + ch[i + (k + (ch_dim2 << 1)) * ch_dim1] = wa1[i - 1] * di2 + - *isign * wa1[i] * dr2; + ch[i - 1 + (k + (ch_dim2 << 1)) * ch_dim1] = wa1[i - 1] * dr2 + + *isign * wa1[i] * di2; + ch[i + (k + ch_dim2 * 3) * ch_dim1] = wa2[i - 1] * di3 + - *isign * wa2[i] * dr3; + ch[i - 1 + (k + ch_dim2 * 3) * ch_dim1] = wa2[i - 1] * dr3 + + *isign * wa2[i] * di3; + } + } + } + return 0; +} + +static int pass4_(ido, l1, cc, ch, wa1, wa2, wa3, isign) + int *ido, *l1; + double *cc, *ch, *wa1, *wa2, *wa3; + int *isign; +{ + /* System generated locals */ + int cc_dim1, cc_offset, ch_dim1, ch_dim2, ch_offset, i_1, i_2; + + /* Local variables */ + int i, k; + double ci2, ci3, ci4, cr2, cr3, cr4, ti1, ti2, ti3, ti4, tr1, tr2, tr3, tr4; + + /* Parameter adjustments */ + cc_dim1 = *ido; + cc_offset = cc_dim1 * 5 + 1; + cc -= cc_offset; + ch_dim1 = *ido; + ch_dim2 = *l1; + ch_offset = ch_dim1 * (ch_dim2 + 1) + 1; + ch -= ch_offset; + --wa1; + --wa2; + --wa3; + + /* Function Body */ + if (*ido == 2) { + i_1 = *l1; + for (k = 1; k <= i_1; ++k) { + ti1 = cc[((k << 2) + 1) * cc_dim1 + 2] + - cc[((k << 2) + 3) * cc_dim1 + 2]; + ti2 = cc[((k << 2) + 1) * cc_dim1 + 2] + + cc[((k << 2) + 3) * cc_dim1 + 2]; + tr4 = *isign * (cc[((k << 2) + 2) * cc_dim1 + 2] + - cc[((k << 2) + 4) * cc_dim1 + 2]); + ti3 = cc[((k << 2) + 2) * cc_dim1 + 2] + + cc[((k << 2) + 4) * cc_dim1 + 2]; + tr1 = cc[((k << 2) + 1) * cc_dim1 + 1] + - cc[((k << 2) + 3) * cc_dim1 + 1]; + tr2 = cc[((k << 2) + 1) * cc_dim1 + 1] + + cc[((k << 2) + 3) * cc_dim1 + 1]; + ti4 = *isign * (cc[((k << 2) + 4) * cc_dim1 + 1] + - cc[((k << 2) + 2) * cc_dim1 + 1]); + tr3 = cc[((k << 2) + 2) * cc_dim1 + 1] + + cc[((k << 2) + 4) * cc_dim1 + 1]; + ch[(k + ch_dim2) * ch_dim1 + 1] = tr2 + tr3; + ch[(k + ch_dim2 * 3) * ch_dim1 + 1] = tr2 - tr3; + ch[(k + ch_dim2) * ch_dim1 + 2] = ti2 + ti3; + ch[(k + ch_dim2 * 3) * ch_dim1 + 2] = ti2 - ti3; + ch[(k + (ch_dim2 << 1)) * ch_dim1 + 1] = tr1 + tr4; + ch[(k + (ch_dim2 << 2)) * ch_dim1 + 1] = tr1 - tr4; + ch[(k + (ch_dim2 << 1)) * ch_dim1 + 2] = ti1 + ti4; + ch[(k + (ch_dim2 << 2)) * ch_dim1 + 2] = ti1 - ti4; + } + } + else { + i_1 = *l1; + for (k = 1; k <= i_1; ++k) { + i_2 = *ido; + for (i = 2; i <= i_2; i += 2) { + ti1 = cc[i + ((k << 2) + 1) * cc_dim1] + - cc[i + ((k << 2) + 3) * cc_dim1]; + ti2 = cc[i + ((k << 2) + 1) * cc_dim1] + + cc[i + ((k << 2) + 3) * cc_dim1]; + ti3 = cc[i + ((k << 2) + 2) * cc_dim1] + + cc[i + ((k << 2) + 4) * cc_dim1]; + tr4 = *isign * (cc[i + ((k << 2) + 2) * cc_dim1] + - cc[i + ((k << 2) + 4) * cc_dim1]); + tr1 = cc[i - 1 + ((k << 2) + 1) * cc_dim1] + - cc[i - 1 + ((k << 2) + 3) * cc_dim1]; + tr2 = cc[i - 1 + ((k << 2) + 1) * cc_dim1] + + cc[i - 1 + ((k << 2) + 3) * cc_dim1]; + ti4 = *isign * (cc[i - 1 + ((k << 2) + 4) * cc_dim1] + - cc[i - 1 + ((k << 2) + 2) * cc_dim1]); + tr3 = cc[i - 1 + ((k << 2) + 2) * cc_dim1] + + cc[i - 1 + ((k << 2) + 4) * cc_dim1]; + ch[i - 1 + (k + ch_dim2) * ch_dim1] = tr2 + tr3; + cr3 = tr2 - tr3; + ch[i + (k + ch_dim2) * ch_dim1] = ti2 + ti3; + ci3 = ti2 - ti3; + cr2 = tr1 + tr4; + cr4 = tr1 - tr4; + ci2 = ti1 + ti4; + ci4 = ti1 - ti4; + ch[i - 1 + (k + (ch_dim2 << 1)) * ch_dim1] = wa1[i - 1] * cr2 + + *isign * wa1[i] * ci2; + ch[i + (k + (ch_dim2 << 1)) * ch_dim1] = wa1[i - 1] * ci2 + - *isign * wa1[i] * cr2; + ch[i - 1 + (k + ch_dim2 * 3) * ch_dim1] = wa2[i - 1] * cr3 + + *isign * wa2[i] * ci3; + ch[i + (k + ch_dim2 * 3) * ch_dim1] = wa2[i - 1] * ci3 + - *isign * wa2[i] * cr3; + ch[i - 1 + (k + (ch_dim2 << 2)) * ch_dim1] = wa3[i - 1] * cr4 + + *isign * wa3[i] * ci4; + ch[i + (k + (ch_dim2 << 2)) * ch_dim1] = wa3[i - 1] * ci4 + - *isign * wa3[i] * cr4; + } + } + } + return 0; +} + +static int pass5_(ido, l1, cc, ch, wa1, wa2, wa3, wa4, isign) + int *ido, *l1; + double *cc, *ch, *wa1, *wa2, *wa3, *wa4; + int *isign; +{ + /* System generated locals */ + int cc_dim1, cc_offset, ch_dim1, ch_dim2, ch_offset, i_1, i_2; + + /* Local variables */ + int i, k; + double ci2, ci3, ci4, ci5, di3, di4, di5, di2, cr2, cr3, cr5, cr4, ti2, ti3, + ti4, ti5, dr3, dr4, dr5, dr2, tr2, tr3, tr4, tr5, ti11, ti12, tr11, + tr12; + + /* Parameter adjustments */ + cc_dim1 = *ido; + cc_offset = cc_dim1 * 6 + 1; + cc -= cc_offset; + ch_dim1 = *ido; + ch_dim2 = *l1; + ch_offset = ch_dim1 * (ch_dim2 + 1) + 1; + ch -= ch_offset; + --wa1; + --wa2; + --wa3; + --wa4; + + /* Function Body */ + tr11 = .309016994374947; + ti11 = -(*isign) * .951056516295154; + tr12 = -.809016994374947; + ti12 = -(*isign) * .587785252292473; + if (*ido == 2) { + i_1 = *l1; + for (k = 1; k <= i_1; ++k) { + ti5 = cc[(k * 5 + 2) * cc_dim1 + 2] - cc[(k * 5 + 5) * cc_dim1 + 2]; + ti2 = cc[(k * 5 + 2) * cc_dim1 + 2] + cc[(k * 5 + 5) * cc_dim1 + 2]; + ti4 = cc[(k * 5 + 3) * cc_dim1 + 2] - cc[(k * 5 + 4) * cc_dim1 + 2]; + ti3 = cc[(k * 5 + 3) * cc_dim1 + 2] + cc[(k * 5 + 4) * cc_dim1 + 2]; + tr5 = cc[(k * 5 + 2) * cc_dim1 + 1] - cc[(k * 5 + 5) * cc_dim1 + 1]; + tr2 = cc[(k * 5 + 2) * cc_dim1 + 1] + cc[(k * 5 + 5) * cc_dim1 + 1]; + tr4 = cc[(k * 5 + 3) * cc_dim1 + 1] - cc[(k * 5 + 4) * cc_dim1 + 1]; + tr3 = cc[(k * 5 + 3) * cc_dim1 + 1] + cc[(k * 5 + 4) * cc_dim1 + 1]; + ch[(k + ch_dim2) * ch_dim1 + 1] = cc[(k * 5 + 1) * cc_dim1 + 1] + + tr2 + tr3; + ch[(k + ch_dim2) * ch_dim1 + 2] = cc[(k * 5 + 1) * cc_dim1 + 2] + + ti2 + ti3; + cr2 = cc[(k * 5 + 1) * cc_dim1 + 1] + tr11 * tr2 + tr12 * tr3; + ci2 = cc[(k * 5 + 1) * cc_dim1 + 2] + tr11 * ti2 + tr12 * ti3; + cr3 = cc[(k * 5 + 1) * cc_dim1 + 1] + tr12 * tr2 + tr11 * tr3; + ci3 = cc[(k * 5 + 1) * cc_dim1 + 2] + tr12 * ti2 + tr11 * ti3; + cr5 = ti11 * tr5 + ti12 * tr4; + ci5 = ti11 * ti5 + ti12 * ti4; + cr4 = ti12 * tr5 - ti11 * tr4; + ci4 = ti12 * ti5 - ti11 * ti4; + ch[(k + (ch_dim2 << 1)) * ch_dim1 + 1] = cr2 - ci5; + ch[(k + ch_dim2 * 5) * ch_dim1 + 1] = cr2 + ci5; + ch[(k + (ch_dim2 << 1)) * ch_dim1 + 2] = ci2 + cr5; + ch[(k + ch_dim2 * 3) * ch_dim1 + 2] = ci3 + cr4; + ch[(k + ch_dim2 * 3) * ch_dim1 + 1] = cr3 - ci4; + ch[(k + (ch_dim2 << 2)) * ch_dim1 + 1] = cr3 + ci4; + ch[(k + (ch_dim2 << 2)) * ch_dim1 + 2] = ci3 - cr4; + ch[(k + ch_dim2 * 5) * ch_dim1 + 2] = ci2 - cr5; + } + } + else { + i_1 = *l1; + for (k = 1; k <= i_1; ++k) { + i_2 = *ido; + for (i = 2; i <= i_2; i += 2) { + ti5 = cc[i + (k * 5 + 2) * cc_dim1] - cc[i + (k * 5 + 5) * cc_dim1]; + ti2 = cc[i + (k * 5 + 2) * cc_dim1] + cc[i + (k * 5 + 5) * cc_dim1]; + ti4 = cc[i + (k * 5 + 3) * cc_dim1] - cc[i + (k * 5 + 4) * cc_dim1]; + ti3 = cc[i + (k * 5 + 3) * cc_dim1] + cc[i + (k * 5 + 4) * cc_dim1]; + tr5 = cc[i - 1 + (k * 5 + 2) * cc_dim1] + - cc[i - 1 + (k * 5 + 5) * cc_dim1]; + tr2 = cc[i - 1 + (k * 5 + 2) * cc_dim1] + + cc[i - 1 + (k * 5 + 5) * cc_dim1]; + tr4 = cc[i - 1 + (k * 5 + 3) * cc_dim1] + - cc[i - 1 + (k * 5 + 4) * cc_dim1]; + tr3 = cc[i - 1 + (k * 5 + 3) * cc_dim1] + + cc[i - 1 + (k * 5 + 4) * cc_dim1]; + ch[i - 1 + (k + ch_dim2) * ch_dim1] = cc[i - 1 + (k * 5 + 1) + * cc_dim1] + tr2 + tr3; + ch[i + (k + ch_dim2) * ch_dim1] = cc[i + (k * 5 + 1) + * cc_dim1] + ti2 + ti3; + cr2 = cc[i - 1 + (k * 5 + 1) * cc_dim1] + tr11 * tr2 + tr12 * tr3; + ci2 = cc[i + (k * 5 + 1) * cc_dim1] + tr11 * ti2 + tr12 * ti3; + + cr3 = cc[i - 1 + (k * 5 + 1) * cc_dim1] + tr12 * tr2 + tr11 * tr3; + ci3 = cc[i + (k * 5 + 1) * cc_dim1] + tr12 * ti2 + tr11 * ti3; + + cr5 = ti11 * tr5 + ti12 * tr4; + ci5 = ti11 * ti5 + ti12 * ti4; + cr4 = ti12 * tr5 - ti11 * tr4; + ci4 = ti12 * ti5 - ti11 * ti4; + dr3 = cr3 - ci4; + dr4 = cr3 + ci4; + di3 = ci3 + cr4; + di4 = ci3 - cr4; + dr5 = cr2 + ci5; + dr2 = cr2 - ci5; + di5 = ci2 - cr5; + di2 = ci2 + cr5; + ch[i - 1 + (k + (ch_dim2 << 1)) * ch_dim1] = wa1[i - 1] * dr2 + + *isign * wa1[i] * di2; + ch[i + (k + (ch_dim2 << 1)) * ch_dim1] = wa1[i - 1] * di2 + - *isign * wa1[i] * dr2; + ch[i - 1 + (k + ch_dim2 * 3) * ch_dim1] = wa2[i - 1] * dr3 + + *isign * wa2[i] * di3; + ch[i + (k + ch_dim2 * 3) * ch_dim1] = wa2[i - 1] * di3 + - *isign * wa2[i] * dr3; + ch[i - 1 + (k + (ch_dim2 << 2)) * ch_dim1] = wa3[i - 1] * dr4 + + *isign * wa3[i] * di4; + ch[i + (k + (ch_dim2 << 2)) * ch_dim1] = wa3[i - 1] * di4 + - *isign * wa3[i] * dr4; + ch[i - 1 + (k + ch_dim2 * 5) * ch_dim1] = wa4[i - 1] * dr5 + + *isign * wa4[i] * di5; + ch[i + (k + ch_dim2 * 5) * ch_dim1] = wa4[i - 1] * di5 + - *isign * wa4[i] * dr5; + } + } + } + return 0; +} diff --git a/lib/cholesky.c b/lib/cholesky.c new file mode 100644 index 0000000..21d1e18 --- /dev/null +++ b/lib/cholesky.c @@ -0,0 +1,81 @@ +/* choldecomp - Cholesky decomposition routines. */ +/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */ +/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */ +/* You may give out copies of this software; for conditions see the */ +/* file COPYING included with this distribution. */ + +#include "linalg.h" + +/* +choldecomp(a, n) + RMatrix a; + int n; +{ + int i, j, k; + + for (i = 0; i < n; i++) { + for (k = 0; k < i; k++) + a[i][i] -= a[k][i] * a[k][i]; + a[i][i] = (a[i][i] > 0) ? sqrt(a[i][i]) : 0.0; + for (j = i + 1; j < n; j++) { + for (k = 0; k < i; k++) a[i][j] -= a[k][i] * a[k][j]; + a[i][j] = (a[i][i] > 0.0) ? a[i][j] / a[i][i] : 0.0; + } + } + for (i = 0; i < n; i++) + for (j = 0; j < i; j++) + a[i][j] = 0.0; +} +*/ + +static double Max(a, b) + double a, b; +{ + return(a > b ? a : b); +} + +choldecomp(a, n, maxoffl, maxadd) + RMatrix a; + int n; + double maxoffl, *maxadd; +{ + double minl, minljj, minl2; + int i, j, k; + + minl = pow(macheps(), 0.25) * maxoffl; + minl2 = 0.0; + + if (maxoffl == 0.0) { + for (i = 0; i < n; i++) + maxoffl = Max(fabs(a[i][i]), maxoffl); + maxoffl = sqrt(maxoffl); + minl2 = sqrt(macheps()) * maxoffl; + } + + *maxadd = 0.0; + for (j = 0; j < n; j++) { + for (i = 0; i < j; i++) a[j][j] -= a[j][i] * a[j][i]; + + minljj = 0.0; + + for (i = j + 1; i < n; i++) { + a[i][j] = a[j][i]; + for (k = 0; k < j; k++) a[i][j] -= a[i][k] * a[j][k]; + minljj = Max(fabs(a[i][j]), minljj); + } + + minljj = Max(minljj / maxoffl, minl); + + if (a[j][j] > minljj * minljj) a[j][j] = sqrt(a[j][j]); + else { + if (minljj < minl2) minljj = minl2; + *maxadd = Max(*maxadd, minljj * minljj - a[j][j]); + a[j][j] = minljj; + } + + for (i = j + 1; i < n; i++) a[i][j] /= a[j][j]; + } + + for (i = 0; i < n; i++) + for (j = i + 1; j < n; j++) a[i][j] = 0.0; +} diff --git a/lib/clib.make b/lib/clib.make new file mode 100644 index 0000000..c7c8350 --- /dev/null +++ b/lib/clib.make @@ -0,0 +1,134 @@ +############################################################# +## Uncomment one of the following two groups for a generic +## application or one compiled to use 68020/68881 intructions. +## +## Generic application +## +CC = C +## +## MC68020/MC68881 application +## +#CC = C -mc68881 -elems881 -mc68020 +############################################################# +############################################################# +# File: clib.make +# Target: clib +# Sources: betabase.c +# bivnor.c +# cbayes.c +# cdists.c +# cfft.c +# cholesky.c +# clinalg.c +# complex.c +# derivatives.c +# functions.c +# gamln.c +# gammabase.c +# kernel.c +# linalgdata.c +# lowess.c +# ludecomp.c +# makerotation.c +# minimize.c +# nor.c +# ppnd.c +# qrdecomp.c +# rcondest.c +# splines.c +# studentbase.c +# svdecomp.c +# utils.c +# mclglue.c +# Created: Friday, August 17, 1990 8:16:25 AM + + +OBJECTS = 6 + betabase.c.o 6 + bivnor.c.o 6 + cbayes.c.o 6 + cdists.c.o 6 + cfft.c.o 6 + cholesky.c.o 6 + clinalg.c.o 6 + complex.c.o 6 + derivatives.c.o 6 + eigen.c.o 6 + functions.c.o 6 + gamln.c.o 6 + gammabase.c.o 6 + kernel.c.o 6 + linalgdata.c.o 6 + lowess.c.o 6 + ludecomp.c.o 6 + makerotation.c.o 6 + minimize.c.o 6 + nor.c.o 6 + ppnd.c.o 6 + qrdecomp.c.o 6 + rcondest.c.o 6 + splines.c.o 6 + studentbase.c.o 6 + svdecomp.c.o 6 + + +betabase.c.o D clib.make betabase.c + {CC} -s BETABASE betabase.c +bivnor.c.o D clib.make bivnor.c + {CC} -s BIVNOR bivnor.c +cbayes.c.o D clib.make cbayes.c + {CC} -s BAYES cbayes.c +cdists.c.o D clib.make cdists.c + {CC} -s CDISTS cdists.c +cfft.c.o D clib.make cfft.c + {CC} -s CFFT cfft.c +cholesky.c.o D clib.make cholesky.c + {CC} -s CHOLESKY cholesky.c +clinalg.c.o D clib.make clinalg.c + {CC} -s LINALG clinalg.c +complex.c.o D clib.make complex.c + {CC} -s COMPLEX complex.c +derivatives.c.o D clib.make derivatives.c + {CC} -s BAYES derivatives.c +eigen.c.o D clib.make eigen.c + {CC} -s EIGEN eigen.c +functions.c.o D clib.make functions.c + {CC} -s BAYES functions.c +gamln.c.o D clib.make gamln.c + {CC} -s GAMMA gamln.c +gammabase.c.o D clib.make gammabase.c + {CC} -s GAMMA gammabase.c +kernel.c.o D clib.make kernel.c + {CC} -s SMOOTH kernel.c +linalgdata.c.o D clib.make linalgdata.c + {CC} -s LINALG linalgdata.c +lowess.c.o D clib.make lowess.c + {CC} -s SMOOTH lowess.c +ludecomp.c.o D clib.make ludecomp.c + {CC} -s LUDECOMP ludecomp.c +makerotation.c.o D clib.make makerotation.c + {CC} -s MAKEROT makerotation.c +minimize.c.o D clib.make minimize.c + {CC} -s BAYES minimize.c +nor.c.o D clib.make nor.c + {CC} -s NORMAL nor.c +ppnd.c.o D clib.make ppnd.c + {CC} -s NORMAL ppnd.c +qrdecomp.c.o D clib.make qrdecomp.c + {CC} -d SCALE=XSSCALE -s QRDECOMP qrdecomp.c # needed besause of name conflict with SCALE??? +rcondest.c.o D clib.make rcondest.c + {CC} -s RCONDEST rcondest.c +splines.c.o D clib.make splines.c + {CC} -s SMOOTH splines.c +studentbase.c.o D clib.make studentbase.c + {CC} -s STUDENT studentbase.c +svdecomp.c.o D clib.make svdecomp.c + {CC} -s SVDECOMP svdecomp.c +mclglue.c.o D clib.make mclglue.c + {CC} -s LSGLUE mclglue.c + +clib.o DD clib.make {OBJECTS} mclglue.c.o ccldists.c.o + lib -o clib.o {OBJECTS} + +clib DD clib.make clib.o mclglue.c.o + diff --git a/lib/clinalg.c b/lib/clinalg.c new file mode 100644 index 0000000..77bfe70 --- /dev/null +++ b/lib/clinalg.c @@ -0,0 +1,211 @@ +/* clinalg - C interface to basic linear algebra routines. */ +/* Copyright (c) 1990, by Luke Tierney */ + +#include "linalg.h" + +#ifdef INTPTR +typedef int PTR; +#else +typedef char *PTR; +#endif + +extern double rcondest(); + +int min (x, y) int x, y; { return((x < y) ? x : y); } +int max (x, y) int x, y; { return((x > y) ? x : y); } + +/************************************************************************/ +/** **/ +/** Machine Epsilon Determination **/ +/** **/ +/************************************************************************/ + +double macheps() +{ + static int calculated = FALSE; + static double epsilon = 1.0; + + if (! calculated) + while (1.0 + epsilon / 2.0 != 1.0) epsilon = epsilon / 2.0; + calculated = TRUE; + return(epsilon); +} + +/************************************************************************/ +/** **/ +/** Lisp Interfaces to Linear Algebra Routines **/ +/** **/ +/************************************************************************/ + +chol_decomp_front(mat, n, dpars) + PTR mat, dpars; + int n; +{ + double *dp = (double *) dpars; + choldecomp((double **) mat, n, *dp, dp + 1); +} + +int lu_decomp_front(mat, n, iv, mode, dp) + PTR mat, iv, dp; + int n, mode; +{ + return(crludcmp((char **) mat, n, (int *) iv, mode, (double *) dp)); +} + +int lu_solve_front(a, n, indx, b, mode) + PTR a, indx, b; + int n, mode; +{ + return(crlubksb((char **) a, n, (int *) indx, (char *) b, mode)); +} + +int lu_inverse_front(pmat, n, piv, pv, mode, pinv) + PTR pmat, piv, pv, pinv; + int n, mode; +{ + Matrix mat = (Matrix) pmat, inv = (Matrix) pinv; + IVector iv = (IVector) piv; + Vector v = (Vector) pv; + CMatrix cinv; + RMatrix rinv; + CVector cv; + RVector rv; + double d; + int i, j, singular; + + singular = crludcmp(mat, n, iv, mode, &d); + + if (! singular) { + rinv = (RMatrix) inv; + cinv = (CMatrix) inv; + rv = (RVector) v; + cv = (CVector) v; + + for (j = 0; j < n; j++) { + for (i = 0; i < n; i++) { + if (mode == RE) rv[i] = rinv[i][j]; + else cv[i] = cinv[i][j]; + } + + singular = singular || crlubksb(mat, n, iv, v, mode); + + for (i = 0; i < n; i++) { + if (mode == RE) rinv[i][j] = rv[i]; + else cinv[i][j] = cv[i]; + } + } + } + return(singular); +} + +sv_decomp_front(mat, m, n, w, v) + PTR mat, w, v; + int m, n; +{ + return(svdcmp((char **) mat, m, n, (char *) w, (char **) v)); +} + +qr_decomp_front(mat, m, n, v, jpvt, pivot) + PTR mat, v, jpvt; + int m, n, pivot; +{ + qrdecomp((char **) mat, m, n, (char **) v, (char *) jpvt, pivot); +} + +double rcondest_front(mat, n) + PTR mat; + int n; +{ + return(rcondest((char **) mat, n)); +} + +make_rotation_front(n, rot, x, y, use_alpha, alpha) + int n, use_alpha; + PTR rot, x, y; + double alpha; +{ + make_rotation(n, (char **) rot, (char *) x, (char *) y, use_alpha, alpha); +} + +int eigen_front(a, n, w, z, fv1) + PTR a, w, z, fv1; + int n; +{ + int ierr; + + eigen(&n, &n, (char *) a, (char *) w, (char *) z, (char *) fv1, &ierr); + return(ierr); +} + +fft_front(n, x, work, isign) + int n, isign; + PTR x, work; +{ + cfft(n, (char *) x, (char *) work, isign); +} + +int base_lowess_front(x, y, n, f, nsteps, delta, ys, rw, res) + PTR x, y, ys, rw, res; + int n, nsteps; + double f, delta; +{ + return(lowess((char *) x, (char *) y, n, f, nsteps, delta, + (char *) ys, (char *) rw, (char *) res)); +} + +range_to_rseq(n, px, ns, pxs) + int n, ns; + PTR px, pxs; +{ + int i; + double xmin, xmax, *x, *xs; + + x = (double *) px; + xs = (double *) pxs; + for (xmax = xmin = x[0], i = 1; i < n; i++) { + if (x[i] > xmax) xmax = x[i]; + if (x[i] < xmin) xmin = x[i]; + } + for (i = 0; i < ns; i++) + xs[i] = xmin + (xmax - xmin) * ((double) i) / ((double) (ns - 1)); +} + +int spline_front(n, x, y, ns, xs, ys, work) + PTR x, y, xs, ys, work; + int n, ns; +{ + return(fit_spline(n, (char *) x, (char *) y, + ns, (char *) xs, (char *) ys, (char *) work)); +} + +kernel_dens_front(x, n, width, xs, ys, ns, code) + PTR x, xs, ys; + int n, ns, code; + double width; +{ + int ktype; + + if (code == 0) ktype = 'U'; + else if (code == 1) ktype = 'T'; + else if (code == 2) ktype = 'G'; + else ktype = 'B'; + + return(kernel_smooth((char *) x, nil, n, width, nil, nil, + (char *) xs, (char *) ys, ns, ktype)); +} + +int kernel_smooth_front(x, y, n, width, xs, ys, ns, code) + PTR x, y, xs, ys; + int n, ns, code; + double width; +{ + int ktype; + + if (code == 0) ktype = 'U'; + else if (code == 1) ktype = 'T'; + else if (code == 2) ktype = 'G'; + else ktype = 'B'; + + return(kernel_smooth((char *) x, (char *) y, n, width, nil, nil, + (char *) xs, (char *) ys, ns, ktype)); +} diff --git a/lib/complex.c b/lib/complex.c new file mode 100644 index 0000000..10711b6 --- /dev/null +++ b/lib/complex.c @@ -0,0 +1,115 @@ +/* complex - Complex number functions */ +/* Copyright (c) 1990, by Luke Tierney */ + +#include "xmath.h" +#include "complex.h" + +static double phase(c) + Complex c; +{ + double phi; + + if (c.real == 0.0) { + if (c.imag > 0.0) phi = PI / 2; + else if (c.imag == 0.0) phi = 0.0; + else phi = -PI / 2; + } + else { + phi = atan(c.imag / c.real); + if (c.real < 0.0) { + if (c.imag > 0.0) phi += PI; + else if (c.imag < 0.0) phi -= PI; + else phi = PI; + } + } + return(phi); +} + +double modulus(c) + Complex c; +{ + return(sqrt(c.real * c.real + c.imag * c.imag)); +} + +Complex cart2complex(real, imag) + double real, imag; +{ + Complex val; + val.real = real; + val.imag = imag; + return(val); +} + +static Complex polar2complex(mod, phi) + double mod, phi; +{ + Complex val; + double cs, sn; + + if (phi == 0) { + cs = 1.0; + sn = 0.0; + } + else if (phi == PI / 2) { + cs = 0.0; + sn = 1.0; + } + else if (phi == PI) { + cs = -1.0; + sn = 0.0; + } + else if (phi == -PI / 2) { + cs = 0.0; + sn = -1.0; + } + else { + cs = cos(phi); + sn = sin(phi); + } + val.real = mod * cs; + val.imag = mod * sn; + return(val); +} + +Complex cadd(c1, c2) + Complex c1, c2; +{ + return(cart2complex(c1.real + c2.real, c1.imag + c2.imag)); +} + +Complex csub(c1, c2) + Complex c1, c2; +{ + return(cart2complex(c1.real - c2.real, c1.imag - c2.imag)); +} + +Complex cmul(c1, c2) + Complex c1, c2; +{ + double m1, m2, p1, p2; + + m1 = modulus(c1); + p1 = phase(c1); + m2 = modulus(c2); + p2 = phase(c2); + return(polar2complex(m1 * m2, p1 + p2)); +} + +Complex cdiv(c1, c2) + Complex c1, c2; +{ + double m1, m2, p1, p2; + + m1 = modulus(c1); + p1 = phase(c1); + m2 = modulus(c2); + p2 = phase(c2); + checkfzero(m2); + return(polar2complex(m1 / m2, p1 - p2)); +} + +static checkfzero(x) + double x; +{ + if (x == 0.0) xlfail("division by zero"); +} diff --git a/lib/complex.h b/lib/complex.h new file mode 100644 index 0000000..54ade1e --- /dev/null +++ b/lib/complex.h @@ -0,0 +1,14 @@ +typedef struct { + double real, imag; +} Complex; + +#ifndef PI +#define PI 3.141592653589793 +#endif PI + +extern Complex makecomplex(); +extern Complex cart2complex(), polar2complex(); +extern Complex csqrt(), cexp(), clog(), cexpt(), csin(), ccos(), ctan(); +extern Complex casin(), cacos(), catan(); +extern Complex cadd(), csub(), cmul(), cdiv(); +extern double phase(), modulus(); diff --git a/lib/derivatives.c b/lib/derivatives.c new file mode 100644 index 0000000..c4852c5 --- /dev/null +++ b/lib/derivatives.c @@ -0,0 +1,67 @@ +/* derivatives - for Bayes code in XLISP-STAT and S */ +/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */ +/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */ +/* You may give out copies of this software; for conditions see the */ +/* file COPYING included with this distribution. */ + +# include "xmath.h" +extern double macheps(); + +typedef double **RMatrix, *RVector; + +# define nil 0L +# define FALSE 0 +# define TRUE 1 + +numergrad(n, x, grad, fsum, ffun, h, typx) + int n; + RVector x, grad, fsum, typx; + int (*ffun)(); + double h; +{ + int i; + double old_xi, f1, f2, hi; + + for (i = 0; i < n; i++) { + old_xi = x[i]; + hi = (typx != nil) ? typx[i] * h : h; + x[i] = old_xi + hi; + (*ffun)(x, &f1, nil, nil); + x[i] = old_xi - hi; + (*ffun)(x, &f2, nil, nil); + x[i] = old_xi; + grad[i] = (f1 - f2) / (2.0 * hi); + fsum[i] = f1 + f2; + } +} + +numerhess(n, x, hess, f, fsum, ffun, h, typx) + int n; + RVector x, fsum, typx; + RMatrix hess; + int (*ffun)(); + double h, f; +{ + int i, j; + double old_xi, old_xj, f1, f2, hi, hj; + + for (i = 0; i < n; i++) { + hi = (typx != nil) ? typx[i] * h : h; + hess[i][i] = (fsum[i] - 2 * f) / (hi * hi); + for (j = i + 1; j < n; j++) { + hj = (typx != nil) ? typx[j] * h : h; + old_xi = x[i]; + old_xj = x[j]; + x[i] = old_xi + hi; + x[j] = old_xj + hj; + (*ffun)(x, &f1, nil, nil); + x[i] = old_xi - hi; + x[j] = old_xj - hj; + (*ffun)(x, &f2, nil, nil); + x[i] = old_xi; + x[j] = old_xj; + hess[i][j] = (2 * f + f1 + f2 - fsum[i] - fsum[j]) / (2.0 * hi * hj); + hess[j][i] = hess[i][j]; + } + } +} diff --git a/lib/eigen.c b/lib/eigen.c new file mode 100644 index 0000000..e45d4f1 --- /dev/null +++ b/lib/eigen.c @@ -0,0 +1,625 @@ +/* eigen.f -- translated by f2c (version of 19 December 1990 16:50:21). + and modified. */ + +#include "xmath.h" + +#define integer int +#define real float +#define doublereal double +#define Min(x,y) ((x) > (y) ? (y) : (x)) +#define Max(x,y) ((x) > (y) ? (x) : (y)) +#define Abs(x) ((x) >= 0 ? (x) : -(x)) + +static /* Subroutine */ int tred2(), tql2(); +static doublereal pythag(), d_sign(); + +/* Table of constant values */ + +static doublereal c_b39 = 1.; + +/* Subroutine */ int eigen(nm, n, a, w, z, fv1, ierr) +integer *nm, *n; +doublereal *a, *w, *z, *fv1; +integer *ierr; +{ + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset; + +/* THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF */ +/* SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) */ +/* TO FIND THE EIGENVALUES AND EIGENVECTORS */ +/* OF A REAL SYMMETRIC MATRIX. */ + +/* ON INPUT */ + +/* NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL */ +/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ +/* DIMENSION STATEMENT. */ + +/* N IS THE ORDER OF THE MATRIX A. */ + +/* A CONTAINS THE REAL SYMMETRIC MATRIX. */ + +/* ON OUTPUT */ + +/* W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. */ + +/* Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. */ + +/* IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR */ +/* COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT */ +/* AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. */ + +/* FV1 IS A TEMPORARY STORAGE ARRAY. */ + +/* ------------------------------------------------------------------ +*/ + + /* Parameter adjustments */ + --fv1; + z_dim1 = *nm; + z_offset = z_dim1 + 1; + z -= z_offset; + --w; + a_dim1 = *nm; + a_offset = a_dim1 + 1; + a -= a_offset; + + /* Function Body */ + if (*n <= *nm) { + goto L10; + } + *ierr = *n * 10; + goto L50; +/* .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... */ +L10: + tred2(nm, n, &a[a_offset], &w[1], &fv1[1], &z[z_offset]); + tql2(nm, n, &w[1], &fv1[1], &z[z_offset], ierr); +L50: + return 0; +} /* eigen */ + +static /* Subroutine */ int tred2(nm, n, a, d, e, z) +integer *nm, *n; +doublereal *a, *d, *e, *z; +{ + /* System generated locals */ + integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + static doublereal f, g, h; + static integer i, j, k, l; + static doublereal scale, hh; + static integer ii, jp1; + + + +/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, */ +/* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. */ +/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). */ + +/* THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A */ +/* SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING */ +/* ORTHOGONAL SIMILARITY TRANSFORMATIONS. */ + +/* ON INPUT */ + +/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ +/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ +/* DIMENSION STATEMENT. */ + +/* N IS THE ORDER OF THE MATRIX. */ + +/* A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE */ +/* LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. */ + +/* ON OUTPUT */ + +/* D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. */ + +/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL */ +/* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. */ + +/* Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX */ +/* PRODUCED IN THE REDUCTION. */ + +/* A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. */ + +/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */ +/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +*/ + +/* THIS VERSION DATED AUGUST 1983. */ + +/* ------------------------------------------------------------------ +*/ + + /* Parameter adjustments */ + z_dim1 = *nm; + z_offset = z_dim1 + 1; + z -= z_offset; + --e; + --d; + a_dim1 = *nm; + a_offset = a_dim1 + 1; + a -= a_offset; + + /* Function Body */ + i__1 = *n; + for (i = 1; i <= i__1; ++i) { + + i__2 = *n; + for (j = i; j <= i__2; ++j) { +/* L80: */ + z[j + i * z_dim1] = a[j + i * a_dim1]; + } + + d[i] = a[*n + i * a_dim1]; +/* L100: */ + } + + if (*n == 1) { + goto L510; + } +/* .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... */ + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i = *n + 2 - ii; + l = i - 1; + h = 0.; + scale = 0.; + if (l < 2) { + goto L130; + } +/* .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... */ + i__2 = l; + for (k = 1; k <= i__2; ++k) { +/* L120: */ + scale += (d__1 = d[k], Abs(d__1)); + } + + if (scale != 0.) { + goto L140; + } +L130: + e[i] = d[l]; + + i__2 = l; + for (j = 1; j <= i__2; ++j) { + d[j] = z[l + j * z_dim1]; + z[i + j * z_dim1] = 0.; + z[j + i * z_dim1] = 0.; +/* L135: */ + } + + goto L290; + +L140: + i__2 = l; + for (k = 1; k <= i__2; ++k) { + d[k] /= scale; + h += d[k] * d[k]; +/* L150: */ + } + + f = d[l]; + d__1 = sqrt(h); + g = -d_sign(&d__1, &f); + e[i] = scale * g; + h -= f * g; + d[l] = f - g; +/* .......... FORM A*U .......... */ + i__2 = l; + for (j = 1; j <= i__2; ++j) { +/* L170: */ + e[j] = 0.; + } + + i__2 = l; + for (j = 1; j <= i__2; ++j) { + f = d[j]; + z[j + i * z_dim1] = f; + g = e[j] + z[j + j * z_dim1] * f; + jp1 = j + 1; + if (l < jp1) { + goto L220; + } + + i__3 = l; + for (k = jp1; k <= i__3; ++k) { + g += z[k + j * z_dim1] * d[k]; + e[k] += z[k + j * z_dim1] * f; +/* L200: */ + } + +L220: + e[j] = g; +/* L240: */ + } +/* .......... FORM P .......... */ + f = 0.; + + i__2 = l; + for (j = 1; j <= i__2; ++j) { + e[j] /= h; + f += e[j] * d[j]; +/* L245: */ + } + + hh = f / (h + h); +/* .......... FORM Q .......... */ + i__2 = l; + for (j = 1; j <= i__2; ++j) { +/* L250: */ + e[j] -= hh * d[j]; + } +/* .......... FORM REDUCED A .......... */ + i__2 = l; + for (j = 1; j <= i__2; ++j) { + f = d[j]; + g = e[j]; + + i__3 = l; + for (k = j; k <= i__3; ++k) { +/* L260: */ + z[k + j * z_dim1] = z[k + j * z_dim1] - f * e[k] - g * d[k]; + } + + d[j] = z[l + j * z_dim1]; + z[i + j * z_dim1] = 0.; +/* L280: */ + } + +L290: + d[i] = h; +/* L300: */ + } +/* .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... */ + i__1 = *n; + for (i = 2; i <= i__1; ++i) { + l = i - 1; + z[*n + l * z_dim1] = z[l + l * z_dim1]; + z[l + l * z_dim1] = 1.; + h = d[i]; + if (h == 0.) { + goto L380; + } + + i__2 = l; + for (k = 1; k <= i__2; ++k) { +/* L330: */ + d[k] = z[k + i * z_dim1] / h; + } + + i__2 = l; + for (j = 1; j <= i__2; ++j) { + g = 0.; + + i__3 = l; + for (k = 1; k <= i__3; ++k) { +/* L340: */ + g += z[k + i * z_dim1] * z[k + j * z_dim1]; + } + + i__3 = l; + for (k = 1; k <= i__3; ++k) { + z[k + j * z_dim1] -= g * d[k]; +/* L360: */ + } + } + +L380: + i__3 = l; + for (k = 1; k <= i__3; ++k) { +/* L400: */ + z[k + i * z_dim1] = 0.; + } + +/* L500: */ + } + +L510: + i__1 = *n; + for (i = 1; i <= i__1; ++i) { + d[i] = z[*n + i * z_dim1]; + z[*n + i * z_dim1] = 0.; +/* L520: */ + } + + z[*n + *n * z_dim1] = 1.; + e[1] = 0.; + return 0; +} /* tred2 */ + +static /* Subroutine */ int tql2(nm, n, d, e, z, ierr) +integer *nm, *n; +doublereal *d, *e, *z; +integer *ierr; +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + static doublereal c, f, g, h; + static integer i, j, k, l, m; + static doublereal p, r, s, c2, c3; + static integer l1, l2; + static doublereal s2; + static integer ii; + static doublereal dl1, el1; + static integer mml; + static doublereal tst1, tst2; + + + +/* THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, */ +/* NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND */ +/* WILKINSON. */ +/* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). */ + +/* THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS */ +/* OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. */ +/* THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO */ +/* BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS */ +/* FULL MATRIX TO TRIDIAGONAL FORM. */ + +/* ON INPUT */ + +/* NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL */ +/* ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM */ +/* DIMENSION STATEMENT. */ + +/* N IS THE ORDER OF THE MATRIX. */ + +/* D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. */ + +/* E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX */ +/* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. */ + +/* Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE */ +/* REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS */ +/* OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN */ +/* THE IDENTITY MATRIX. */ + +/* ON OUTPUT */ + +/* D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN */ +/* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT */ +/* UNORDERED FOR INDICES 1,2,...,IERR-1. */ + +/* E HAS BEEN DESTROYED. */ + +/* Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC */ +/* TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, */ +/* Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED */ +/* EIGENVALUES. */ + +/* IERR IS SET TO */ +/* ZERO FOR NORMAL RETURN, */ +/* J IF THE J-TH EIGENVALUE HAS NOT BEEN */ +/* DETERMINED AFTER 30 ITERATIONS. */ + +/* CALLS PYTHAG FOR DSQRT(A*A + B*B) . */ + +/* QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, */ +/* MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +*/ + +/* THIS VERSION DATED AUGUST 1983. */ + +/* ------------------------------------------------------------------ +*/ + + /* Parameter adjustments */ + z_dim1 = *nm; + z_offset = z_dim1 + 1; + z -= z_offset; + --e; + --d; + + /* Function Body */ + *ierr = 0; + if (*n == 1) { + goto L1001; + } + + i__1 = *n; + for (i = 2; i <= i__1; ++i) { +/* L100: */ + e[i - 1] = e[i]; + } + + f = 0.; + tst1 = 0.; + e[*n] = 0.; + + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + j = 0; + h = (d__1 = d[l], Abs(d__1)) + (d__2 = e[l], Abs(d__2)); + if (tst1 < h) { + tst1 = h; + } +/* .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... */ + i__2 = *n; + for (m = l; m <= i__2; ++m) { + tst2 = tst1 + (d__1 = e[m], Abs(d__1)); + if (tst2 == tst1) { + goto L120; + } +/* .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT */ +/* THROUGH THE BOTTOM OF THE LOOP .......... */ +/* L110: */ + } + +L120: + if (m == l) { + goto L220; + } +L130: + if (j == 30) { + goto L1000; + } + ++j; +/* .......... FORM SHIFT .......... */ + l1 = l + 1; + l2 = l1 + 1; + g = d[l]; + p = (d[l1] - g) / (e[l] * 2.); + r = pythag(&p, &c_b39); + d[l] = e[l] / (p + d_sign(&r, &p)); + d[l1] = e[l] * (p + d_sign(&r, &p)); + dl1 = d[l1]; + h = g - d[l]; + if (l2 > *n) { + goto L145; + } + + i__2 = *n; + for (i = l2; i <= i__2; ++i) { +/* L140: */ + d[i] -= h; + } + +L145: + f += h; +/* .......... QL TRANSFORMATION .......... */ + p = d[m]; + c = 1.; + c2 = c; + el1 = e[l1]; + s = 0.; + mml = m - l; +/* .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... */ + i__2 = mml; + for (ii = 1; ii <= i__2; ++ii) { + c3 = c2; + c2 = c; + s2 = s; + i = m - ii; + g = c * e[i]; + h = c * p; + r = pythag(&p, &e[i]); + e[i + 1] = s * r; + s = e[i] / r; + c = p / r; + p = c * d[i] - s * g; + d[i + 1] = h + s * (c * g + s * d[i]); +/* .......... FORM VECTOR .......... */ + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + h = z[k + (i + 1) * z_dim1]; + z[k + (i + 1) * z_dim1] = s * z[k + i * z_dim1] + c * h; + z[k + i * z_dim1] = c * z[k + i * z_dim1] - s * h; +/* L180: */ + } + +/* L200: */ + } + + p = -s * s2 * c3 * el1 * e[l] / dl1; + e[l] = s * p; + d[l] = c * p; + tst2 = tst1 + (d__1 = e[l], Abs(d__1)); + if (tst2 > tst1) { + goto L130; + } +L220: + d[l] += f; +/* L240: */ + } +/* .......... ORDER EIGENVALUES AND EIGENVECTORS .......... */ + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i = ii - 1; + k = i; + p = d[i]; + + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d[j] >= p) { + goto L260; + } + k = j; + p = d[j]; +L260: + ; + } + + if (k == i) { + goto L300; + } + d[k] = d[i]; + d[i] = p; + + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + p = z[j + i * z_dim1]; + z[j + i * z_dim1] = z[j + k * z_dim1]; + z[j + k * z_dim1] = p; +/* L280: */ + } + +L300: + ; + } + + goto L1001; +/* .......... SET ERROR -- NO CONVERGENCE TO AN */ +/* EIGENVALUE AFTER 30 ITERATIONS .......... */ +L1000: + *ierr = l; +L1001: + return 0; +} /* tql2 */ + +static doublereal pythag(a, b) +doublereal *a, *b; +{ + /* System generated locals */ + doublereal ret_val, d__1, d__2, d__3; + + /* Local variables */ + static doublereal p, r, s, t, u; + + +/* FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW */ + + +/* Computing MAX */ + d__1 = Abs(*a), d__2 = Abs(*b); + p = Max(d__1,d__2); + if (p == 0.) { + goto L20; + } +/* Computing MIN */ + d__2 = Abs(*a), d__3 = Abs(*b); +/* Computing 2nd power */ + d__1 = Min(d__2,d__3) / p; + r = d__1 * d__1; +L10: + t = r + 4.; + if (t == 4.) { + goto L20; + } + s = r / t; + u = s * 2. + 1.; + p = u * p; +/* Computing 2nd power */ + d__1 = s / u; + r = d__1 * d__1 * r; + goto L10; +L20: + ret_val = p; + return ret_val; +} /* pythag */ + +static double d_sign(a,b) + doublereal *a, *b; +{ + double x; + x = (*a >= 0 ? *a : - *a); + return( *b >= 0 ? x : -x); +} diff --git a/lib/exclglue.c b/lib/exclglue.c new file mode 100644 index 0000000..ab795a9 --- /dev/null +++ b/lib/exclglue.c @@ -0,0 +1,385 @@ +#include "linalg.h" + +extern double rcondest_front(); + +extern double unirand(), gamma(); +extern double normalcdf(), normalquant(), normaldens(), normalrand(), + bnormcdf(); +extern double cauchycdf(), cauchyquant(), cauchydens(), cauchyrand(); +extern double gammacdf(), gammaquant(), gammadens(), gammarand(); +extern double chisqcdf(), chisqquant(), chisqdens(), chisqrand(); +extern double betacdf(), betaquant(), betadens(), betarand(); +extern double tcdf(), tquant(), tdens(), trand(); +extern double fcdf(), fquant(), fdens(), frand(); +extern double poissoncdf(), poissonpmf(); +extern int poissonquant(), poissonrand(); +extern double binomialcdf(), binomialpmf(); +extern int binomialquant(), binomialrand(); + +/***************************************************************************/ +/***************************************************************************/ +/**** ****/ +/**** Basic Utilities ****/ +/**** ****/ +/***************************************************************************/ +/***************************************************************************/ + +/***************************************************************************/ +/** **/ +/** Callback Value Storage **/ +/** **/ +/***************************************************************************/ + +static int excl_integer_value; +static double excl_double_value; + +excl_set_integer_value(x) + int x; +{ + excl_integer_value = x; +} + +excl_set_double_value(x) + double x; +{ + excl_double_value = x; +} + +/***************************************************************************/ +/** **/ +/** Storage Allocation Functions **/ +/** **/ +/***************************************************************************/ + +int la_base_allocate(n, m) + unsigned n, m; +{ + char *p = calloc(n, m); + if (p == nil) xlfail("allocation failed"); + return((int) p); +} + +int la_base_free_alloc(p) + int p; +{ + if (p) free((char *) p); + return(0); +} + +int la_mode_size(mode) + int mode; +{ + switch (mode) { + case IN: return(sizeof(int)); + case RE: return(sizeof(double)); + case CX: return(sizeof(Complex)); + } + return(0); +} + +/***************************************************************************/ +/** **/ +/** Callbacks for Internal Storage **/ +/** **/ +/***************************************************************************/ + +int la_allocate_index, la_free_alloc_index; + +excl_register_la_allocate(f) int f; { la_allocate_index = f; } +excl_register_la_free_alloc(f) int f; { la_free_alloc_index = f; } + +int la_allocate(n, m) + int n, m; +{ + lisp_call(la_allocate_index, n, m); + return(excl_integer_value); +} + +la_free_alloc(p) + int p; +{ + lisp_call(la_free_alloc_index, p); +} + +/***************************************************************************/ +/** **/ +/** Storage Access Functions **/ +/** **/ +/***************************************************************************/ + +int la_get_integer(p, i) + int p, i; +{ + return(*(((int *) p) + i)); +} + +double la_get_double(p, i) + int p, i; +{ + return(*(((double *) p) + i)); +} + +double la_get_complex_real(p, i) + int p, i; +{ + Complex *c = ((Complex *) p) + i; + return(c->real); +} + +double la_get_complex_imag(p, i) + int p, i; +{ + Complex *c = ((Complex *) p) + i; + return(c->imag); +} + +/***************************************************************************/ +/** **/ +/** Storage Mutation Functions **/ +/** **/ +/***************************************************************************/ + +int la_put_integer(p, i, x) + int p, i, x; +{ + *(((int *) p) + i) = x; + return(0); +} + +int la_put_double(p, i, x) + int p, i; + double x; +{ + *(((double *) p) + i) = x; + return(0); +} + +int la_put_complex(p, i, x, y) + int p, i; + double x, y; +{ + Complex *c = ((Complex *) p) + i; + c->real = x; + c->imag = y; + return(0); +} + +/***************************************************************************/ +/** **/ +/** XLISP internal error message emulation **/ +/** **/ +/***************************************************************************/ + +char buf[1000]; + +static int excl_set_buf_char_index; +excl_register_set_buf_char(f) int f; { excl_set_buf_char_index = f; } +set_buf_char(n, c) int n, c; { lisp_call(excl_set_buf_char_index, n, c); } + +static int excl_print_buffer_index; +excl_register_print_buffer(f) int f; { excl_print_buffer_index = f; } +print_buffer(n, m) int n, m; { lisp_call(excl_print_buffer_index, n, m); } + +static int bufpos = 0; + +static resetbuf() { bufpos = 0; } + +static prbuf(s) + char *s; +{ + int i, n; + + n = strlen(s); + for (i = 0; i +#define PRINTSTR(s) printf(s) +#else +# include "xmath.h" +#define PRINTSTR(s) stdputstr(s) +#endif SBAYES + +extern char *S_alloc(), *calloc(), *realloc(); +extern double macheps(); +char *minresultstring(); + +/************************************************************************/ +/** **/ +/** Definitions and Globals **/ +/** **/ +/************************************************************************/ + +#define nil 0L +#define NULL 0L +#define TRUE 1 +#define FALSE 0 + +#define ROOT2PI 2.50662827463100050241 +#define PI_INV .31830988618379067153 + +#define GRADTOL_POWER 1.0 / 3.0 +#define H_POWER 1.0 / 6.0 + +typedef double **RMatrix, *RVector; + +typedef struct{ + char *f, **sf, **g; + int n, k; + int change_sign, fderivs; + int *gderivs; + double typf, h, dflt; + RVector typx, fsum, cvals, ctarget; + RMatrix gfsum; +} Fundata; + +static Fundata func, gfuncs, cfuncs; + +/************************************************************************/ +/** **/ +/** Memory Utilities **/ +/** **/ +/************************************************************************/ + +/* this function is used to maintain a statically allocated piece of */ +/* memory of a specified size. If a larger piece is needed the pointer */ +/* is realloced. This allows functions using memory allocation to be */ +/* called repeatedly (but not recursively) from within the same call */ +/* from S. It attempts to avoid the danger of dangling callocs. */ + +static makespace(pptr, size) + char **pptr; + int size; +{ + if (size <= 0) return; + if (*pptr == nil) *pptr = calloc(size, 1); + else *pptr = realloc(*pptr, size); + if (size > 0 && *pptr == nil) Recover("memory allocation failed", NULL); +} + +/************************************************************************/ +/** **/ +/** Functions Evaluation Routines **/ +/** **/ +/************************************************************************/ + +/* + * All Hessianevaluations by numerical derivatives assume the gradient is + * evaluated first at the same location. The results are cached away. + */ + +/* install log posterior function */ +static install_func(f, sf, n, change_sign, typf, h, typx, dflt) + char *f, **sf; + int n; + double typf, h, dflt; + RVector typx; +{ + int i; + static int inited = FALSE; + + if (! inited) { + func.typx = nil; + func.fsum = nil; + inited = TRUE; + } + makespace(&func.typx, n * sizeof(double)); + makespace(&func.fsum, n * sizeof(double)); + + func.f = f; + func.sf = sf; + func.n = n; + func.change_sign = change_sign; + func.typf = (typf > 0.0) ? typf : 1.0; + func.h = (h > 0.0) ? h : pow(macheps(), H_POWER); + for (i = 0; i < n; i++) + func.typx[i] = (typx != nil && typx[i] > 0.0) ? typx[i] : 1.0; + func.dflt = dflt; + func.fderivs = 0; +} + +/* install tilt functions */ +static install_gfuncs(g, n, k, change_sign, h, typx) + char **g; + int n, k, change_sign; + double h; + RVector typx; +{ + int i; + static int inited = FALSE; + static double *gfsumdata = nil; + + if (! inited) { + gfuncs.typx = nil; + gfuncs.gfsum = nil; + gfuncs.gderivs = nil; + inited = TRUE; + } + makespace(&gfuncs.typx, n * sizeof(double)); + makespace(&gfuncs.gfsum, k * sizeof(double *)); + makespace(&gfsumdata, k * n * sizeof(double)); + makespace(&gfuncs.gderivs, k *sizeof(int)); + + gfuncs.g = g; + gfuncs.n = n; + gfuncs.k = k; + gfuncs.change_sign = change_sign; + gfuncs.h = (h > 0.0) ? h : pow(macheps(), H_POWER); + for (i = 0; i < n; i++) + gfuncs.typx[i] = (typx != nil && typx[i] > 0.0) ? typx[i] : 1.0; + for (i = 0; i < k; i++) gfuncs.gfsum[i] = gfsumdata + i * n; +} + +/* install constraint functions */ +static install_cfuncs(g, n, k, ctarget, h, typx) + char **g; + int n, k; + double h; + RVector typx, ctarget; +{ + int i; + static int inited = FALSE; + + if (! inited) { + cfuncs.typx = nil; + cfuncs.fsum = nil; + cfuncs.gderivs = nil; + inited = TRUE; + } + makespace(&cfuncs.typx, n * sizeof(double)); + makespace(&cfuncs.fsum, n * sizeof(double)); + makespace(&cfuncs.gderivs, k * sizeof(int)); + + cfuncs.g = g; + cfuncs.n = n; + cfuncs.k = k; + cfuncs.h = (h > 0.0) ? h : pow(macheps(), H_POWER); + for (i = 0; i < n; i++) + cfuncs.typx[i] = (typx != nil && typx[i] > 0.0) ? typx[i] : 1.0; + cfuncs.ctarget = ctarget; +} + +/* callback to test if x is in the support of the posterior */ +static in_support(ff, n, x) + char **ff; + int n; + double *x; +{ + char *args[1], *values[1]; + int *result; + char *mode[1]; + long length[1]; + + if (ff == nil || ff[0] == nil) return(TRUE); + else { + mode[0] = "double"; + length[0] =n; + args[0] = (char *) x; + call_S(ff[0], 1L, args, mode, length, 0L, 1L, values); + result = (int *) values[0]; + return(result[0]); + } +} + +/* callback for logposterior evaluation */ +static evalfunc(x, pval, grad, hess) + RVector x, grad; + double *pval; + RMatrix hess; +{ + char *args[1], *values[3]; + double *result, val; + char *mode[1]; + long length[1]; + int i, j; + + for (i = 0; i < 3; i++) values[i] = nil; + + if (in_support(func.sf, func.n, x)) { + if (pval != nil || func.fderivs > 0 || hess != nil) { + mode[0] = "double"; + length[0] = func.n; + args[0] = (char *) x; + call_S(func.f, 1L, args, mode, length, 0L, 3L, values); + result = (double *) values[0]; + val = (! func.change_sign) ? result[0] : -result[0]; + if (pval != nil) *pval = val; + if (values[2] != nil) func.fderivs = 2; + else if (values[1] != nil) func.fderivs = 1; + else func.fderivs = 0; + } + if (grad != nil) { + if (func.fderivs > 0) { + result = (double *) values[1]; + for (i = 0; i < func.n; i++) + grad[i] = (! func.change_sign) ? result[i] : -result[i]; + } + else { + numergrad(func.n, x, grad, func.fsum, evalfunc, func.h, func.typx); + } + } + if (hess != nil) { + if (func.fderivs == 2) { + result = (double *) values[2]; + for (i = 0; i < func.n; i++) + for (j = 0; j < func.n; j++) + hess[i][j] = (! func.change_sign) ? result[i + j * func.n] + : -result[i + j * func.n]; + } + else { + if (func.fderivs == 1) /* kludge to get fsum for analytic gradients */ + numergrad(func.n, x, func.fsum, func.fsum, + evalfunc, func.h, func.typx); + numerhess(func.n, x, hess, val, func.fsum, evalfunc, func.h, func.typx); + } + } + return(TRUE); + } + else { + if (pval != nil) *pval = func.dflt; + return(FALSE); + } +} + + +/* callback for tilt function evaluation */ +static int which_gfunc; + +static evalgfunc(x, pval, grad, hess) + RVector x, grad; + double *pval; + RMatrix hess; +{ + char *args[1], *values[3]; + double *result, val; + char *mode[1]; + long length[1]; + int i, j; + + for (i = 0; i < 3; i++) values[i] = nil; + + if (pval != nil || gfuncs.gderivs[which_gfunc] > 0 || hess != nil) { + mode[0] = "double"; + length[0] = gfuncs.n; + args[0] = (char *) x; + call_S(gfuncs.g[which_gfunc], 1L, args, mode, length, 0L, 3L, values); + result = (double *) values[0]; + val = result[0]; + if (pval != nil) *pval = result[0]; + if (values[2] != nil) gfuncs.gderivs[which_gfunc] = 2; + else if (values[1] != nil) gfuncs.gderivs[which_gfunc] = 1; + else gfuncs.gderivs[which_gfunc] = 0; + } + if (grad != nil) { + if (gfuncs.gderivs[which_gfunc] > 0) { + result = (double *) values[1]; + for (i = 0; i < gfuncs.n; i++) grad[i] = result[i]; + } + else { + numergrad(gfuncs.n, x, grad, gfuncs.gfsum[which_gfunc], evalgfunc, + gfuncs.h, gfuncs.typx); + } + } + if (hess != nil) { + if (gfuncs.gderivs[which_gfunc] == 2) { + result = (double *) values[2]; + for (i = 0; i < gfuncs.n; i++) + for (j = 0; j < gfuncs.n; j++) + hess[i][j] = result[i + j * gfuncs.n]; + } + else { + /* kludge to get fsum if analytic gradient used */ + if (gfuncs.gderivs[which_gfunc] == 1) + numergrad(gfuncs.n, x, gfuncs.gfsum[which_gfunc], + gfuncs.gfsum[which_gfunc], evalgfunc, gfuncs.h, gfuncs.typx); + numerhess(gfuncs.n, x, hess, val, gfuncs.gfsum[which_gfunc], evalgfunc, + gfuncs.h, gfuncs.typx); + } + } +} + +/* callback for constraint function evaluation */ +static int which_cfunc; + +static evalcfunc(x, pval, grad, hess) + RVector x, grad; + double *pval; + RMatrix hess; +{ + char *args[1], *values[3]; + double *result, val; + char *mode[1]; + long length[1]; + int i, j; + + if (pval != nil || cfuncs.gderivs[which_cfunc] > 0 || hess != nil) { + mode[0] = "double"; + length[0] = cfuncs.n; + args[0] = (char *) x; + call_S(cfuncs.g[which_cfunc], 1L, args, mode, length, 0L, 3L, values); + result = (double *) values[0]; + val = result[0]; + if (pval != nil) { + *pval = result[0]; + if (cfuncs.ctarget != nil) *pval -= cfuncs.ctarget[which_cfunc]; + } + if (values[2] != nil) cfuncs.gderivs[which_cfunc] = 2; + else if (values[1] != nil) cfuncs.gderivs[which_cfunc] = 1; + else cfuncs.gderivs[which_cfunc] = 0; + } + if (grad != nil) { + if (cfuncs.gderivs[which_cfunc] > 0) { + result = (double *) values[1]; + for (i = 0; i 0)) + add_tilt(x, pval, grad, hess, tiltinfo.tilt, tiltinfo.exptilt); +} + +constfunc(x, vals, jac, hess) + RVector x, vals; + RMatrix jac, hess; +{ + int i, k = cfuncs.k; + double *pvali, *jaci; + + for (i = 0; i < k; i++) { + pvali = (vals != nil) ? vals + i : nil; + jaci = (jac != nil) ? jac[i] : nil; + which_cfunc = i; + evalcfunc(x, pvali, jaci, nil); + } +} + +static add_tilt(x, pval, grad, hess, tilt, exptilt) + RVector x, grad; + double *pval, tilt; + RMatrix hess; + int exptilt; +{ + int i, j, k, n = func.n, m = gfuncs.k; + double *gval, *ggrad, **ghess, etilt; + + if (m == 0) return; + + if (gfuncs.change_sign) tilt = -tilt; + + for (k = 0; k < m; k++) { + gval = (pval != nil) ? tiltinfo.gval + k : nil; + ggrad = (grad != nil) ? tiltinfo.ggrad[k] : nil; + ghess = (hess != nil) ? tiltinfo.ghess : nil; + + which_gfunc = k; + evalgfunc(x, gval, ggrad, ghess); + + if (exptilt) { + etilt = (tiltinfo.tscale != nil) ? tilt / tiltinfo.tscale[k] : tilt; + if (pval != nil) *pval += etilt * *gval; + if (grad != nil) + for (i = 0; i < n; i++) grad[i] += etilt * ggrad[i]; + if (hess != nil) + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) hess[i][j] += etilt * ghess[i][j]; + } + else { + gval = tiltinfo.gval; + ggrad = tiltinfo.ggrad[k]; + ghess = tiltinfo.ghess; + if (gval[k] <= 0.0) Recover("nonpositive function value", NULL); + if (pval != nil) *pval += tilt * log(gval[k]); + if (grad != nil) + for (i = 0; i < n; i++) grad[i] += tilt * ggrad[i] / gval[k]; + if (hess != nil) + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) + hess[i][j] += + tilt * (ghess[i][j] / gval[k] + - (ggrad[i] / gval[k]) * (ggrad[j] / gval[k])); + } + } +} + +maxfront(ff, gf, cf, x, typx, fvals, gvals, cvals, ctarget, ipars, dpars, + tscale, msg) + char **ff, **gf, **cf; + double *x, *typx, *fvals, *gvals, *cvals, *ctarget, *tscale; + MaxIPars *ipars; + MaxDPars *dpars; + char **msg; +{ + static char *work = nil; + static RMatrix H = nil, cJ = nil; + double *pf, *grad, *c; + int i, n, m, k; + int (*cfun)(); + + if (ipars->verbose > 0) PRINTSTR("maximizing...\n"); + + n = ipars->n; + m = ipars->m; + k = ipars->k; + if (k >= n) Recover("too many constraints", NULL); + + makespace(&H, n * sizeof(double *)); + makespace(&work, minworkspacesize(n, k)); + + pf = fvals; fvals++; + grad = fvals; fvals += n; + for (i = 0; i < n; i++, fvals += n) H[i] = fvals; + set_tilt_info(n, m, dpars->newtilt, ipars->exptilt, tscale); + + if (k == 0) { + c = nil; + cJ = nil; + cfun = nil; + } + else { + c = cvals; + cvals += k; + makespace(&cJ, k * sizeof(double *)); + for (i = 0; i < k; i++) cJ[i] = cvals + i * n; + cfun = constfunc; + } + + install_func(ff[0], nil, n, TRUE, dpars->typf, dpars->h, typx, dpars->dflt); + install_gfuncs(gf, n, m, TRUE, dpars->h, typx); + install_cfuncs(cf, n, k, ctarget, dpars->h, typx); + + minsetup(n, k, minfunc, cfun, x, dpars->typf, typx, work); + minsetoptions(dpars->gradtol, dpars->steptol, dpars->maxstep, + ipars->itnlimit, ipars->verbose, ipars->backtrack, TRUE); + + if (ipars->vals_suppl) { + for (i = 0; i < k; i++) c[i] -= ctarget[i]; + if (dpars->newtilt != dpars->tilt) { + add_tilt(x, pf, grad, H, dpars->newtilt - dpars->tilt, ipars->exptilt); + dpars->tilt = dpars->newtilt; + } + minsupplyvalues(*pf, grad, H, c, cJ); + } + + minimize(); + minresults(x, pf, nil, grad, H, c, cJ, &ipars->count, &ipars->termcode, + &dpars->hessadd); + msg[0] = minresultstring(ipars->termcode); + + for (i = 0; i < k; i++) c[i] += ctarget[i]; + ipars->vals_suppl = TRUE; +} + +/************************************************************************/ +/** **/ +/** Log Laplace Approximation **/ +/** **/ +/************************************************************************/ + +loglapdet(fvals, cvals, ipars, dpars, val, detonly) + double *fvals, *cvals; + MaxIPars *ipars; + MaxDPars *dpars; + double *val; + int *detonly; +{ + int i, j, l, n = ipars->n, k = ipars->k; + double f = -fvals[0], *hessdata = fvals + n + 1, *cgraddata = cvals + k; + double ldL, ldcv, maxadd; + static RMatrix hess = nil, cgrad = nil; + + if (k >= n) Recover("too many constraints", NULL); + + makespace(&hess, n * sizeof(double *)); + makespace(&cgrad, k * sizeof(double *)); + + for (i = 0; i < n; i++) hess[i] = hessdata + i * n; + for (i = 0; i < k; i++) cgrad[i] = cgraddata + i * n; + + choldecomp(hess, n, 0.0, &maxadd); + /**** do something if not pos. definite ****/ + + for (i = 0, ldL = 0.0; i < n; i++) ldL += log(hess[i][i]); + + if (k > 0) { + /* forward solve for (L^-1) cgrad^T */ + for (l = 0; l < k; l++) { + for (i = 0; i < n; i++) { + if (hess[i][i] != 0.0) cgrad[l][i] /= hess[i][i]; + for (j = i + 1; j < n; j++) cgrad[l][j] -= hess[j][i] * cgrad[l][i]; + } + } + + /* compute sigma and stdev */ + for (i = 0; i < k; i++) { + for (j = i; j < k; j++) { + for (l = 0, hess[i][j] = 0.0; l < n; l++) + hess[i][j] += cgrad[i][l] * cgrad[j][l]; + hess[j][i] = hess[i][j]; + } + } + + choldecomp(hess, k, 0.0, &maxadd); + /**** do something if not pos. definite ****/ + for (i = 0, ldcv = 0.0; i < k; i++) ldcv += log(hess[i][i]); + } + else ldcv = 0.0; + + *val = (n - k) * log(ROOT2PI) - ldL - ldcv; + if (! *detonly) *val += f; +} + +#ifdef SBAYES + +loglapfront(fvals, cvals, ipars, dpars, val) + double *fvals, *cvals; + MaxIPars *ipars; + MaxDPars *dpars; + double *val; +{ + int detonly = FALSE; + + loglapdet(fvals, cvals, ipars, dpars, val, &detonly); +} + +/************************************************************************/ +/** **/ +/** First Order Moments **/ +/** **/ +/************************************************************************/ + +moms1front(gf, n, m, x, hessdata, mean, stdev, sigmadata, h, typx) + char *gf; + int *n, *m; + double *x, *hessdata, *mean, *stdev, *sigmadata, *h, *typx; +{ + int i, j, k; + RMatrix hess, sigma, delg; + double *delgdata, maxadd; + + hess = (RMatrix) S_alloc(*n, sizeof(double *)); + sigma = (RMatrix) S_alloc(*m, sizeof(double *)); + delg = (RMatrix) S_alloc(*m, sizeof(double *)); + delgdata = (double *) S_alloc(*m * *n, sizeof(double)); + + for (i = 0; i < *n; i++) hess[i] = hessdata + i * *n; + for (i = 0; i < *m; i++) sigma[i] = sigmadata + i * *m; + for (i = 0; i < *m; i++) delg[i] = delgdata + i * *n; + + gevalfront(gf, n, m, x, h, typx, mean, delgdata); + + /* get the cholesky decomposition L of the hessian */ + choldecomp(hess, *n, 0.0, &maxadd); + + /* forward solve for (L^-1) delg^T */ + for (k = 0; k < *m; k++) { + for (i = 0; i < *n; i++) { + if (hess[i][i] != 0.0) delg[k][i] /= hess[i][i]; + for (j = i + 1; j < *n; j++) delg[k][j] -= hess[j][i] * delg[k][i]; + } + } + + /* compute sigma and stdev */ + for (i = 0; i < *m; i++) { + for (j = i; j < *m; j++) { + for (k = 0, sigma[i][j] = 0.0; k < *n; k++) + sigma[i][j] += delg[i][k] * delg[j][k]; + sigma[j][i] = sigma[i][j]; + } + stdev[i] = sqrt(sigma[i][i]); + } +} + +/************************************************************************/ +/** **/ +/** Second Order Moments **/ +/** **/ +/************************************************************************/ + +typedef struct { + MaxIPars max; + int full, covar; +} MomIPars; + +typedef struct { + MaxDPars max; + double mgfdel; +} MomDPars; + +moms2front(ff, gf, gnum, x, typx, fvals, gvals, ipars, dpars, + mean, stdev, sigmadata) + char **ff, **gf; + int *gnum; + double *x, *typx, *fvals, *gvals, *mean, *stdev, *sigmadata; + MomIPars *ipars; + MomDPars *dpars; +{ + char *msg; + double h, loglap0, loglap1, loglap2; + double *tilts, *fvals1, *gvals1, *x1; + MomDPars dp1, *dpars1 = &dp1; + MomIPars ip1, *ipars1 = &ip1; + int i, n, m; + + n = ipars->max.n; + m = *gnum; + h = dpars->max.h; + + tilts = (double *) S_alloc(m, sizeof(double)); + x1 = (double *) S_alloc(n, sizeof(double)); + fvals1 = (double *) S_alloc(1 + n + n * n, sizeof(double)); + gvals1 = (double *) S_alloc(m + n * m, sizeof(double)); + + maxfront(ff, nil, nil, x, typx, fvals, gvals, nil, nil, + ipars, dpars, nil, &msg); + copypars(x, fvals, gvals, ipars, dpars, x1, fvals1, gvals1, ipars1, dpars1); + loglapfront(fvals1, nil, ipars1, dpars1, &loglap0); + copypars(x, fvals, gvals, ipars, dpars, x1, fvals1, gvals1, ipars1, dpars1); + moms1front(gf, &n, &m, x1, fvals1 + n + 1, mean, stdev, sigmadata, &h, typx); + + if (ipars->full) { + for (i = 0; i < m; i++) { + copypars(x, fvals, gvals, ipars, dpars, + x1, fvals1, gvals1, ipars1, dpars1); + ipars1->max.m = 1; + ipars1->max.exptilt = FALSE; + dpars1->max.newtilt = 1.0; + maxfront(ff, gf + i, nil, x1, typx, fvals1, gvals1, nil, nil, + ipars1, dpars1, nil, &msg); + loglapfront(fvals1, nil, ipars1, dpars1, &loglap1); + loglap1 -= loglap0; + + copypars(x, fvals, gvals, ipars, dpars, + x1, fvals1, gvals1, ipars1, dpars1); + ipars1->max.m = 1; + ipars1->max.exptilt = FALSE; + dpars1->max.newtilt = 2.0; + maxfront(ff, gf + i, nil, x1, typx, fvals1, gvals1, nil, nil, + ipars1, dpars1, nil, &msg); + loglapfront(fvals1, nil, ipars1, dpars1, &loglap2); + loglap2 -= loglap0; + + mean[i] = exp(loglap1); + stdev[i] = sqrt(exp(loglap2) - exp(2.0 * loglap1)); + if (ipars->covar) sigmadata[i + i * m] = stdev[i] * stdev[i]; + } + if (ipars->covar) { + char *cgf[2]; + int j; + + for (i = 0; i < m; i++) { + for (j = i + 1; j < m; j++) { + cgf[0] = gf[i]; + cgf[1] = gf[j]; + copypars(x, fvals, gvals, ipars, dpars, + x1, fvals1, gvals1, ipars1, dpars1); + ipars1->max.m = 2; + ipars1->max.exptilt = FALSE; + dpars1->max.newtilt = 1.0; + maxfront(ff, gf + i, nil, x1, typx, fvals1, gvals1, nil, nil, + ipars1, dpars1, nil, &msg); + loglapfront(fvals1, nil, ipars1, dpars1, &loglap1); + loglap1 -= loglap0; + + sigmadata[i + j * m] = exp(loglap1) - mean[i] * mean[j]; + sigmadata[j + i * m] = sigmadata[i + j * m]; + } + } + } + } + else { + for (i = 0; i < m; i++) + tilts[i] = (stdev[i] > 0.0) ? dpars->mgfdel / stdev[i] : dpars->mgfdel; + + for (i = 0; i < m; i++) { + copypars(x, fvals, gvals, ipars, dpars, + x1, fvals1, gvals1, ipars1, dpars1); + ipars1->max.m = 1; + ipars1->max.exptilt = TRUE; + dpars1->max.newtilt = tilts[i]; + maxfront(ff, gf + i, nil, x1, typx, fvals1, gvals1, nil, nil, + ipars1, dpars1, nil, &msg); + loglapfront(fvals1, nil, ipars1, dpars1, &loglap1); + loglap1 -= loglap0; + + copypars(x, fvals, gvals, ipars, dpars, + x1, fvals1, gvals1, ipars1, dpars1); + ipars1->max.m = 1; + ipars1->max.exptilt = TRUE; + dpars1->max.newtilt = -tilts[i]; + maxfront(ff, gf + i, nil, x1, typx, fvals1, gvals1, nil, nil, + ipars1, dpars1, nil, &msg); + loglapfront(fvals1, nil, ipars1, dpars1, &loglap2); + loglap2 -= loglap0; + + mean[i] = (loglap1 - loglap2) / (2.0 * tilts[i]); + stdev[i] = sqrt((loglap1 + loglap2) / (tilts[i] * tilts[i])); + if (ipars->covar) sigmadata[i + i * m] = stdev[i] * stdev[i]; + } + if (ipars->covar) { + char *cgf[2]; + double ctilt, tscale[2]; + int j; + + ctilt = dpars->mgfdel; + for (i = 0; i < m; i++) { + for (j = i + 1; j < m; j++) { + cgf[0] = gf[i]; + cgf[1] = gf[j]; + tscale[0] = stdev[i] > 0 ? stdev[i] : 1.0; + tscale[1] = stdev[j] > 0 ? stdev[j] : 1.0; + + copypars(x, fvals, gvals, ipars, dpars, + x1, fvals1, gvals1, ipars1, dpars1); + ipars1->max.m = 2; + ipars1->max.exptilt = TRUE; + dpars1->max.newtilt = ctilt; + maxfront(ff, cgf, nil, x1, typx, fvals1, gvals1, nil, nil, + ipars1, dpars1, tscale, &msg); + loglapfront(fvals1, nil, ipars1, dpars1, &loglap1); + loglap1 -= loglap0; + + copypars(x, fvals, gvals, ipars, dpars, + x1, fvals1, gvals1, ipars1, dpars1); + ipars1->max.m = 2; + ipars1->max.exptilt = TRUE; + dpars1->max.newtilt = -ctilt; + maxfront(ff, cgf, nil, x1, typx, fvals1, gvals1, nil, nil, + ipars1, dpars1, tscale, &msg); + loglapfront(fvals1, nil, ipars1, dpars1, &loglap2); + loglap2 -= loglap0; + + sigmadata[i + j * m] = stdev[i] * stdev[j] + * ((loglap2 + loglap1) /(2 * ctilt * ctilt) - 1.0); + sigmadata[j + i * m] = sigmadata[i + j * m]; + } + } + } + } +} + +static copypars(x, f, g, ip, dp, x1, f1, g1, ip1, dp1) + double *x, *f, *g, *x1, *f1, *g1; + MomIPars *ip, *ip1; + MomDPars *dp, *dp1; +{ + int i, n, m, nf, ng; + + n = ip->max.n; + m = ip->max.m; + nf = 1 + n + n * n; + ng = m + n * m; + + for (i = 0; i < n; i++) x1[i] = x[i]; + for (i = 0; i < nf; i++) f1[i] = f[i]; + for (i = 0; i < ng; i++) g1[i] = g[i]; + *ip1 = *ip; + *dp1 = *dp; +} + +/************************************************************************/ +/** **/ +/** Laplace Margins **/ +/** **/ +/************************************************************************/ + +lapmar1front(ff, gf, x, typx, fvals, ipars, dpars, xmar, ymar, nmar) + char **ff, **gf; + double *x, *typx, *fvals, *xmar, *ymar; + MaxIPars *ipars; + MaxDPars *dpars; + int *nmar; +{ + char *msg; + int i, n, m, mindex; + double h, loglap0, loglap1, xmode, stdev, sigmadata, ctarget[1]; + double *fvals1, *x1, *cvals, *cvals1, *fvals2, *x2, *cvals2; + MaxDPars dp1, dp2, *dpars1 = &dp1, *dpars2 = &dp2; + MaxIPars ip1, ip2, *ipars1 = &ip1, *ipars2 = &ip2; + + n = ipars->n; + m = 1; + h = dpars->h; + + x1 = (double *) S_alloc(n + 1, sizeof(double)); + fvals1 = (double *) S_alloc(1 + n + n * n, sizeof(double)); + cvals = (double *) S_alloc(m + n * m, sizeof(double)); + cvals1 = (double *) S_alloc(m + n * m, sizeof(double)); + x2 = (double *) S_alloc(n + 1, sizeof(double)); + fvals2 = (double *) S_alloc(1 + n + n * n, sizeof(double)); + cvals2 = (double *) S_alloc(m + n * m, sizeof(double)); + + maxfront(ff, nil, nil, x, typx, fvals, nil, nil, nil, + ipars, dpars, nil, &msg); + cpmarpars(x, fvals, cvals, ipars, dpars, x1, fvals1, cvals1, ipars1, dpars1); + loglapfront(fvals1, nil, ipars1, dpars1, &loglap0); + cpmarpars(x, fvals, cvals, ipars, dpars, x1, fvals1, cvals1, ipars1, dpars1); + moms1front(gf, &n, &m, x1, fvals1 + n + 1, &xmode, &stdev, &sigmadata, + &h, typx); + + ipars->k = 1; + ipars->vals_suppl = FALSE; + ctarget[0] = xmode; + maxfront(ff, nil, gf, x, typx, fvals, nil, cvals, ctarget, + ipars, dpars, nil, &msg); + + for (mindex = 0; mindex < *nmar && xmar[mindex] <= xmode; mindex++); + + cpmarpars(x, fvals, cvals, ipars, dpars, x1, fvals1, cvals1, ipars1, dpars1); + for (i = mindex; i >= 0; i--) { + ctarget[0] = xmar[i]; + maxfront(ff, nil, gf, x1, typx, fvals1, nil, cvals1, ctarget, + ipars1, dpars1, nil, &msg); + cpmarpars(x1, fvals1, cvals1, ipars1, dpars1, x2, + fvals2, cvals2, ipars2, dpars2); + loglapfront(fvals2, cvals2, ipars2, dpars2, &loglap1); + ymar[i] = exp(loglap1 - loglap0); + } + cpmarpars(x, fvals, cvals, ipars, dpars, x1, fvals1, cvals1, ipars1, dpars1); + for (i = mindex + 1; i < *nmar; i++) { + ctarget[0] = xmar[i]; + maxfront(ff, nil, gf, x1, typx, fvals1, nil, cvals1, ctarget, + ipars1, dpars1, nil, &msg); + cpmarpars(x1, fvals1, cvals1, ipars1, dpars1, x2, + fvals2, cvals2, ipars2, dpars2); + loglapfront(fvals2, cvals2, ipars2, dpars2, &loglap1); + ymar[i] = exp(loglap1 - loglap0); + } +} + +static cpmarpars(x, f, g, ip, dp, x1, f1, g1, ip1, dp1) + double *x, *f, *g, *x1, *f1, *g1; + MaxIPars *ip, *ip1; + MaxDPars *dp, *dp1; +{ + int i, n, k, nf, ng; + + n = ip->n; + k = ip->k; + nf = 1 + n + n * n; + ng = k + n * k; + + for (i = 0; i < n; i++) x1[i] = x[i]; + for (i = 0; i < nf; i++) f1[i] = f[i]; + for (i = 0; i < ng; i++) g1[i] = g[i]; + *ip1 = *ip; + *dp1 = *dp; +} +#endif /* SBAYES */ + +#ifdef TODO +get hessian from gradiant for analytical gradiants +avoid repeated derivative calls in mimimize. +2d margins +use pos. definiteness info in margins +#endif TODO diff --git a/lib/gamln.c b/lib/gamln.c new file mode 100644 index 0000000..7e5510d --- /dev/null +++ b/lib/gamln.c @@ -0,0 +1,35 @@ +#include "xmath.h" + +/* +log gamma function from Numerical Recipes +*/ + +static double cof[6] = { + 76.18009173, + -86.50532033, + 24.01409822, + -1.231739516, + 0.120858003e-2, + -0.536382e-5 +}; + +double gamma(xx) + double xx; +{ + double x, tmp, ser; + int j; + + if (xx < 1.0) return(gamma(1.0 + xx) - log(xx)); + else { + x = xx - 1.0; + tmp = x + 5.5; + tmp -= (x + 0.5) * log(tmp); + ser = 1.0; + for (j = 0; j < 6; j++) { + x += 1.0; + ser += cof[j] / x; + } + return(-tmp + log(2.50662827465 * ser)); + } +} + diff --git a/lib/gammabase.c b/lib/gammabase.c new file mode 100644 index 0000000..5faf343 --- /dev/null +++ b/lib/gammabase.c @@ -0,0 +1,288 @@ +#include "xmath.h" + +#define TRUE 1 +#define FALSE 0 + +extern double gamma(), ppnd(); +static double gammp(), gser(), gcf(), gnorm(), ppchi2(); + +gammabase(x, a, p) + double *x, *a, *p; +{ + *p = gammp(*a, *x); +} + +double ppgamma(p, a, ifault) + double p, a; + int *ifault; +{ + double x, v, g; + + v = 2.0 * a; + g = gamma(a); + x = ppchi2(&p, &v, &g, ifault); + return(x / 2.0); +} + +/* + Static Routines +*/ + +/* + From Numerical Recipes, with normal approximation from Appl. Stat. 239 +*/ + +#define EPSILON 1.0e-14 +#define LARGE_A 10000.0 +#define ITMAX 1000 + +static double gammp(a, x) + double a, x; +{ + double gln, p; + + if (x <= 0.0 || a <= 0.0) p = 0.0; + else if (a > LARGE_A) p = gnorm(a, x); + else { + gln = gamma(a); + if (x < (a + 1.0)) p = gser(a, x, gln); + else p = 1.0 - gcf(a, x, gln); + } + return(p); +} + +/* compute gamma cdf by a normal approximation */ +static double gnorm(a, x) + double a, x; +{ + double p, sx; + + if (x <= 0.0 || a <= 0.0) p = 0.0; + else { + sx = sqrt(a) * 3.0 * (pow(x / a, 1.0 / 3.0) + 1.0 / (a * 9.0) - 1.0); + normbase(&sx, &p); + } + return(p); +} + +/* compute gamma cdf by its series representation */ +static double gser(a, x, gln) + double a, x, gln; +{ + double p, sum, del, ap; + int n, done = FALSE; + + if (x <= 0.0 || a <= 0.0) p = 0.0; + else { + ap = a; + del = sum = 1.0 / a; + for (n = 1; ! done && n < ITMAX; n++) { + ap += 1.0; + del *= x / ap; + sum += del; + if (fabs(del) < EPSILON) done = TRUE; + } + p = sum * exp(- x + a * log(x) - gln); + } + return(p); +} + +/* compute complementary gamma cdf by its continued fraction expansion */ +static double gcf(a, x, gln) + double a, x, gln; +{ + double gold = 0.0, g, fac = 1.0, b1 = 1.0; + double b0 = 0.0, anf, ana, an, a1, a0 = 1.0; + double p; + int done = FALSE; + + a1 = x; + p = 0.0; + for(an = 1.0; ! done && an <= ITMAX; an += 1.0) { + ana = an - a; + a0 = (a1 + a0 * ana) * fac; + b0 = (b1 + b0 * ana) * fac; + anf = an * fac; + a1 = x * a0 + anf * a1; + b1 = x * b0 + anf * b1; + if (a1 != 0.0) { + fac = 1.0 / a1; + g = b1 * fac; + if (fabs((g - gold) / g) < EPSILON) { + p = exp(-x + a * log(x) - gln) * g; + done = TRUE; + } + gold = g; + } + } + return(p); +} + +static double gammad(x, a, iflag) + double *x, *a; + int *iflag; +{ + double cdf; + + gammabase(x, a, &cdf); + return(cdf); +} + +/* + ppchi2.f -- translated by f2c and modified + + Algorithm AS 91 Appl. Statist. (1975) Vol.24, P.35 + To evaluate the percentage points of the chi-squared + probability distribution function. + + p must lie in the range 0.000002 to 0.999998, + (but I am using it for 0 < p < 1 - seems to work) + v must be positive, + g must be supplied and should be equal to ln(gamma(v/2.0)) + + Auxiliary routines required: ppnd = AS 111 (or AS 241) and gammad. +*/ + +static double ppchi2(p, v, g, ifault) + double *p, *v, *g; + int *ifault; +{ + /* Initialized data */ + + static double aa = .6931471806; + static double six = 6.; + static double c1 = .01; + static double c2 = .222222; + static double c3 = .32; + static double c4 = .4; + static double c5 = 1.24; + static double c6 = 2.2; + static double c7 = 4.67; + static double c8 = 6.66; + static double c9 = 6.73; + static double e = 5e-7; + static double c10 = 13.32; + static double c11 = 60.; + static double c12 = 70.; + static double c13 = 84.; + static double c14 = 105.; + static double c15 = 120.; + static double c16 = 127.; + static double c17 = 140.; + static double c18 = 1175.; + static double c19 = 210.; + static double c20 = 252.; + static double c21 = 2264.; + static double c22 = 294.; + static double c23 = 346.; + static double c24 = 420.; + static double c25 = 462.; + static double c26 = 606.; + static double c27 = 672.; + static double c28 = 707.; + static double c29 = 735.; + static double c30 = 889.; + static double c31 = 932.; + static double c32 = 966.; + static double c33 = 1141.; + static double c34 = 1182.; + static double c35 = 1278.; + static double c36 = 1740.; + static double c37 = 2520.; + static double c38 = 5040.; + static double zero = 0.; + static double half = .5; + static double one = 1.; + static double two = 2.; + static double three = 3.; + +/* + static double pmin = 2e-6; + static double pmax = .999998; +*/ + static double pmin = 0.0; + static double pmax = 1.0; + + /* System generated locals */ + double ret_val, d_1, d_2; + + /* Local variables */ + static double a, b, c, q, t, x, p1, p2, s1, s2, s3, s4, s5, s6, ch; + static double xx; + static int if1; + + + /* test arguments and initialise */ + ret_val = -one; + *ifault = 1; + if (*p <= pmin || *p >= pmax) return ret_val; + *ifault = 2; + if (*v <= zero) return ret_val; + *ifault = 0; + xx = half * *v; + c = xx - one; + + if (*v < -c5 * log(*p)) { + /* starting approximation for small chi-squared */ + ch = pow(*p * xx * exp(*g + xx * aa), one / xx); + if (ch < e) { + ret_val = ch; + return ret_val; + } + } + else if (*v > c3) { + /* call to algorithm AS 111 - note that p has been tested above. */ + /* AS 241 could be used as an alternative. */ + x = ppnd(*p, &if1); + + /* starting approximation using Wilson and Hilferty estimate */ + p1 = c2 / *v; + /* Computing 3rd power */ + d_1 = x * sqrt(p1) + one - p1; + ch = *v * (d_1 * d_1 * d_1); + + /* starting approximation for p tending to 1 */ + if (ch > c6 * *v + six) + ch = -two * (log(one - *p) - c * log(half * ch) + *g); + } + else{ + /* starting approximation for v less than or equal to 0.32 */ + ch = c4; + a = log(one - *p); + do { + q = ch; + p1 = one + ch * (c7 + ch); + p2 = ch * (c9 + ch * (c8 + ch)); + d_1 = -half + (c7 + two * ch) / p1; + d_2 = (c9 + ch * (c10 + three * ch)) / p2; + t = d_1 - d_2; + ch -= (one - exp(a + *g + half * ch + c * aa) * p2 / p1) / t; + } while (fabs(q / ch - one) > c1); + } + + do { + /* call to gammad and calculation of seven term Taylor series */ + q = ch; + p1 = half * ch; + p2 = *p - gammad(&p1, &xx, &if1); + if (if1 != 0) { + *ifault = 3; + return ret_val; + } + t = p2 * exp(xx * aa + *g + p1 - c * log(ch)); + b = t / ch; + a = half * t - b * c; + s1 = (c19 + a * (c17 + a * (c14 + a * (c13 + a * (c12 + c11 * a))))) / c24; + s2 = (c24 + a * (c29 + a * (c32 + a * (c33 + c35 * a)))) / c37; + s3 = (c19 + a * (c25 + a * (c28 + c31 * a))) / c37; + s4 = (c20 + a * (c27 + c34 * a) + c * (c22 + a * (c30 + c36 * a))) / c38; + s5 = (c13 + c21 * a + c * (c18 + c26 * a)) / c37; + s6 = (c15 + c * (c23 + c16 * c)) / c38; + d_1 = (s3 - b * (s4 - b * (s5 - b * s6))); + d_1 = (s1 - b * (s2 - b * d_1)); + ch += t * (one + half * t * s1 - b * c * d_1); + } while (fabs(q / ch - one) > e); + + ret_val = ch; + return ret_val; +} diff --git a/lib/kernel.c b/lib/kernel.c new file mode 100644 index 0000000..cdee735 --- /dev/null +++ b/lib/kernel.c @@ -0,0 +1,83 @@ +#include "xmath.h" + +#ifndef ROOT2PI +#define ROOT2PI 2.50662827463100050241 +#endif ROOT2PI + +#ifndef nil +#define nil 0L +#endif nil + +static double kernel(x, y, w, type) + double x, y, w; + int type; +{ + double z, k; + + if (w > 0.0) { + z = (x - y) / w; + switch (type) { + case 'B': + w = 2.0 * w; + z = 0.5 * z; + if (-0.5 < z && z < 0.5) { + z = (1.0 - 4 * z * z); + k = 15.0 * z * z / 8.0; + } + else k = 0.0; + break; + case 'G': + w = 0.25 * w; + z = 4.0 * z; + k = exp(- 0.5 * z * z) / ROOT2PI; + break; + case 'U': + w = 1.5 * w; + z = .75 * z; + k = (fabs(z) < 0.5) ? 1.0 : 0.0; + break; + case 'T': + if (-1.0 <= z && z < 0.0) k = 1.0 + z; + else if (0.0 <= z && z < 1.0) k = 1.0 - z; + else k = 0.0; + break; + default: k = 0.0; break; + } + k = k / w; + } + else k = 0.0; + + return(k); +} + +kernel_smooth(x, y, n, width, wts, wds, xs, ys, ns, ktype) + double *x, *y, width, *wts, *wds, *xs, *ys; + int n, ns, ktype; +{ + int i, j; + double wsum, ysum, lwidth, lwt, xmin, xmax; + + if (n < 1) return(1); + if (width <= 0.0) { + if (n < 2) return(1); + for (xmin = xmax = x[0], i = 1; i < n; i++) { + if (xmin > x[i]) xmin = x[i]; + if (xmax < x[i]) xmax = x[i]; + } + width = (xmax - xmin) / (1 + log((double) n)); + } + + for (i = 0; i < ns; i++) { + for (j = 0, wsum = 0.0, ysum = 0.0; j < n; j++) { + lwidth = (wds != nil) ? width * wds[j] : width; + lwt = kernel(xs[i], x[j], lwidth, ktype); + if (wts != nil) lwt *= wts[j]; + wsum += lwt; + if (y != nil) ysum += lwt * y[j]; + } + if (y != nil) ys[i] = (wsum > 0.0) ? ysum / wsum : 0.0; + else ys[i] = wsum / n; + } + return(0); +} + diff --git a/lib/linalg.h b/lib/linalg.h new file mode 100644 index 0000000..6cf505c --- /dev/null +++ b/lib/linalg.h @@ -0,0 +1,26 @@ +# include "xmath.h" +# include "xlisp.h" +# include "complex.h" + +extern char *calloc(); +extern double macheps(); + +#define nil 0L + +typedef char **Matrix, *Vector; +typedef int **IMatrix, *IVector; +typedef double **RMatrix, *RVector; +typedef Complex **CMatrix, *CVector; + +#define IN 0 +#define RE 1 +#define CX 2 + +/* external functions */ +extern IVector ivector(); +extern RVector rvector(); +extern CVector cvector(); +extern IMatrix imatrix(); +extern RMatrix rmatrix(); +extern CMatrix cmatrix(); + diff --git a/lib/linalgdata.c b/lib/linalgdata.c new file mode 100644 index 0000000..f81f25b --- /dev/null +++ b/lib/linalgdata.c @@ -0,0 +1,89 @@ +/* linalgdata - allocation support for basic linear algebra routines. */ +/* Copyright (c) 1990, by Luke Tierney */ + +#include "linalg.h" + +#ifdef INTPTR +typedef int PTR; +#else +typedef char *PTR; +#endif + +extern PTR la_allocate(); + +/************************************************************************/ +/** **/ +/** Storage Allocation Functions **/ +/** **/ +/************************************************************************/ + +static char *allocate(n, m) + unsigned n, m; +{ + char *p = (char *) la_allocate(n, m); + if (p == nil) xlfail("allocation failed"); + return(p); +} + +static free_alloc(p) + char *p; +{ + if (p != nil) la_free_alloc((PTR) p); +} + +IVector ivector(n) + unsigned n; +{ + return((IVector) allocate(n, sizeof(int))); +} + +RVector rvector(n) + unsigned n; +{ + return((RVector) allocate(n, sizeof(double))); +} + +CVector cvector(n) + unsigned n; +{ + return((CVector) allocate(n, sizeof(Complex))); +} + +free_vector(v) Vector v; { free_alloc(v); } + +IMatrix imatrix(n, m) + unsigned n, m; +{ + int i; + IMatrix mat = (IMatrix) allocate(n, sizeof(IVector)); + for (i = 0; i < n; i++) mat[i] = (IVector) allocate(m, sizeof(int)); + return(mat); +} + +RMatrix rmatrix(n, m) + unsigned n, m; +{ + int i; + RMatrix mat = (RMatrix) allocate(n, sizeof(RVector)); + for (i = 0; i < n; i++) mat[i] = (RVector) allocate(m, sizeof(double)); + return(mat); +} + +CMatrix cmatrix(n, m) + unsigned n, m; +{ + int i; + CMatrix mat = (CMatrix) allocate(n, sizeof(CVector)); + for (i = 0; i < n; i++) mat[i] = (CVector) allocate(m, sizeof(Complex)); + return(mat); +} + +free_matrix(mat, n) + Matrix mat; + int n; +{ + int i; + + if (mat != nil) for (i = 0; i < n; i++) free_alloc(mat[i]); + free_alloc(mat); +} diff --git a/lib/lowess.c b/lib/lowess.c new file mode 100644 index 0000000..fb3875f --- /dev/null +++ b/lib/lowess.c @@ -0,0 +1,148 @@ +/* + Translated from RATFOR lowess code of W. S. Cleveland as obtained from NETLIB +*/ + +#include "xmath.h" + +#define FALSE 0 +#define TRUE 1 + +static double pow2(x) double x; { return(x * x); } +static double pow3(x) double x; { return(x * x * x); } +static double fmax(x,y) double x, y; { return (x > y ? x : y); } + +lowess(x, y, n, f, nsteps, delta, ys, rw, res) + double *x, *y, f, delta, *ys, *rw, *res; + int n, nsteps; +{ + int iter, ns, ok, nleft, nright, i, j, last, m1, m2; + double d1, d2, denom, alpha, cut, cmad, c9, c1, r; + + if (n < 2) { ys[0] = y[0]; return(1); } + ns = max(min((int) (f * n), n), 2); /* at least two, at most n points */ + for(iter = 1; iter <= nsteps + 1; iter++){ /* robustness iterations */ + nleft = 0; nright = ns - 1; + last = -1; /* index of prev estimated point */ + i = 0; /* index of current point */ + do { + while(nright < n - 1){ + /* move nleft, nright to right if radius decreases */ + d1 = x[i] - x[nleft]; + d2 = x[nright + 1] - x[i]; + /* if d1 <= d2 with x[nright+1] == x[nright], lowest fixes */ + if (d1 <= d2) break; + /* radius will not decrease by move right */ + nleft++; + nright++; + } + lowest(x, y, n, x[i], &ys[i], nleft, nright, res, (iter > 1), rw, &ok); + /* fitted value at x[i] */ + if (! ok) ys[i] = y[i]; + /* all weights zero - copy over value (all rw==0) */ + if (last < i - 1) { /* skipped points -- interpolate */ + denom = x[i] - x[last]; /* non-zero - proof? */ + for(j = last + 1; j < i; j = j + 1){ + alpha = (x[j] - x[last]) / denom; + ys[j] = alpha * ys[i] + (1.0 - alpha) * ys[last]; + } + } + last = i; /* last point actually estimated */ + cut = x[last] + delta; /* x coord of close points */ + for(i=last + 1; i < n; i++) { /* find close points */ + if (x[i] > cut) break; /* i one beyond last pt within cut */ + if(x[i] == x[last]) { /* exact match in x */ + ys[i] = ys[last]; + last = i; + } + } + i = max(last + 1,i - 1); + /* back 1 point so interpolation within delta, but always go forward */ + } while(last < n - 1); + for (i = 0; i < n; i++) /* residuals */ + res[i] = y[i] - ys[i]; + if (iter > nsteps) break; /* compute robustness weights except last time */ + for (i = 0; i < n; i++) + rw[i] = fabs(res[i]); + sort(rw,n); + m1 = 1 + n / 2; m2 = n - m1 + 1; + cmad = 3.0 * (rw[m1] + rw[m2]); /* 6 median abs resid */ + c9 = .999 * cmad; c1 = .001 * cmad; + for (i = 0; i < n; i++) { + r = fabs(res[i]); + if(r <= c1) rw[i] = 1.0; /* near 0, avoid underflow */ + else if(r > c9) rw[i] = 0.0; /* near 1, avoid underflow */ + else rw[i] = pow2(1.0 - pow2(r / cmad)); + } + } + return(0); +} + + +static lowest(x, y, n, xs, ys, nleft, nright, w, userw, rw, ok) + double *x, *y, *w, *rw, xs, *ys; + int n, nleft, nright, userw, *ok; +{ + double range, h, h1, h9, a, b, c, r; + int j, nrt; + + range = x[n - 1] - x[0]; + h = fmax(xs - x[nleft], x[nright] - xs); + h9 = .999 * h; + h1 = .001 * h; + + /* compute weights (pick up all ties on right) */ + a = 0.0; /* sum of weights */ + for(j = nleft; j < n; j++) { + w[j]=0.0; + r = fabs(x[j] - xs); + if (r <= h9) { /* small enough for non-zero weight */ + if (r > h1) w[j] = pow3(1.0-pow3(r/h)); + else w[j] = 1.0; + if (userw) w[j] = rw[j] * w[j]; + a += w[j]; + } + else if (x[j] > xs) break; /* get out at first zero wt on right */ + } + nrt = j - 1; /* rightmost pt (may be greater than nright because of ties) */ + if (a <= 0.0) *ok = FALSE; + else { /* weighted least squares */ + *ok = TRUE; + + /* make sum of w[j] == 1 */ + for (j = nleft; j <= nrt; j++) w[j] = w[j] / a; + + if (h > 0.0) { /* use linear fit */ + + /* find weighted center of x values */ + for (j = nleft, a = 0.0; j <= nrt; j++) a += w[j] * x[j]; + + b = xs - a; + for (j = nleft, c = 0.0; j <= nrt; j++) + c += w[j] * (x[j] - a) * (x[j] - a); + + if(sqrt(c) > .001 * range) { + /* points are spread out enough to compute slope */ + b = b/c; + for (j = nleft; j <= nrt; j++) + w[j] = w[j] * (1.0 + b*(x[j] - a)); + } + } + for (j = nleft, *ys = 0.0; j <= nrt; j++) *ys += w[j] * y[j]; + } +} + +static compar(a, b) + double *a, *b; +{ + if (*a < *b) return(-1); + else if (*a > *b) return(1); + else return(0); +} + +static sort(x, n) + double *x; + int n; +{ + qsort(x, n, sizeof(double), compar); +} + diff --git a/lib/ludecomp.c b/lib/ludecomp.c new file mode 100644 index 0000000..02ad677 --- /dev/null +++ b/lib/ludecomp.c @@ -0,0 +1,173 @@ +/* ludecomp - LU decomposition and backsolving routines. */ +/* Taken from Numerical Recipies. */ +/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */ +/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */ +/* You may give out copies of this software; for conditions see the */ +/* file COPYING included with this distribution. */ + +#include "linalg.h" + +crludcmp(mat, n, indx, mode, d) + Matrix mat; + IVector indx; + int n, mode; + double *d; +{ + int i, imax, j, k, singular = FALSE; + double big, temp; + Complex cdum, csum; + double rdum, rsum; + CMatrix cmat = (CMatrix) mat; + RMatrix rmat = (RMatrix) mat; + RVector vv; + + vv = rvector(n); + *d = 1.0; + + /* set up the pivot permutation vector */ + for (i = 0; i < n; i++) indx[i] = i; + + /* get scaling information for implicit pivoting */ + for (i = 0; i < n; i++) { + big = 0.0; + for (j = 0; j < n; j++) { + temp = (mode == RE) ? fabs(rmat[i][j]) : modulus(cmat[i][j]); + if (temp > big) big = temp; + } + if (big == 0.0) { + vv[i] = 1.0; /* no scaling for zero rows */ + singular = TRUE; + } + else vv[i] = 1.0 / big; + } + + /* loop over columns for Crout's method */ + for (j = 0; j < n; j++) { + for (i = 0; i < j; i++) { + if (mode == RE) rsum = rmat[i][j]; + else csum = cmat[i][j]; + + for (k = 0; k < i; k++) + if (mode == RE) rsum -= rmat[i][k] * rmat[k][j]; + else csum = csub(csum, cmul(cmat[i][k], cmat[k][j])); + + if (mode == RE) rmat[i][j] = rsum; + else cmat[i][j] = csum; + } + big = 0.0; + for (i = j; i < n; i++) { + if (mode == RE) rsum = rmat[i][j]; + else csum = cmat[i][j]; + + for (k = 0; k < j; k++) + if (mode == RE) rsum -= rmat[i][k] * rmat[k][j]; + else csum = csub(csum, cmul(cmat[i][k], cmat[k][j])); + + if (mode == RE) rmat[i][j] = rsum; + else cmat[i][j] = csum; + + temp = vv[i] * ((mode == RE) ? fabs(rsum) : modulus(csum)); + if (temp >= big) { big = temp; imax = i; } + } + + /* interchange rows if needed */ + if (j != imax) { + for (k = 0; k < n; k++) { + if (mode == RE) { + rdum = rmat[imax][k]; + rmat[imax][k] = rmat[j][k]; + rmat[j][k] = rdum; + } + else { + cdum = cmat[imax][k]; + cmat[imax][k] = cmat[j][k]; + cmat[j][k] = cdum; + } + } + *d = -(*d); + vv[imax] = vv[j]; + } + indx[j] = imax; + + /* divide by the pivot element */ + temp = (mode == RE) ? fabs(rmat[j][j]) : modulus(cmat[j][j]); + if (temp == 0.0) singular = TRUE; + else if (j < n - 1) { + if (mode == RE) { + rdum = 1.0 / rmat[j][j]; + for (i = j + 1; i < n; i++) rmat[i][j] *= rdum; + } + else { + cdum = cdiv(cart2complex(1.0, 0.0), cmat[j][j]); + for (i = j + 1; i < n; i++) cmat[i][j] = cmul(cmat[i][j], cdum); + } + } + } + free_vector(vv); + return(singular); +} + +crlubksb(a, n, indx, b, mode) + Matrix a; + IVector indx; + Vector b; + int n, mode; +{ + int i, ii, ip, j, singular = FALSE; + CMatrix ca = (CMatrix) a; + CVector cb = (CVector) b; + RMatrix ra = (RMatrix) a; + RVector rb = (RVector) b; + double rsum; + Complex csum; + + /* forward substitute using L part */ + for (i = 0, ii = -1; i < n; i++) { + ip = indx[i]; + if (mode == RE) { + rsum = rb[ip]; + rb[ip] = rb[i]; + } + else { + csum = cb[ip]; + cb[ip] = cb[i]; + } + if (ii >= 0) + for (j = ii; j <= i - 1; j++) + if (mode == RE) rsum -= ra[i][j] * rb[j]; + else csum = csub(csum, cmul(ca[i][j], cb[j])); + else { + if (mode == RE) { + if (rsum != 0.0) ii = i; + } + else if (csum.real != 0.0 || csum.imag != 0.0) ii = i; + } + if (mode == RE) rb[i] = rsum; + else cb[i] = csum; + } + + /* back substitute using the U part */ + for (i = n - 1; i >= 0; i--) { + if (mode == RE) { + rsum = rb[i]; + for (j = i + 1; j < n; j++) rsum -= ra[i][j] * rb[j]; + if (ra[i][i] == 0.0) { + singular = TRUE; + break; + } + else rb[i] = rsum / ra[i][i]; + } + else { + csum = cb[i]; + for (j = i + 1; j < n; j++) csum = csub(csum, cmul(ca[i][j], cb[j])); + if (modulus(ca[i][i]) == 0.0) { + singular = TRUE; + break; + } + else cb[i] = cdiv(csum, ca[i][i]); + } + } + + return(singular); +} + diff --git a/lib/makerotation.c b/lib/makerotation.c new file mode 100644 index 0000000..1e665be --- /dev/null +++ b/lib/makerotation.c @@ -0,0 +1,59 @@ +/* makerotation - Construct rotation from x to y by alpha. */ +/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */ +/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */ +/* You may give out copies of this software; for conditions see the */ +/* file COPYING included with this distribution. */ + +#include "linalg.h" + +static double inner_product(n, x, y) + int n; + RVector x, y; +{ + double result = 0.0; + + for (; n > 0; n--, x++, y++) result += *x * *y; + return(result); +} + +#define NORM(n, x) (sqrt(inner_product(n, x, x))) + +make_rotation(n, rot, x, y, use_alpha, alpha) + int n, use_alpha; + RMatrix rot; + RVector x, y; + double alpha; +{ + double nx, ny, xy, c, s; + int i, j; + + for (i = 0; i < n; i++) { + for (j = 0; j < n; j++) rot[i][j] = 0.0; + rot[i][i] = 1.0; + } + + nx = NORM(n, x); + ny = NORM(n, y); + if (nx == 0.0 || ny == 0.0) return; + + for (i = 0; i < n; i++) x[i] /= nx; + for (i = 0; i < n; i++) y[i] /= ny; + + xy = inner_product(n, x, y); + c = (use_alpha) ? cos(alpha) : xy; + s = (use_alpha) ? sin(alpha) : sqrt(1 - c * c); + + for (i = 0; i < n; i++) y[i] -= xy * x[i]; + + ny = NORM(n, y); + if (ny == 0.0) return; + for (i = 0; i < n; i++) y[i] /= ny; + + for (i = 0; i < n; i++) { + for (j = 0; j < n; j++) + rot[i][j] = x[j] * ( x[i] * (c - 1.0) + y[i] * s) + + y[j] * (- x[i] * s + y[i] * (c - 1.0)); + rot[i][i] += 1.0; + } +} + diff --git a/lib/mclglue.c b/lib/mclglue.c new file mode 100644 index 0000000..e3c9735 --- /dev/null +++ b/lib/mclglue.c @@ -0,0 +1,476 @@ +#include "linalg.h" + +typedef char *PTR; + +extern double unirand(), gamma(); +extern double normalcdf(), normalquant(), normaldens(), normalrand(); +extern double bnormcdf(); +extern double cauchycdf(), cauchyquant(), cauchydens(), cauchyrand(); +extern double gammacdf(), gammaquant(), gammadens(), gammarand(); +extern double chisqcdf(), chisqquant(), chisqdens(), chisqrand(); +extern double betacdf(), betaquant(), betadens(), betarand(); +extern double tcdf(), tquant(), tdens(), trand(); +extern double fcdf(), fquant(), fdens(), frand(); +extern double poissoncdf(), poissonpmf(); +extern int poissonquant(), poissonrand(); +extern double binomialcdf(), binomialpmf(); +extern int binomialquant(), binomialrand(); + +/***********************************************************************/ +/***********************************************************************/ +/**** ****/ +/**** Basic Utilities ****/ +/**** ****/ +/***********************************************************************/ +/***********************************************************************/ + +/***********************************************************************/ +/** **/ +/** Callback Support Functions **/ +/** **/ +/***********************************************************************/ + +static int ccl_integer_value; +static double ccl_double_value; +static PTR ccl_ptr_value; +ccl_store_integer(x) int x; { ccl_integer_value = x; } +ccl_store_double(x) double x; { ccl_double_value = x; } +ccl_store_ptr(x) PTR x; { ccl_ptr_value = x; } + +/***************************************************************************/ +/** **/ +/** Lisp-Managed Calloc/Free **/ +/** **/ +/***************************************************************************/ + +#ifdef DODO +static void (*new_ptr)(); +static void (*free_ptr)(); + +register_new_ptr(f) void (*f)(); { new_ptr = f; } +register_free_ptr(f) void (*f)(); { free_ptr = f; } + +char *calloc(n, m) + int n, m; +{ + int i, N = n * m; + char *p; + + (*new_ptr)(N); + p = (char *) ccl_ptr_value; + for (i = 0; i < N; i++) p[i] = 0; + return(p); +} + +malloc() { xlfail("malloc not available yet"); } +realloc() { xlfail("realloc not available yet"); } + +void free(p) + char *p; +{ + (*free_ptr)(p); +} +#endif DODO + +/***************************************************************************/ +/** **/ +/** Storage Allocation Functions **/ +/** **/ +/***************************************************************************/ + +PTR la_base_allocate(n, m) + unsigned n, m; +{ + char *p = calloc(n, m); + if (p == nil) xlfail("allocation failed"); + return((PTR) p); +} + +int la_base_free_alloc(p) + PTR p; +{ + if (p) free((char *) p); + return(0); +} + +int la_mode_size(mode) + int mode; +{ + switch (mode) { + case IN: return(sizeof(int)); + case RE: return(sizeof(double)); + case CX: return(sizeof(Complex)); + } + return(0); +} + +/***************************************************************************/ +/** **/ +/** Callbacks for Internal Storage **/ +/** **/ +/***************************************************************************/ + +int (*ccl_la_allocate)(), (*ccl_la_free_alloc)(); + +register_la_allocate(f) int (*f)(); { ccl_la_allocate = f; } +register_la_free_alloc(f) int (*f)(); { ccl_la_free_alloc = f; } + +PTR la_allocate(n, m) + int n, m; +{ + (*ccl_la_allocate)(n, m); + return(ccl_ptr_value); +} + +la_free_alloc(p) + PTR p; +{ + (*ccl_la_free_alloc)(p); +} + +/***************************************************************************/ +/** **/ +/** Storage Access Functions **/ +/** **/ +/***************************************************************************/ + +int la_get_integer(p, i) + PTR p; + int i; +{ + return(*(((int *) p) + i)); +} + +double la_get_double(p, i) + PTR p; + int i; +{ + return(*(((double *) p) + i)); +} + +double la_get_complex_real(p, i) + PTR p; + int i; +{ + Complex *c = ((Complex *) p) + i; + return(c->real); +} + +double la_get_complex_imag(p, i) + PTR p; + int i; +{ + Complex *c = ((Complex *) p) + i; + return(c->imag); +} + +PTR la_get_pointer(p, i) + PTR p; + int i; +{ + return(*(((PTR *) p) + i)); +} + +/***************************************************************************/ +/** **/ +/** Storage Mutation Functions **/ +/** **/ +/***************************************************************************/ + +int la_put_integer(p, i, x) + PTR p; + int i, x; +{ + *(((int *) p) + i) = x; + return(0); +} + +int la_put_double(p, i, x) + PTR p; + int i; + double x; +{ + *(((double *) p) + i) = x; + return(0); +} + +int la_put_complex(p, i, x, y) + PTR p; + int i; + double x, y; +{ + Complex *c = ((Complex *) p) + i; + c->real = x; + c->imag = y; + return(0); +} + +int la_put_pointer(p, i, x) + PTR p, x; + int i; +{ + *(((PTR *) p) + i) = x; + return(0); +} + +/***********************************************************************/ +/** **/ +/** XLISP Internal Error Message Emulation **/ +/** **/ +/***********************************************************************/ + +char buf[1000]; + +static int (*ccl_set_buf_char_fptr)(); +register_set_buf_char(f) int (*f)(); { ccl_set_buf_char_fptr = f; } +set_buf_char(n, c) int n, c; { (*ccl_set_buf_char_fptr)(n, c); } + +static int (*ccl_print_buffer)(); +register_print_buffer(f) int (*f)(); { ccl_print_buffer = f; } +print_buffer(n, m) int n, m; { (*ccl_print_buffer)(n, m); } + +static int bufpos = 0; + +static resetbuf() { bufpos = 0; } + +static prbuf(s) + char *s; +{ + int i, n; + + n = strlen(s); + for (i = 0; i +static char buf[200]; +#define PRINTSTR(s) printf(s) +#else +# include "xmath.h" +extern char buf[]; +#define PRINTSTR(s) stdputstr(s) +#endif SBAYES + +extern double macheps(); + +/************************************************************************/ +/** **/ +/** Definitions and Globals **/ +/** **/ +/************************************************************************/ + +# define nil 0L +# define FALSE 0 +# define TRUE 1 + +# define INIT_GRAD_FRAC .001 +# define CONSEC_MAX_LIMIT 5 +# define ALPHA .0001 +# define MAX_STEP_FACTOR 1000 +# define GRADTOL_POWER 1.0 / 3.0 +# define STEPTOL_POWER 2.0 / 3.0 +# define ITNLIMIT 100 +# define VERBOSE 0 +# define USE_SEARCH TRUE + +typedef double **RMatrix, *RVector; + +typedef struct { + int n, k; + int (*ffun)(), (*gfun)(); + double f, typf, new_f; + double crit, new_crit; + RVector x, new_x, sx, delf, new_delf, qnstep, F; + RMatrix hessf, H, L, new_delg; + double gradtol, steptol, maxstep; + int itncount, itnlimit, maxtaken, consecmax, retcode, termcode; + int use_line_search, verbose, values_supplied, change_sign; + double diagadd; +} Iteration; + +static char *termcodes[] = {"not yet terminated", + "gradient size is less than gradient tolerance", + "step size is less than step tolerance", + "no satisfactory step found in backtracking", + "iteration limit exceeded", + "maximum size step taken 5 iterations in a row"}; + +/************************************************************************/ +/** **/ +/** Utility Functions **/ +/** **/ +/************************************************************************/ + +static double Max(a, b) + double a, b; +{ + return(a > b ? a : b); +} + +static double Min(a, b) + double a, b; +{ + return(a > b ? b : a); +} + +/************************************************************************/ +/** **/ +/** Cholesky Solving Functions **/ +/** **/ +/************************************************************************/ + +/* solve (L L^T) s = -g for s */ +static cholsolve(n, g, L, s) + int n; + RVector g, s; + RMatrix L; +{ + int i; + + /* solve Ly = g */ + lsolve(n, g, L, s); + + /* solve L^Ts = y */ + ltsolve(n, s, L, s); + + for (i = 0; i < n; i++) s[i] = -s[i]; +} + +/* solve Ly = b for y */ +static lsolve(n, b, L, y) + int n; + RVector b, y; + RMatrix L; +{ + int i, j; + + for (i = 0; i < n; i++) { + y[i] = b[i]; + for (j = 0; j < i; j++) y[i] -= L[i][j] * y[j]; + if (L[i][i] != 0) y[i] /= L[i][i]; + } +} + +/* solve (L^T)x = y for x */ +static ltsolve(n, y, L, x) + int n; + RVector y, x; + RMatrix L; +{ + int i, j; + + for (i = n - 1; i >= 0; i--) { + x[i] = y[i]; + for (j = i + 1; j < n; j++) x[i] -= L[j][i] * x[j]; + if (L[i][i] != 0) x[i] /= L[i][i]; + } +} + +static modelhess(n, sx, H, L, diagadd) + int n; + RVector sx; + RMatrix H, L; + double *diagadd; +{ + int i, j; + double sqrteps, maxdiag, mindiag, maxoff, maxoffl, maxposdiag, mu, + maxadd, maxev, minev, offrow, sdd; + + /* scale H on both sides with sx */ + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) H[i][j] /= sx[i] * sx[j]; + + /* + * find mu to add to diagonal so no diagonal elements are negative + * and largest diagonal dominates largest off diagonal element in H + */ + sqrteps = sqrt(macheps()); + for (maxdiag = H[0][0], i = 1; i < n; i++) + maxdiag = Max(maxdiag, H[i][i]); + for (mindiag = H[0][0], i = 1; i < n; i++) + mindiag = Min(mindiag, H[i][i]); + maxposdiag = Max(0.0, maxdiag); + + if (mindiag <= sqrteps * maxposdiag) { + mu = 2 * (maxposdiag - mindiag) * sqrteps - mindiag; + maxdiag += mu; + } + else mu = 0.0; + + if (n > 1) { + for (maxoff = fabs(H[0][1]), i = 0; i < n; i++) + for (j = i + 1; j < n; j++) + maxoff = Max(maxoff, fabs(H[i][j])); + } + else maxoff = 0.0; + + if (maxoff * (1 + 2 * sqrteps) > maxdiag) { + mu += (maxoff - maxdiag) + 2 * sqrteps * maxoff; + maxdiag = maxoff * (1 + 2 * sqrteps); + } + + if (maxdiag == 0.0) { + mu = 1; + maxdiag = 1; + } + + if (mu > 0) for (i = 0; i < n; i++) H[i][i] += mu; + + maxoffl = sqrt(Max(maxdiag, maxoff / n)); + + /* + * compute the perturbed Cholesky decomposition + */ + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) L[i][j] = H[i][j]; + choldecomp(L, n, maxoffl, &maxadd); + + /* + * add something to diagonal, if needed, to make positive definite + * and recompute factorization + */ + if (maxadd > 0) { + maxev = H[0][0]; + minev = H[0][0]; + for (i = 0; i < n; i++) { + for (offrow = 0.0, j = 0; j < n; j++) + if (i != j) offrow += fabs(H[i][j]); + maxev = Max(maxev, H[i][i] + offrow); + minev = Min(minev, H[i][i] - offrow); + } + sdd = (maxev - minev) * sqrteps - minev; + sdd = Max(sdd, 0.0); + mu = Min(maxadd, sdd); + for (i = 0; i < n; i++) H[i][i] += mu; + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) L[i][j] = H[i][j]; + choldecomp(L, n, maxoffl, &maxadd); + *diagadd = mu; + } + else *diagadd = 0.0; + + /* unscale H and L */ + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) { + H[i][j] *= sx[i] * sx[j]; + L[i][j] *= sx[i]; + } +} + +/************************************************************************/ +/** **/ +/** Stopping Criteria **/ +/** **/ +/************************************************************************/ + +static double gradsize(iter, new) + Iteration *iter; + int new; +{ + int n, i; + double size, term, crit, typf; + RVector x, delf, sx; + + n = iter->n + iter->k; + crit = iter->crit; + typf = iter->typf; + x = iter->x; + sx = iter->sx; + delf = (new) ? iter->new_delf : iter->delf; + + for (i = 0, size = 0.0; i < n; i++) { + term = fabs(delf[i]) * Max(x[i], 1.0 / sx[i]) / Max(fabs(crit), typf); + size = Max(size, term); + } + return(size); +} + +static double incrsize(iter) + Iteration *iter; +{ + int n, i; + double size, term; + RVector x, new_x, sx; + + new_x = iter->new_x; + n = iter->n + iter->k; + x = iter->x; + sx = iter->sx; + + for (i = 0, size = 0.0; i < n; i++) { + term = fabs(x[i] - new_x[i]) / Max(fabs(x[i]), 1.0 / sx[i]); + size = Max(size, term); + } + return(size); +} + +static stoptest0(iter) + Iteration *iter; +{ + iter->consecmax = 0; + + if (gradsize(iter, FALSE) <= INIT_GRAD_FRAC * iter->gradtol) + iter->termcode = 1; + else iter->termcode = 0; + + return(iter->termcode); +} + +static stoptest(iter) + Iteration *iter; +{ + int termcode, retcode, itncount, itnlimit, maxtaken, consecmax; + double gradtol, steptol; + + retcode = iter->retcode; + gradtol = iter->gradtol; + steptol = iter->steptol; + itncount = iter->itncount; + itnlimit = iter->itnlimit; + maxtaken = iter->maxtaken; + consecmax = iter->consecmax; + + termcode = 0; + if (retcode == 1) termcode = 3; + else if (gradsize(iter, TRUE) <= gradtol) termcode = 1; + else if (incrsize(iter) <= steptol) termcode = 2; + else if (itncount >= itnlimit) termcode = 4; + else if (maxtaken) { + consecmax++; + if (consecmax >= CONSEC_MAX_LIMIT) termcode = 5; + } + else consecmax = 0; + + iter->consecmax = consecmax; + iter->termcode = termcode; + + return(termcode); +} + +/************************************************************************/ +/** **/ +/** Function and Derivative Evaluation **/ +/** **/ +/************************************************************************/ + +static eval_funval(iter) + Iteration *iter; +{ + int i; + + (*(iter->ffun))(iter->x, &iter->f, nil, nil); + if (iter->k == 0) iter->crit = iter->f; + else { + eval_gradient(iter); + for (i = 0, iter->crit = 0.0; i < iter->n + iter->k; i++) + iter->crit += 0.5 * pow(fabs(iter->delf[i]), 2.0); + } +} + +static eval_next_funval(iter) + Iteration *iter; +{ + int i; + + (*(iter->ffun))(iter->new_x, &iter->new_f, nil, nil); + if (iter->k == 0) iter->new_crit = iter->new_f; + else { + eval_next_gradient(iter); + for (i = 0, iter->new_crit = 0.0; i < iter->n + iter->k; i++) + iter->new_crit += 0.5 * pow(fabs(iter->new_delf[i]), 2.0); + } +} + +static eval_gradient(iter) + Iteration *iter; +{ + int i, j, n, k; + + n = iter->n; + k = iter->k; + + (*(iter->ffun))(iter->x, nil, iter->delf, nil); + if (k > 0) { + (*(iter->gfun))(iter->x, iter->delf + n, nil, nil); + (*(iter->gfun))(iter->x, nil, iter->new_delg, nil); + for (i = 0; i < n; i++) { + for (j = 0; j < k; j++) + iter->delf[i] += iter->x[n + j] * iter->new_delg[j][i]; + for (j = 0; j < k; j++) { + iter->hessf[n + j][i] = iter->new_delg[j][i]; + iter->hessf[i][n + j] = iter->new_delg[j][i]; + } + } + } +} + +static eval_next_gradient(iter) + Iteration *iter; +{ + int i, j, n, k; + + n = iter->n; + k = iter->k; + (*(iter->ffun))(iter->new_x, nil, iter->new_delf, nil); + if (k > 0) { + (*(iter->gfun))(iter->new_x, iter->new_delf + n, nil, nil); + (*(iter->gfun))(iter->new_x, nil, iter->new_delg, nil); + for (i = 0; i < n; i++) { + for (j = 0; j < k; j++) + iter->new_delf[i] += iter->new_x[n + j] * iter->new_delg[j][i]; + } + } +} + +static eval_hessian(iter) + Iteration *iter; +{ + int i, j, n, k; + + n = iter->n; + k = iter->k; + (*(iter->ffun))(iter->x, nil, nil, iter->hessf); + for (i = n; i < n + k; i++) + for (j = n; j < n + k; j++) iter->hessf[i][j] = 0.0; +} + +/************************************************************************/ +/** **/ +/** Backtracking Line Search **/ +/** **/ +/************************************************************************/ + +static linesearch(iter) + Iteration *iter; +{ + int i, n; + double newtlen, maxstep, initslope, rellength, lambda, minlambda, + lambdatemp, lambdaprev, a, b, disc, critprev, f1, f2, a11, a12, a21, a22, + del; + RVector qnstep, delf, x, new_x, sx; + + n = iter->n + iter->k; + if (! iter->use_line_search) { + iter->maxtaken = FALSE; + for (i = 0; i < n; i++) + iter->new_x[i] = iter->x[i] + iter->qnstep[i]; + eval_next_funval(iter); + iter->retcode = 0; + } + else{ + qnstep = iter->qnstep; + maxstep = iter->maxstep; + delf = (iter->k == 0) ? iter->delf : iter->F; + x = iter->x; + new_x = iter->new_x; + sx = iter->sx; + + iter->maxtaken = FALSE; + iter->retcode = 2; + + for (i = 0, newtlen = 0.0; i < n; i++) + newtlen += pow(sx[i] * qnstep[i], 2.0); + newtlen = sqrt(newtlen); + + if (newtlen > maxstep) { + for (i = 0; i < n; i++) qnstep[i] *= (maxstep / newtlen); + newtlen = maxstep; + } + + for (i = 0, initslope = 0.0; i < n; i++) initslope += delf[i] * qnstep[i]; + + for (i = 0, rellength = 0.0; i < n; i++) + rellength = Max(rellength, fabs(qnstep[i]) / Max(fabs(x[i]), 1.0 / sx[i])); + + minlambda = (rellength == 0.0) ? 2.0 : iter->steptol / rellength; + + lambda = 1.0; + lambdaprev = 1.0; /* to make compilers happy */ + critprev = 1.0; /* to make compilers happy */ + while (iter->retcode > 1) { + for (i = 0; i < n; i++) new_x[i] = x[i] + lambda * qnstep[i]; + eval_next_funval(iter); + if (iter->new_crit <= iter->crit + ALPHA * lambda * initslope) { + iter->retcode = 0; + if (lambda == 1.0 && newtlen > 0.99 * maxstep) iter->maxtaken = TRUE; + } + else if (lambda < minlambda) { + iter->retcode = 1; + iter->new_crit = iter->crit; + for (i = 0; i < n; i++) new_x[i] = x[i]; + } + else { + if (lambda == 1.0) { /* first backtrack, quadratic fit */ + lambdatemp = - initslope + / (2 * (iter->new_crit - iter->crit - initslope)); + } + else { /* all subsequent backtracks, cubic fit */ + del = lambda - lambdaprev; + f1 = iter->new_crit - iter->crit - lambda * initslope; + f2 = critprev - iter->crit - lambdaprev * initslope; + a11 = 1.0 / (lambda * lambda); + a12 = -1.0 / (lambdaprev * lambdaprev); + a21 = -lambdaprev * a11; + a22 = -lambda * a12; + a = (a11 * f1 + a12 * f2) / del; + b = (a21 * f1 + a22 * f2) / del; + disc = b * b - 3 * a * initslope; + if (a == 0) { /* cubic is a quadratic */ + lambdatemp = - initslope / (2 * b); + } + else { /* legitimate cubic */ + lambdatemp = (-b + sqrt(disc)) / (3 * a); + } + lambdatemp = Min(lambdatemp, 0.5 * lambda); + } + lambdaprev = lambda; + critprev = iter->new_crit; + lambda = Max(0.1 * lambda, lambdatemp); + if (iter->verbose > 0) { + sprintf(buf, "Backtracking: lambda = %g\n", lambda); + PRINTSTR(buf); + } + } + } + } +} + +/************************************************************************/ +/** **/ +/** Status Printing Functions **/ +/** **/ +/************************************************************************/ + +static print_header(iter) + Iteration *iter; +{ + if (iter->verbose > 0) { + sprintf(buf, "Iteration %d.\n", iter->itncount); + PRINTSTR(buf); + } +} + +static print_status(iter) + Iteration *iter; +{ + int i, j; + + if (iter->verbose > 0) { + sprintf(buf, "Criterion value = %g\n", + (iter->change_sign) ? -iter->crit : iter->crit); + PRINTSTR(buf); + if (iter->verbose > 1) { + PRINTSTR("Location = <"); + for (i = 0; i < iter->n + iter->k; i++) { + sprintf(buf, (i < iter->n + iter->k - 1) ? "%g " : "%g>\n", iter->x[i]); + PRINTSTR(buf); + } + } + if (iter->verbose > 2) { + PRINTSTR("Gradient = <"); + for (i = 0; i < iter->n + iter->k; i++) { + sprintf(buf, (i < iter->n + iter->k - 1) ? "%g " : "%g>\n", + (iter->change_sign) ? -iter->delf[i] : iter->delf[i]); + PRINTSTR(buf); + } + } + if (iter->verbose > 3) { + PRINTSTR("Hessian:\n"); + for (i = 0; i < iter->n + iter->k; i++) { + for (j = 0; j < iter->n + iter->k; j++) { + sprintf(buf, (j < iter->n + iter->k - 1) ? "%g " : "%g\n", + (iter->change_sign) ? -iter->hessf[i][j] : iter->hessf[i][j]); + PRINTSTR(buf); + } + } + } + } + if (iter->termcode != 0 && iter->verbose > 0) { + sprintf(buf, "Reason for termination: %s.\n", termcodes[iter->termcode]); + PRINTSTR(buf); + } +} + +/************************************************************************/ +/** **/ +/** Iteration Driver **/ +/** **/ +/************************************************************************/ + +static findqnstep(iter) + Iteration *iter; +{ + int i, j, N, l; + + if (iter->k == 0) { + modelhess(iter->n, iter->sx, iter->hessf, iter->L, &iter->diagadd); + cholsolve(iter->n, iter->delf, iter->L, iter->qnstep); + } + else { + N = iter->n + iter->k; + for (i = 0; i < N; i++) { + for (l = 0, iter->F[i] = 0.0; l < N; l++) + iter->F[i] += iter->hessf[i][l] * iter->delf[l]; + for (j = 0; j < N; j++) + for (l = 0, iter->H[i][j] = 0.0; l < N; l++) + iter->H[i][j] += iter->hessf[i][l] * iter->hessf[j][l]; + } + modelhess(N, iter->sx, iter->H, iter->L, &iter->diagadd); + cholsolve(N, iter->F, iter->L, iter->qnstep); + } +} + +static iterupdate(iter) + Iteration *iter; +{ + int i, j, n, k; + + n = iter->n; + k = iter->k; + iter->f = iter->new_f; + iter->crit = iter->new_crit; + for (i = 0; i < n + k; i++) { + iter->x[i] = iter->new_x[i]; + iter->delf[i] = iter->new_delf[i]; + } + for (i = 0; i < k; i++) { + for (j = 0; j < n; j++) { + iter->hessf[n + i][j] = iter->new_delg[i][j]; + iter->hessf[j][n + i] = iter->new_delg[i][j]; + } + } +} + +static mindriver(iter) + Iteration *iter; +{ + iter->consecmax = 0; + iter->itncount = 0; + iter->termcode = 0; + if (! iter->values_supplied) { + eval_funval(iter); + if (iter->k == 0) eval_gradient(iter); + eval_hessian(iter); + } + + stoptest0(iter); + print_header(iter); + print_status(iter); + while (iter->termcode == 0) { + iter->itncount++; + print_header(iter); + findqnstep(iter); + linesearch(iter); + if (iter->k == 0) eval_next_gradient(iter); + stoptest(iter); + iterupdate(iter); + eval_hessian(iter); + print_status(iter); + } +} + +/************************************************************************/ +/** **/ +/** External Interface Routines **/ +/** **/ +/************************************************************************/ + +static Iteration myiter; + +minworkspacesize(n, k) + int n, k; +{ + int size; + + /* x, new_x, sx, delf, new_delf, qnstep and F */ + size = 7 * sizeof(double) * (n + k); + + /* hessf, H and L */ + size += 3 * (sizeof(double *) * (n + k) + + sizeof(double) * (n + k) * (n + k)); + + /* delg and new_delg */ + size += 2 * (sizeof(double *) * k + sizeof(double) * n * k); + + return(size); +} + +char *minresultstring(code) + int code; +{ + if (code <= 0) return("bad input data"); + else if (code <= 5) return(termcodes[code]); + else return("unknown return code"); +} + +minsetup(n, k, ffun, gfun, x, typf, typx, work) + int n, k, (*ffun)(), (*gfun)(); + RVector x, typx; + double typf; + char *work; +{ + Iteration *iter = &myiter; + int i, j; + double nx0, ntypx; + + n = (n > 0) ? n : 0; + k = (k > 0) ? k : 0; + + iter->n = n; + iter->k = k; + iter->ffun = ffun; + iter->gfun = gfun; + + iter->x = (RVector) work; work += sizeof(double) * (n + k); + iter->new_x = (RVector) work; work += sizeof(double) * (n + k); + iter->sx = (RVector) work; work += sizeof(double) * (n + k); + iter->delf = (RVector) work; work += sizeof(double) * (n + k); + iter->new_delf = (RVector) work; work += sizeof(double) * (n + k); + iter->qnstep = (RVector) work; work += sizeof(double) * (n + k); + iter->F = (RVector) work; work += sizeof(double) * (n + k); + for (i = 0; i < n; i++) { + iter->x[i] = x[i]; + iter->sx[i] = (typx != nil && typx[i] > 0.0) ? 1.0 / typx[i] : 1.0; + } + for (i = 0; i < k; i++) { + iter->x[n + i] = x[n + i]; + iter->sx[n + i] = 1.0; + } + + iter->hessf = (RMatrix) work; work += sizeof(double *) * (n + k); + for (i = 0; i < n + k; i++) { + iter->hessf[i] = (RVector) work; + work += sizeof(double) * (n + k); + } + for (i = 0; i < n + k; i++) + for (j = 0; j < n + k; j++) iter->hessf[i][j] = 0.0; + iter->L = (RMatrix) work; work += sizeof(double *) * (n + k); + for (i = 0; i < n + k; i++) { + iter->L[i] = (RVector) work; + work += sizeof(double) * (n + k); + } + iter->H = (RMatrix) work; work += sizeof(double *) * (n + k); + for (i = 0; i < n + k; i++) { + iter->H[i] = (RVector) work; + work += sizeof(double) * (n + k); + } + + iter->new_delg = (k > 0) ? (RMatrix) work : nil; + work += sizeof(double *) * k; + for (i = 0; i < k; i++) { + iter->new_delg[i] = (RVector) work; + work += sizeof(double) * n; + } + + iter->typf = (typf > 0.0) ? typf : 1.0; + + iter->verbose = VERBOSE; + iter->use_line_search = USE_SEARCH; + iter->itncount = 0; + iter->itnlimit = ITNLIMIT; + iter->gradtol = pow(macheps(), GRADTOL_POWER); + iter->steptol = pow(macheps(), STEPTOL_POWER); + for (i = 0, nx0 = 0.0, ntypx = 0.0; i < iter->n; i++) { + nx0 += fabs(iter->new_x[i] / iter->sx[i]); + ntypx += fabs(1.0 / iter->sx[i]); + } + iter->maxstep = MAX_STEP_FACTOR * Max(nx0, ntypx); + iter->values_supplied = FALSE; +} + +minsetoptions(gradtol, steptol, maxstep, itnlimit, verbose, use_search, change_sign) + double gradtol, steptol, maxstep; + int itnlimit, verbose, use_search, change_sign; +{ + Iteration *iter = &myiter; + + if (gradtol > 0.0) iter->gradtol = gradtol; + if (steptol > 0.0) iter->steptol = steptol; + if (maxstep > 0.0) iter->maxstep = maxstep; + if (itnlimit >= 0) iter->itnlimit = itnlimit; + if (verbose >= 0) iter->verbose = verbose; + iter->use_line_search = use_search; + iter->change_sign = change_sign; +} + +minsupplyvalues(f, delf, hessf, g, delg) + double f; + RVector delf, g; + RMatrix hessf, delg; +{ + Iteration *iter = &myiter; + int i, j, n, k; + + n = iter->n; + k = iter->k; + + iter->f = f; + for (i = 0; i < n; i++) { + iter->delf[i] = delf[i]; + for (j = 0; j < k; j++) + iter->delf[i] += iter->x[n + j] * delg[j][i]; + for (j = 0; j < n; j++) iter->hessf[i][j] = hessf[i][j]; + } + for (i = 0; i < k; i++) { + iter->delf[n + i] = g[i]; + for (j = 0; j < n; j++) { + iter->hessf[n + i][j] = delg[i][j]; + iter->hessf[j][n + i] = delg[i][j]; + } + } + if (k == 0) iter->crit = f; + else { + for (i = 0, iter->crit = 0.0; i < n + k; i++) + iter->crit += 0.5 * pow(fabs(iter->delf[i]), 2.0); + } + iter->values_supplied = TRUE; +} + +minimize() { mindriver(&myiter); } + +minresults(x, pf, pcrit, delf, hessf, g, delg, pcount, ptermcode, diagadd) + RVector x, delf, g; + double *pf, *pcrit, *diagadd; + RMatrix hessf, delg; + int *pcount, *ptermcode; +{ + Iteration *iter = &myiter; + int i, j, n, k; + + n = iter->n; + k = iter->k; + + if (pf != nil) *pf = iter->f; + if (pcrit != nil) *pcrit = iter->crit; + for (i = 0; i < n; i++) { + if (x != nil) x[i] = iter->x[i]; + if (delf != nil) delf[i] = iter->delf[i]; + for (j = 0; j < n; j++) if (hessf != nil) hessf[i][j] = iter->hessf[i][j]; + } + for (i = 0; i < k; i++) { + if (x != nil) x[n + i] = iter->x[n + i]; + if (g != nil) g[i] = iter->delf[n + i]; + for (j = 0; j < n; j++) + if (delg != nil) delg[i][j] = iter->hessf[n + i][j]; + } + if (pcount != nil) *pcount = iter->itncount; + if (ptermcode != nil) *ptermcode = iter->termcode; + if (diagadd != nil) *diagadd = iter->diagadd; +} + +#ifdef SBAYES +double pdlogdet(n, H) + int n; + RMatrix H; +{ + int i; + double logdet, maxadd; + + choldecomp(H, n, 0.0, &maxadd); + for (i = 0, logdet = 0.0; i < n; i++) logdet += 2.0 * log(H[i][i]); + return(logdet); +} +#endif /* SBAYES */ +#ifdef TODO +return amount added to make pos definite +scaling for constraints +alternate global strategies +callback function for verbose mode +#endif TODO diff --git a/lib/nor.c b/lib/nor.c new file mode 100644 index 0000000..67fca0c --- /dev/null +++ b/lib/nor.c @@ -0,0 +1,90 @@ +# include +# include "xmath.h" + +#define P10 242.66795523053175 +#define P11 21.979261618294152 +#define P12 6.9963834886191355 +#define P13 -.035609843701815385 +#define Q10 215.05887586986120 +#define Q11 91.164905404514901 +#define Q12 15.082797630407787 +#define Q13 1.0 + +#define P20 300.4592610201616005 +#define P21 451.9189537118729422 +#define P22 339.3208167343436870 +#define P23 152.9892850469404039 +#define P24 43.16222722205673530 +#define P25 7.211758250883093659 +#define P26 .5641955174789739711 +#define P27 -.0000001368648573827167067 +#define Q20 300.4592609569832933 +#define Q21 790.9509253278980272 +#define Q22 931.3540948506096211 +#define Q23 638.9802644656311665 +#define Q24 277.5854447439876434 +#define Q25 77.00015293522947295 +#define Q26 12.78272731962942351 +#define Q27 1.0 + +#define P30 -.00299610707703542174 +#define P31 -.0494730910623250734 +#define P32 -.226956593539686930 +#define P33 -.278661308609647788 +#define P34 -.0223192459734184686 +#define Q30 .0106209230528467918 +#define Q31 .191308926107829841 +#define Q32 1.05167510706793207 +#define Q33 1.98733201817135256 +#define Q34 1.0 + +#define SQRT2 1.414213562373095049 +#define SQRTPI 1.772453850905516027 + +normbase(x, phi) +double *x, *phi; +{ + int sn; + double R1, R2, y, y2, y3, y4, y5, y6, y7, erf, erfc, z, z2, z3, z4; + + y = *x / SQRT2; + if (y < 0) { + y = -y; + sn = -1; + } + else sn = 1; + y2 = y * y; + y4 = y2 * y2; + y6 = y4 * y2; + + if(y < 0.46875) { + R1 = P10 + P11 * y2 + P12 * y4 + P13 * y6; + R2 = Q10 + Q11 * y2 + Q12 * y4 + Q13 * y6; + erf = y * R1 / R2; + if(sn == 1) *phi = 0.5 + 0.5*erf; + else *phi = 0.5 - 0.5*erf; + } + else if(y < 4.0) { + y3 = y2 * y; + y5 = y4 * y; + y7 = y6 * y; + R1 = P20 + P21 * y + P22 * y2 + P23 * y3 + P24 * y4 + P25 * y5 + + P26 * y6 + P27 * y7; + R2 = Q20 + Q21 * y + Q22 * y2 + Q23 * y3 + Q24 * y4 + Q25 * y5 + + Q26 * y6 + Q27 * y7; + erfc = exp(-y2) * R1 / R2; + if(sn == 1) *phi = 1.0 - 0.5*erfc; + else *phi = 0.5*erfc; + } + else { + z = y4; + z2 = z * z; + z3 = z2 * z; + z4 = z2 * z2; + R1 = P30 + P31 * z + P32 * z2 + P33 * z3 + P34 * z4; + R2 = Q30 + Q31 * z + Q32 * z2 + Q33 * z3 + Q34 * z4; + erfc = (exp(-y2)/y) * (1.0 / SQRTPI + R1 / (R2 * y2)); + if(sn == 1) *phi = 1.0 - 0.5*erfc; + else *phi = 0.5*erfc; + } +} diff --git a/lib/ppnd.c b/lib/ppnd.c new file mode 100644 index 0000000..f8f218a --- /dev/null +++ b/lib/ppnd.c @@ -0,0 +1,60 @@ +#include "xmath.h" + +#define zero 0.0 +#define half 0.5 +#define one 1.0 +#define split 0.42e0 +#define a0 2.50662823884e0 +#define a1 -18.61500062529e0 +#define a2 41.39119773534e0 +#define a3 -25.44106049637e0 +#define b1 -8.47351093090e0 +#define b2 23.08336743743e0 +#define b3 -21.06224101826e0 +#define b4 3.13082909833e0 + +#define c0 -2.78718931138e0 +#define c1 -2.29796479134e0 +#define c2 4.85014127135e0 +#define c3 2.32121276858e0 +#define d1 3.54388924762e0 +#define d2 1.63706781897e0 + +/* +c +c Algorithm as 111 Applied statistics (1977), vol 26 no 1 page 121 +c Produces normal deviate corresponding to lower tail area of p +c the hash sums are the sums of the moduli of the coefficients +c they nave no inherent meanings but are incuded for use in +c checking transcriptions. Functions abs,alog and sqrt are used. +c + +derived from AS111 fortran version +*/ + +double ppnd(p, ifault) + double p; + int *ifault; +{ + double q,r,ppn; + + *ifault = 0; + q = p - half; + if( fabs(q) <= split) { + r = q*q; + ppn = q * (((a3 * r + a2) * r + a1) * r + a0) + / ((((b4 * r + b3) * r + b2) * r + b1) * r + one); + } + else { + r = p; + if(q > zero) r = one - p; + if(r <= zero) { + *ifault = 1; + return(0.0); + } + r = sqrt(-log(r)); + ppn = (((c3*r+c2)*r + c1) * r + c0) / ((d2 * r + d1) * r + one); + if( q < zero) ppn = -ppn; + } + return(ppn); +} diff --git a/lib/qrdecomp.c b/lib/qrdecomp.c new file mode 100644 index 0000000..b7c9708 --- /dev/null +++ b/lib/qrdecomp.c @@ -0,0 +1,186 @@ +/* adapted from DQRDC of LINPACK */ + +#include "linalg.h" + +#define SIGN(a, b) ((b) >= 0.0 ? fabs(a) : -fabs(a)) + +static double NORM2(i, j, n, x) + int i, j, n; + double **x; +{ + int k; + double maxx, sum, temp; + + for (k = i, maxx = 0.0; k < n; k++) { + temp = fabs(x[k][j]); + if (maxx < temp) maxx = temp; + } + if (maxx == 0.0) return(0.0); + else { + for (k = i, sum = 0.0; k < n; k++) { + temp = x[k][j] / maxx; + sum += temp * temp; + } + return(maxx * sqrt(sum)); + } +} + +static double DOT(i, j, k, n, x) + int i, j, k; + double **x; +{ + int l; + double sum; + + for (l = i, sum = 0.0; l < n; l++) sum += x[l][j] * x[l][k]; + return(sum); +} + +static AXPY(i, j, k, n, a, x) + int i, j, k, n; + double a, **x; +{ + int l; + for (l = i; l < n; l++) x[l][k] = a * x[l][j] + x[l][k]; +} + +static SCALE(i, j, n, a, x) + int i, j, n; + double a, **x; +{ + int k; + for (k = i; k < n; k++) x[k][j] *= a; +} + +static SWAP(i, j, n, a) + int i, j, n; + double **a; +{ + int k; + double temp; + for (k = 0; k < n; k++) { + temp = a[k][i]; + a[k][i] = a[k][j]; + a[k][j] = temp; + } +} + +qrdecomp(x,n,p,v,jpvt,pivot) + int n, p, pivot; + int *jpvt; + double **x, **v; +{ + int i,j,k,jp,l,lp1,lup,maxj; + double maxnrm,tt,*qraux,*work; + double nrmxl,t; + + if (n < 0) return; + work = v[0]; + qraux = rvector(p); + + /* + * compute the norms of the free columns. + */ + if (pivot) + for (j = 0; j < p; j++) { + jpvt[j] = j; + qraux[j] = NORM2(0, j, n, x); + work[j] = qraux[j]; + } + /* + * perform the householder reduction of x. + */ + lup = (n < p) ? n : p; + for (l = 0; l < lup; l++) { + if (pivot) { + /* + * locate the column of largest norm and bring it + * into the pivot position. + */ + maxnrm = 0.0; + maxj = l; + for (j = l; j < p; j++) + if (qraux[j]>maxnrm) { + maxnrm = qraux[j]; + maxj = j; + } + if (maxj!=l) { + SWAP(l, maxj, n, x); + qraux[maxj] = qraux[l]; + work[maxj] = work[l]; + jp = jpvt[maxj]; + jpvt[maxj] = jpvt[l]; + jpvt[l] = jp; + } + } + qraux[l] = 0.0; + if (l != n-1) { + /* + * compute the householder transformation for column l. + */ + nrmxl = NORM2(l, l, n, x); + if (nrmxl != 0.0) { + if (x[l][l] != 0.0) + nrmxl = SIGN(nrmxl, x[l][l]); + SCALE(l, l, n, 1.0 / nrmxl, x); + x[l][l] = 1.0+x[l][l]; + /* + * apply the transformation to the remaining columns, + * updating the norms. + */ + lp1 = l+1; + for (j = lp1; j < p; j++) { + t = -DOT(l, l, j, n, x) / x[l][l]; + AXPY(l, l, j, n, t, x); + if (pivot) + if (qraux[j]!=0.0) { + tt = 1.0-(fabs(x[l][j])/qraux[j])*(fabs(x[l][j])/qraux[j]); + if (tt < 0.0) tt = 0.0; + t = tt; + tt = 1.0+0.05*tt*(qraux[j]/work[j])*(qraux[j]/work[j]); + if (tt!=1.0) + qraux[j] = qraux[j]*sqrt(t); + else { + qraux[j] = NORM2(l+1, j, n, x); + work[j] = qraux[j]; + } + } + } + /* + * save the transformation. + */ + qraux[l] = x[l][l]; + x[l][l] = -nrmxl; + } + } + } + + /* copy over the upper triangle of a */ + for (i = 0; i < p; i++) { + for (j = 0; j < i; j++) v[i][j] = 0.0; + for (j = i; j < p; j++) { + v[i][j] = x[i][j]; + } + } + + /* accumulate the Q transformation -- assumes p <= n */ + for (i = 0; i < p; i++) { + x[i][i] = qraux[i]; + for (k = 0; k < i; k++) x[k][i] = 0.0; + } + for (i = p - 1; i >= 0; i--) { + if (i == n - 1) x[i][i] = 1.0; + else { + for (k = i; k < n; k++) x[k][i] = -x[k][i]; + x[i][i] += 1.0; + } + for (j = i - 1; j >= 0; j--) { + if (x[j][j] != 0.0) { + t = -DOT(j, j, i, n, x) / x[j][j]; + AXPY(j, j, i, n, t, x); + } + } + } + + free_vector(qraux); +} diff --git a/lib/rcondest.c b/lib/rcondest.c new file mode 100644 index 0000000..8361e3b --- /dev/null +++ b/lib/rcondest.c @@ -0,0 +1,100 @@ +/* rcondest - Estimates reciprocal of condition number. */ +/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */ +/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */ +/* You may give out copies of this software; for conditions see the */ +/* file COPYING included with this distribution. */ + +#include "linalg.h" + +static double Max(a, b) + double a, b; +{ + return(a > b ? a : b); +} + +double rcondest(a, n) + RMatrix a; + int n; +{ + RVector p, pm, x; + double est, xp, xm, temp, tempm, xnorm; + int i, j; + + for (i = 0; i < n; i++) + if (a[i][i] == 0.0) return(0.0); + + p = rvector(n); + pm = rvector(n); + x = rvector(n); + + /* Set est to reciprocal of L1 matrix norm of A */ + est = fabs(a[0][0]); + for (j = 1; j < n; j++) { + for (i = 0, temp = fabs(a[j][j]); i < j; i++) + temp += fabs(a[i][j]); + est = Max(est, temp); + } + est = 1.0 / est; + + /* Solve A^Tx = e, selecting e as you proceed */ + x[0] = 1.0 / a[0][0]; + for (i = 1; i < n; i++) p[i] = a[0][i] * x[0]; + for (j = 1; j < n; j++) { + /* select ej and calculate x[j] */ + xp = ( 1.0 - p[j]) / a[j][j]; + xm = (-1.0 - p[j]) / a[j][j]; + temp = fabs(xp); + tempm = fabs(xm); + for (i = j + 1; i < n; i++) { + pm[i] = p[i] + a[j][i] * xm; + tempm += fabs(pm[i] / a[i][i]); + p[i] += a[j][i] * xp; + temp += fabs(p[i] / a[i][i]); + } + if (temp >= tempm) x[j] = xp; + else { + x[j] = xm; + for (i = j + 1; i < n; i++) p[i] = pm[i]; + } + } + + for (j = 0, xnorm = 0.0; j < n; j++) xnorm += fabs(x[j]); + est = est * xnorm; + backsolve(a, x, n, RE); + for (j = 0, xnorm = 0.0; j < n; j++) xnorm += fabs(x[j]); + if (xnorm > 0) est = est / xnorm; + + free_vector(p); + free_vector(pm); + free_vector(x); + + return(est); +} + +backsolve(a, b, n, mode) + Matrix a; + Vector b; + int n; +{ + int i, j; + RMatrix ra = (RMatrix) a; + RVector rb = (RVector) b; + CMatrix ca = (CMatrix) a; + CVector cb = (CVector) b; + + switch (mode) { + case RE: + for (i = n - 1; i >= 0; i--) { + if (ra[i][i] != 0.0) rb[i] = rb[i] / ra[i][i]; + for (j = i + 1; j < n; j++) rb[i] -= ra[i][j] * rb[j]; + } + break; + case CX: + for (i = n - 1; i >= 0; i--) { + if (modulus(ca[i][i]) != 0.0) cb[i] = cdiv(cb[i], ca[i][i]); + for (j = i + 1; j < n; j++) + cb[i] = csub(cb[i], cmul(ca[i][j], cb[j])); + } + break; + } +} diff --git a/lib/splines.c b/lib/splines.c new file mode 100644 index 0000000..2e63933 --- /dev/null +++ b/lib/splines.c @@ -0,0 +1,104 @@ +#include "xmath.h" + +/* natural cubic spline interpolation based on Numerical Recipes in C */ + +/* calculate second derivatives; assumes strictly increasing x values */ +static find_spline_derivs(x, y, n, y2, u) + double *x, *y, *y2, *u; + int n; +{ + int i, k; + double p, sig; + + y2[0] = u[0] = 0.0; /* lower boundary condition for natural spline */ + + /* decomposition loop for the tridiagonal algorithm */ + for (i = 1; i < n - 1; i++) { + y2[i] = u[i] = 0.0; /* set in case a zero test is failed */ + if (x[i - 1] < x[i] && x[i] < x[i + 1]) { + sig = (x[i] - x[i - 1]) / (x[i + 1] - x[i - 1]); + p = sig * y2[i - 1] + 2.0; + if (p != 0.0) { + y2[i] = (sig - 1.0) / p; + u[i] = (y[i + 1] - y[i]) / (x[i + 1] - x[i]) + - (y[i] - y[i - 1]) / (x[i] - x[i - 1]); + u[i] = (6.0 * u[i] / (x[i + 1] - x[i - 1]) - sig * u[i - 1]) / p; + } + } + } + + /* upper boundary condition for natural spline */ + y2[n - 1] = 0.0; + + /* backsubstitution loop of the tridiagonal algorithm */ + for (k = n - 2; k >= 0; k--) + y2[k] = y2[k] * y2[k + 1] + u[k]; +} + +/* interpolate or extrapolate value at x using results of find_spline_derivs */ +static spline_interp(xa, ya, y2a, n, x, y) + double *xa, *ya, *y2a, x, *y; + int n; +{ + int klo, khi, k; + double h, b, a; + + if (x <= xa[0]) { + h = xa[1] - xa[0]; + b = (h > 0.0) ? (ya[1] - ya[0]) / h - h * y2a[1] / 6.0 : 0.0; + *y = ya[0] + b * (x - xa[0]); + } + else if (x >= xa[n - 1]) { + h = xa[n - 1] - xa[n - 2]; + b = (h > 0.0) ? (ya[n - 1] - ya[n - 2]) / h + h * y2a[n - 2] / 6.0 : 0.0; + *y = ya[n - 1] + b * (x - xa[n - 1]); + } + else { + /* try a linear interpolation for equally spaced x values */ + k = (n - 1) * (x - xa[0]) / (xa[n - 1] - xa[0]); + + /* make sure the range is right */ + if (k < 0) k = 0; + if (k > n - 2) k = n - 2; + + /* bisect if necessary until the bracketing interval is found */ + klo = (x >= xa[k]) ? k : 0; + khi = (x < xa[k + 1]) ? k + 1 : n - 1; + while (khi - klo > 1) { + k = (khi + klo) / 2; + if (xa[k] > x) khi = k; + else klo = k; + } + + /* interpolate */ + h = xa[khi] - xa[klo]; + if (h > 0.0) { + a = (xa[khi] - x) / h; + b = (x - xa[klo]) / h; + *y = a * ya[klo] + b * ya[khi] + + ((a * a * a - a) * y2a[klo] + (b * b * b - b) * y2a[khi]) * (h * h) / 6.0; + } + else *y = (ya[klo] + ya[khi]) / 2.0; /* should not be needed */ + } +} + +fit_spline(n, x, y, ns, xs, ys, work) + int n, ns; + double *x, *y, *xs, *ys, *work; +{ + int i; + double *y2, *u; + + y2 = work; u = work + n; + + if (n < 2 || ns < 1) return (1); /* signal an error */ + for (i = 1; i < n; i++) + if (x[i - 1] >= x[i]) return(1); /* signal an error */ + + find_spline_derivs(x, y, n, y2, u); + + for (i = 0; i < ns; i++) + spline_interp(x, y, y2, n, xs[i], &ys[i]); + + return(0); +} diff --git a/lib/studentbase.c b/lib/studentbase.c new file mode 100644 index 0000000..8fe7e41 --- /dev/null +++ b/lib/studentbase.c @@ -0,0 +1,120 @@ +#include "xmath.h" + +#define TWOVRPI 0.636619772367581343 +#define HALF_PI 1.5707963268 +#define EPSILON .000001 + +extern double ppnd(), ppbeta(); + +/* CACM Algorithm 395, by G. W. Hill */ + +studentbase(x, df, cdf) + double *x, *df, *cdf; +{ + double t, y, b, a, z, j, n; + + n = *df; + z = 1.0; + t = (*x) * (*x); + y = t / n; + b = 1.0 + y; + + if (n > floor(n) || (n >= 20 && t < n) || (n > 20)) { + if (n < 2.0 && n != 1.0) { + /* beta integral aproximation for small df */ + double da = 0.5, db = 0.5 * n, dx, dp; + int ia = 0, ib = floor(db); + + dx = db / (db + da * t); + betabase(&dx, &db, &da, &ib, &ia, &dp); + *cdf = (*x >= 0) ? 1.0 - .5 * dp : .5 * dp; + } + else { + /* asymptotic series for large or non-integer df */ + if(y > EPSILON) y = log(b); + a = n - 0.5; + b = 48.0 * a * a; + y = a * y; + y = (((((-0.4 * y - 3.3) * y - 24.0) * y - 85.5) + / (0.8 * y * y + 100.0 + b) + y + 3.0) / b + 1.0) * sqrt(y); + + y = -1.0 * y; + normbase(&y, cdf); + if (*x > 0.0) *cdf = 1.0 - *cdf; + } + } + else { + /* nested summation of cosine series */ + if (n < 20 && t < 4.0) { + a = y = sqrt(y); + if(n == 1.0) a = 0.0; + } + else { + a = sqrt(b); + y = a * n; + for(j = 2; fabs(a - z) > EPSILON; j += 2.0) { + z = a; + y = (y * (j - 1)) / (b * j); + a = a + y / (n + j); + } + n += 2.0; + z = y = 0.0; + a = -a; + } + for(n = n - 2.0; n > 1.0; n -= 2.0) a = ((n - 1.0) / (b * n)) * a + y; + a = (fabs(n) < EPSILON) ? a/sqrt(b) : TWOVRPI * (atan(y) + a / b); + *cdf = z - a; + if(*x > 0.0) *cdf = 1.0 - 0.5 * *cdf; + else *cdf = 0.5 * *cdf; + } +} + +/* CACM Algorithm 396, by G. W. Hill */ + +double ppstudent(pp, n, ifault) + double pp, n; + int *ifault; +{ + double sq, p, a, b, c, d, x, y; + + /* convert to double upper tailed probability */ + p = (pp < 0.5) ? 2.0 * pp : 2.0 * (1.0 - pp); + + if (n <= 3.0) { + if (n == 1) sq = tan(HALF_PI * (1.0 - p)); + else if (n == 2.0) sq = sqrt(2.0 / (p * (2.0 - p)) - 2.0); + else { + sq = ppbeta(p, 0.5 * n, 0.5, ifault); + if (sq != 0.0) sq = sqrt((n / sq) - n); + } + } + else { + a = 1.0 / (n - 0.5); + b = 48.0 / (a * a); + c = ((20700.0 * a / b - 98.0) * a - 16) * a + 96.36; + d = ((94.5 / (b + c) - 3.0) / b + 1.0) * sqrt(a * HALF_PI) * n; + x = d * p; + y = pow(x, 2.0 / n); + if (y > 0.05 + a) { + /* asymptotic inverse expansion about normal */ + x = ppnd(0.5 * p, ifault); + y = x * x; + if (n < 5) c = c + 0.3 * (n - 4.5) * (x + 0.6); + c = (((0.05 * d * x - 5.0) * x - 7.0) * x - 2.0) * x + b + c; + y = (((((0.4 * y + 6.3) * y + 36.0) * y + 94.5) / c - y - 3.0) / b + + 1.0) * x; + y = a * y * y; + y = (y > .002) ? exp(y) - 1.0 : 0.5 * y * y + y; + } + else { + y = ((1.0 / (((n + 6.0) / (n * y) - 0.089 * d - 0.822) + * (n + 2.0) * 3.0) + 0.5 / (n + 4.0)) * y - 1.0) + * (n + 1.0) / (n + 2.0) + 1.0 / y; + } + sq = sqrt(n * y); + } + + /* decode based on tail */ + if (pp < 0.5) sq = -sq; + return(sq); +} diff --git a/lib/svdecomp.c b/lib/svdecomp.c new file mode 100644 index 0000000..b83f7ef --- /dev/null +++ b/lib/svdecomp.c @@ -0,0 +1,261 @@ +/* svdecomp - SVD decomposition routines. */ +/* Taken from Numerical Recipies. */ +/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */ +/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */ +/* You may give out copies of this software; for conditions see the */ +/* file COPYING included with this distribution. */ + +#include "linalg.h" + +static double PYTHAG(a, b) + double a, b; +{ + double at = fabs(a), bt = fabs(b), ct, result; + + if (at > bt) { ct = bt / at; result = at * sqrt(1.0 + ct * ct); } + else if (bt > 0.0) { ct = at / bt; result = bt * sqrt(1.0 + ct * ct); } + else result = 0.0; + return(result); +} + +#define SWAPD(a, b) (temp = (a), (a) = (b), (b) = temp) + +static sort_sv(m, n, k, a, w, v) + int m, n, k; + RMatrix a, v; + RVector w; +{ + int i, j; + double temp; + + for (i = k; (i < n - 1) && (w[i] < w[i+1]); i++) { + SWAPD(w[i], w[i+1]); + for (j = 0; j < m; j++) SWAPD(a[j][i], a[j][i+1]); + for (j = 0; j < n; j++) SWAPD(v[j][i], v[j][i+1]); + } +} + +static double maxarg1, maxarg2; +#define Max(a, b) (maxarg1 = (a), maxarg2 = (b), (maxarg1) > (maxarg2) ? (maxarg1) : (maxarg2)) +#define SIGN(a, b) ((b) >= 0.0 ? fabs(a) : -fabs(a)) + +svdcmp(a, m, n, w, v) + RMatrix a, v; + RVector w; + int m, n; +{ + int flag, i, its, j, jj, k, l, nm; + double c, f, h, s, x, y, z; + double anorm = 0.0, g = 0.0, scale = 0.0; + RVector rv1; + + if (m < n) return(FALSE); /* flag an error if m < n */ + + rv1 = rvector(n); + + /* Householder reduction to bidiagonal form */ + for (i = 0; i < n; i++) { + + /* left-hand reduction */ + l = i + 1; + rv1[i] = scale * g; + g = s = scale = 0.0; + if (i < m) { + for (k = i; k < m; k++) scale += fabs(a[k][i]); + if (scale) { + for (k = i; k < m; k++) { + a[k][i] /= scale; + s += a[k][i] * a[k][i]; + } + f = a[i][i]; + g = -SIGN(sqrt(s), f); + h = f * g - s; + a[i][i] = f - g; + if (i != n - 1) { + for (j = l; j < n; j++) { + for (s = 0.0, k = i; k < m; k++) s += a[k][i] * a[k][j]; + f = s / h; + for (k = i; k < m; k++) a[k][j] += f * a[k][i]; + } + } + for (k = i; k < m; k++) a[k][i] *= scale; + } + } + w[i] = scale * g; + + /* right-hand reduction */ + g = s = scale = 0.0; + if (i < m && i != n - 1) { + for (k = l; k < n; k++) scale += fabs(a[i][k]); + if (scale) { + for (k = l; k < n; k++) { + a[i][k] /= scale; + s += a[i][k] * a[i][k]; + } + f = a[i][l]; + g = -SIGN(sqrt(s), f); + h = f * g - s; + a[i][l] = f - g; + for (k = l; k < n; k++) rv1[k] = a[i][k] / h; + if (i != m - 1) { + for (j = l; j < m; j++) { + for (s = 0.0, k = l; k < n; k++) s += a[j][k] * a[i][k]; + for (k = l; k < n; k++) a[j][k] += s * rv1[k]; + } + } + for (k = l; k < n; k++) a[i][k] *= scale; + } + } + anorm = Max(anorm, (fabs(w[i]) + fabs(rv1[i]))); + } + + /* accumulate the right-hand transformation */ + for (i = n - 1; i >= 0; i--) { + if (i < n - 1) { + if (g) { + for (j = l; j < n; j++) + v[j][i] = (a[i][j] / a[i][l]) / g; + for (j = l; j < n; j++) { + for (s = 0.0, k = l; k < n; k++) s += a[i][k] * v[k][j]; + for (k = l; k < n; k++) v[k][j] += s * v[k][i]; + } + } + for (j = l; j < n; j++) v[i][j] = v[j][i] = 0.0; + } + v[i][i] = 1.0; + g = rv1[i]; + l = i; + } + + /* accumulate the left-hand transformation */ + for (i = n - 1; i >= 0; i--) { + l = i + 1; + g = w[i]; + if (i < n - 1) + for (j = l; j < n; j++) a[i][j] = 0.0; + if (g) { + g = 1.0 / g; + if (i != n - 1) { + for (j = l; j < n; j++) { + for (s = 0.0, k = l; k < m; k++) s += a[k][i] * a[k][j]; + f = (s / a[i][i]) * g; + for (k = i; k < m; k++) a[k][j] += f * a[k][i]; + } + } + for (j = i; j < m; j++) a[j][i] *= g; + } + else { + for (j = i; j < m; j++) a[j][i] = 0.0; + } + ++a[i][i]; + } + + /* diagonalize the bidiagonal form */ + for (k = n - 1; k >= 0; k--) { /* loop over singular values */ + for (its = 0; its < 30; its++) { /* loop over allowed iterations */ + flag = 1; + for (l = k; l >= 0; l--) { /* test for splitting */ + nm = l - 1; + if (fabs(rv1[l]) + anorm == anorm) { + flag = 0; + break; + } + if (fabs(w[nm]) + anorm == anorm) break; + } + if (flag) { + c = 0.0; + s = 1.0; + for (i = l; i <= k; i++) { + f = s * rv1[i]; + if (fabs(f) + anorm != anorm) { + g = w[i]; + h = PYTHAG(f, g); + w[i] = h; + if (h == 0.0) { + char s[100]; + sprintf(s, "h = %f, f = %f, g = %f\n", f, g); + stdputstr(s); + } + h = 1.0 / h; + c = g * h; + s = (- f * h); + for (j = 0; j < m; j++) { + y = a[j][nm]; + z = a[j][i]; + a[j][nm] = y * c + z * s; + a[j][i] = z * c - y * s; + } + } + } + } + z = w[k]; + if (l == k) { /* convergence */ + if (z < 0.0) { /* make singular value nonnegative */ + w[k] = -z; + for (j = 0; j < n; j++) v[j][k] = (-v[j][k]); + } + sort_sv(m, n, k, a, w, v); + break; + } + if (its >= 30) { + free_vector(rv1); + return(FALSE); /* return an error flag */ + } + + /* shift from bottom 2 x 2 minor */ + x = w[l]; + nm = k - 1; + y = w[nm]; + g = rv1[nm]; + h = rv1[k]; + f = ((y - z) * (y + z) + (g - h) * (g + h)) / (2.0 * h * y); + g = PYTHAG(f, 1.0); + f = ((x - z) * (x + z) + h * ((y / (f + SIGN(g, f))) - h)) / x; + + /* next QR transformation */ + c = s = 1.0; + for (j = l; j <= nm; j++) { + i = j + 1; + g = rv1[i]; + y = w[i]; + h = s * g; + g = c * g; + z = PYTHAG(f, h); + rv1[j] = z; + c = f / z; + s = h / z; + f = x * c + g * s; + g = g * c - x * s; + h = y * s; + y = y * c; + for (jj = 0; jj < n; jj++) { + x = v[jj][j]; + z = v[jj][i]; + v[jj][j] = x * c + z * s; + v[jj][i] = z * c - x * s; + } + z = PYTHAG(f, h); + w[j] = z; + if (z) { + z = 1.0 / z; + c = f * z; + s = h * z; + } + f = (c * g) + (s * y); + x = (c * y) - (s * g); + for (jj = 0; jj < m; jj++) { + y = a[jj][j]; + z = a[jj][i]; + a[jj][j] = y * c + z * s; + a[jj][i] = z * c - y * s; + } + } + rv1[l] = 0.0; + rv1[k] = f; + w[k] = x; + } + } + free_vector(rv1); + return(TRUE); +} + diff --git a/lib/xlisp.h b/lib/xlisp.h new file mode 100644 index 0000000..073648b --- /dev/null +++ b/lib/xlisp.h @@ -0,0 +1,9 @@ +#include + +#define FALSE 0 +#define TRUE 1 + +#ifndef IN_KCL_GLUE +typedef void *object; +typedef object LVAL; +#endif diff --git a/lib/xmath.h b/lib/xmath.h new file mode 100644 index 0000000..716e607 --- /dev/null +++ b/lib/xmath.h @@ -0,0 +1,5 @@ +#include + +#ifndef HUGE +#define HUGE 1e38 +#endif diff --git a/linalg.lsp b/linalg.lsp new file mode 100644 index 0000000..f57c6d5 --- /dev/null +++ b/linalg.lsp @@ -0,0 +1,1074 @@ +;;;; linalg -- Lisp-Stat interface to basic linear algebra routines. +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +(provide "linalg") + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(in-package lisp-stat-basics) +#-:CLtL2 +(in-package 'lisp-stat-basics) + +(export '(chol-decomp lu-decomp lu-solve determinant inverse sv-decomp + qr-decomp rcondest make-rotation spline kernel-dens kernel-smooth + fft make-sweep-matrix sweep-operator ax+y numgrad numhess + split-list eigen)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Lisp to C number conversion and checking +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; Lisp to/from C sequence and matrix conversion and checking +;;;; + +(defun is-cons (a) (if (consp a) 1 0)) + +(defun check-fixnum (a) + (if (/= 0 (la-data-mode a)) (error "not an integer sequence - ~s" a))) + +(defun check-real (data) + (let ((data (compound-data-seq data))) + (cond + ((vectorp data) + (let ((n (length data))) + (declare (fixnum n)) + (dotimes (i n) + (declare (fixnum i)) + (check-one-real (aref data i))))) + ((consp data) (dolist (x data) (check-one-real x))) + (t (error "bad sequence - ~s" data))))) + +(defun vec-assign (a i x) (setf (aref a i) x)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Lisp Interfaces to Linear Algebra Routines +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; Cholesky Decomposition +;;;; + +(defun chol-decomp (a &optional (maxoffl 0.0)) +"Args: (a) +Modified Cholesky decomposition. A should be a square, symmetric matrix. +Computes lower triangular matrix L such that L L^T = A + D where D is a +diagonal matrix. If A is strictly positive definite D will be zero. +Otherwise, D is as small as possible to make A + D numerically strictly +positive definite. Returns a list (L (max D))." + (check-square-matrix a) + (check-real a) + (let* ((n (array-dimension a 0)) + (result (make-array (list n n))) + (dpars (list maxoffl 0.0))) + (check-real dpars) + (let ((mat (la-data-to-matrix a mode-re)) + (dp (la-data-to-vector dpars mode-re))) + (unwind-protect + (progn + (chol-decomp-front mat n dp) + (la-matrix-to-data mat n n mode-re result) + (la-vector-to-data dp 2 mode-re dpars)) + (la-free-matrix mat n) + (la-free-vector dp))) + (list result (second dpars)))) + +;;;; +;;;; LU Decomposition +;;;; + +(defun lu-decomp (a) +"Args: (a) +A is a square matrix of numbers (real or complex). Computes the LU +decomposition of A and returns a list of the form (LU IV D FLAG), where +LU is a matrix with the L part in the lower triangle, the U part in the +upper triangle (the diagonal entries of L are taken to be 1), IV is a vector +describing the row permutation used, D is 1 if the number of permutations +is odd, -1 if even, and FLAG is T if A is numerically singular, NIL otherwise. +Used bu LU-SOLVE." + (check-square-matrix a) + (let* ((n (array-dimension a 0)) + (mode (max mode-re (la-data-mode a))) + (result (list (make-array (list n n)) (make-array n) nil nil))) + (let ((mat (la-data-to-matrix a mode)) + (iv (la-vector n mode-in)) + (d (la-vector 1 mode-re)) + (singular 0)) + (unwind-protect + (progn + (setf singular (lu-decomp-front mat n iv mode d)) + (la-matrix-to-data mat n n mode (first result)) + (la-vector-to-data iv n mode-in (second result)) + (setf (third result) (la-get-double d 0)) + (setf (fourth result) (if (= singular 0) nil t))) + (la-free-matrix mat n) + (la-free-vector iv) + (la-free-vector d))) + result)) + +(defun lu-solve (lu lb) +"Args: (lu b) +LU is the result of (LU-DECOMP A) for a square matrix A, B is a sequence. +Returns the solution to the equation Ax = B. Signals an error if A is +singular." + (let ((la (first lu)) + (lidx (second lu))) + (check-square-matrix la) + (check-sequence lidx) + (check-sequence lb) + (check-fixnum lidx) + (let* ((n (num-rows la)) + (result (make-sequence (if (consp lb) 'list 'vector) n)) + (a-mode (la-data-mode la)) + (b-mode (la-data-mode lb))) + (if (/= n (length lidx)) (error "index sequence is wrong length")) + (if (/= n (length lb)) (error "right hand side is wrong length")) + (let* ((mode (max mode-re a-mode b-mode)) + (a (la-data-to-matrix la mode)) + (indx (la-data-to-vector lidx mode-in)) + (b (la-data-to-vector lb mode)) + (singular 0)) + (unwind-protect + (progn + (setf singular (lu-solve-front a n indx b mode)) + (la-vector-to-data b n mode result)) + (la-free-matrix a n) + (la-free-vector indx) + (la-free-vector b)) + (if (/= 0 singular) (error "matrix is (numerically) singular")) + result)))) + +(defun determinant (a) +"Args: (m) +Returns the determinant of the square matrix M." + (let* ((lu (lu-decomp a)) + (la (first lu)) + (n (num-rows a)) + (d1 (third lu)) + (d2 0.d0)) + (declare (fixnum n)) + (flet ((fabs (x) (float (abs x) 0.d0))) + (dotimes (i n (* d1 (exp d2))) + (declare (fixnum i)) + (let* ((x (aref la i i)) + (magn (fabs x))) + (if (= 0.0 magn) (return 0.d0)) + (setf d1 (* d1 (/ x magn))) + (setf d2 (+ d2 (log magn)))))))) + +(defun inverse (a) +"Args: (m) +Returns the inverse of the the square matrix M; signals an error if M is ill +conditioned or singular" + (check-square-matrix a) + (let ((n (num-rows a)) + (mode (max mode-re (la-data-mode a)))) + (declare (fixnum n)) + (let ((result (make-array (list n n) :initial-element 0))) + (dotimes (i n) + (declare (fixnum i)) + (setf (aref result i i) 1)) + (let ((mat (la-data-to-matrix a mode)) + (inv (la-data-to-matrix result mode)) + (iv (la-vector n mode-in)) + (v (la-vector n mode)) + (singular 0)) + (unwind-protect + (progn + (setf singular (lu-inverse-front mat n iv v mode inv)) + (la-matrix-to-data inv n n mode result)) + (la-free-matrix mat n) + (la-free-matrix inv n) + (la-free-vector iv) + (la-free-vector v)) + (if (/= singular 0) (error "matrix is (numerically) singular")) + result)))) + +;;;; +;;;; SV Decomposition +;;;; + +(defun sv-decomp (a) +"Args: (a) +A is a matrix of real numbers with at least as many rows as columns. +Computes the singular value decomposition of A and returns a list of the form +(U W V FLAG) where U and V are matrices whose columns are the left and right +singular vectors of A and W is the sequence of singular values of A. FLAG is T +if the algorithm converged, NIL otherwise." + (check-matrix a) + (let* ((m (num-rows a)) + (n (num-cols a)) + (mode (max mode-re (la-data-mode a))) + (result (list (make-array (list m n)) + (make-array n) + (make-array (list n n)) + nil))) + (if (< m n) (error "number of rows less than number of columns")) + (if (= mode mode-cx) (error "complex SVD not available yet")) + (let ((mat (la-data-to-matrix a mode)) + (w (la-vector n mode-re)) + (v (la-matrix n n mode-re)) + (converged 0)) + (unwind-protect + (progn + (setf converged (sv-decomp-front mat m n w v)) + (la-matrix-to-data mat m n mode (first result)) + (la-vector-to-data w n mode (second result)) + (la-matrix-to-data v n n mode (third result)) + (setf (fourth result) (if (/= 0 converged) t nil))) + (la-free-matrix mat m) + (la-free-vector w) + (la-free-matrix v n)) + result))) + + +;;;; +;;;; QR Decomposition +;;;; + +(defun qr-decomp (a &optional pivot) +"Args: (a &optional pivot) +A is a matrix of real numbers with at least as many rows as columns. Computes +the QR factorization of A and returns the result in a list of the form (Q R). +If PIVOT is true the columns of X are first permuted to place insure the +absolute values of the diagonal elements of R are nonincreasing. In this case +the result includes a third element, a list of the indices of the columns in +the order in which they were used." + (check-matrix a) + (let* ((m (num-rows a)) + (n (num-cols a)) + (mode (max mode-re (la-data-mode a))) + (p (if pivot 1 0)) + (result (if pivot + (list (make-array (list m n)) + (make-array (list n n)) + (make-array n)) + (list (make-array (list m n)) (make-array (list n n)))))) + (if (< m n) (error "number of rows less than number of columns")) + (if (= mode mode-cx) (error "complex QR decomposition not available yet")) + (let ((mat (la-data-to-matrix a mode)) + (v (la-matrix n n mode-re)) + (jpvt (la-vector n mode-in))) + (unwind-protect + (progn + (qr-decomp-front mat m n v jpvt p) + (la-matrix-to-data mat m n mode (first result)) + (la-matrix-to-data v n n mode (second result)) + (if pivot (la-vector-to-data jpvt n mode-in (third result)))) + (la-free-matrix mat m) + (la-free-matrix v n) + (la-free-vector jpvt)) + result))) + +;;;; +;;;; Estimate of Condition Number for Lower Triangular Matrix +;;;; + +(defun rcondest (a) +"Args: (a) +Returns an estimate of the reciprocal of the L1 condition number of an upper +triangular matrix a." + (check-square-matrix a) + (let ((mode (max mode-re (la-data-mode a))) + (n (num-rows a))) + (if (= mode mode-cx) + (error "complex condition estimate not available yet")) + (let ((mat (la-data-to-matrix a mode)) + (est 0.0)) + (unwind-protect + (setf est (rcondest-front mat n)) + (la-free-matrix mat n)) + est))) + +;;;; +;;;; Make Rotation Matrix +;;;; + +(defun make-rotation (x y &optional alpha) +"Args: (x y &optional alpha) +Returns a rotation matrix for rotating from X to Y, or from X toward Y +by angle ALPHA, in radians. X and Y are sequences of the same length." + (check-sequence x) + (check-sequence y) + (if alpha (check-one-real alpha)) + (let* ((n (length x)) + (mode (max mode-re (la-data-mode x) (la-data-mode y))) + (use-angle (if alpha 1 0)) + (angle (if alpha (float alpha 0.0) 0.0)) + (result (make-array (list n n)))) + (if (/= n (length y)) (error "sequences not the same length")) + (if (= mode mode-cx) (error "complex data not supported yet")) + (let ((px (la-data-to-vector x mode-re)) + (py (la-data-to-vector y mode-re)) + (rot (la-matrix n n mode-re))) + (unwind-protect + (progn + (make-rotation-front n rot px py use-angle angle) + (la-matrix-to-data rot n n mode-re result)) + (la-free-vector px) + (la-free-vector py) + (la-free-matrix rot n)) + result))) + +;;;; +;;;; Eigenvalues and Vectors +;;;; + +(defun eigen (a) +"Args: (a) +Returns list of list of eigenvalues and list of eigenvectors of square, +symmetric matrix A. Third element of result is NIL if algorithm converges. +If the algorithm does not converge, the third element is an integer I. +In this case the eigenvalues 0, ..., I are not reliable." + (check-square-matrix a) + (let ((mode (max mode-re (la-data-mode a))) + (n (num-rows a))) + (if (= mode mode-cx) (error "matrix must be real and symmetric")) + (let ((evals (make-array n)) + (evecs (make-list (* n n))) + (pa (la-data-to-vector (compound-data-seq a) mode-re)) + (w (la-vector n mode-re)) + (z (la-vector (* n n) mode-re)) + (fv1 (la-vector n mode-re)) + (ierr 0)) + (unwind-protect + (progn + (setf ierr (eigen-front pa n w z fv1)) + (la-vector-to-data w n mode-re evals) + (la-vector-to-data z (* n n) mode-re evecs)) + (la-free-vector pa) + (la-free-vector z) + (la-free-vector w) + (la-free-vector fv1)) + (list (nreverse evals) + (nreverse (mapcar #'(lambda (x) (coerce x 'vector)) + (split-list evecs n))) + (if (/= 0 ierr) (- n ierr)))))) + +;;;; +;;;; Spline Interpolation +;;;; + +(defun make-smoother-args (x y xvals) + (check-sequence x) + (check-real x) + (when y + (check-sequence y) + (check-real y)) + (unless (integerp xvals) + (check-sequence xvals) + (check-real xvals)) + (let* ((n (length x)) + (ns (if (integerp xvals) xvals (length xvals))) + (result (list (make-list ns) (make-list ns)))) + (if (and y (/= n (length y))) (error "sequences not the same length")) + (list x y n (if (integerp xvals) 0 1) ns xvals result))) + +(defun get-smoother-result (args) (seventh args)) + +(defmacro with-smoother-data ((x y xvals is-reg) &rest body) + `(progn + (check-sequence ,x) + (check-real ,x) + (when ,is-reg + (check-sequence ,y) + (check-real ,y)) + (unless (integerp ,xvals) + (check-sequence ,xvals) + (check-real ,xvals)) + (let* ((supplied (not (integerp ,xvals))) + (n (length ,x)) + (ns (if supplied (length ,xvals) ,xvals)) + (result (list (make-list ns) (make-list ns)))) + (if (and ,is-reg (/= n (length ,y))) + (error "sequences not the same length")) + (if (and (not supplied) (< ns 2)) + (error "too few points for interpolation")) + (let* ((px (la-data-to-vector ,x mode-re)) + (py (if ,is-reg (la-data-to-vector ,y mode-re))) + (pxs (if supplied + (la-data-to-vector ,xvals mode-re) + (la-vector ns mode-re))) + (pys (la-vector ns mode-re))) + (unless supplied (la-range-to-rseq n px ns pxs)) + (unwind-protect + (progn ,@body + (la-vector-to-data pxs ns mode-re (first result)) + (la-vector-to-data pys ns mode-re (second result))) + (la-free-vector px) + (if ,is-reg (la-free-vector py)) + (la-free-vector pxs) + (la-free-vector pys)) + result)))) + +(defun spline (x y &key (xvals 30)) +"Args: (x y &key xvals) +Returns list of x and y values of natural cubic spline interpolation of (X,Y). +X must be strictly increasing. XVALS can be an integer, the number of equally +spaced points to use in the range of X, or it can be a sequence of points at +which to interpolate." + (with-smoother-data (x y xvals t) + (let ((work (la-vector (* 2 n) mode-re)) + (error 0)) + (unwind-protect + (setf error (spline-front n px py ns pxs pys work)) + (la-free-vector work)) + (if (/= error 0) (error "bad data for splines"))))) + +;;;; +;;;; Kernel Density Estimators and Smoothers +;;;; + +(defun kernel-type-code (type) + (cond ((eq type 'u) 0) + ((eq type 't) 1) + ((eq type 'g) 2) + (t 3))) + +(defun kernel-dens (x &key (type 'b) (width -1.0) (xvals 30)) +"Args: (x &key xvals width type) +Returns list of x and y values of kernel density estimate of X. XVALS can be an +integer, the number of equally spaced points to use in the range of X, or it +can be a sequence of points at which to interpolate. WIDTH specifies the +window width. TYPE specifies the lernel and should be one of the symbols G, T, +U or B for gaussian, triangular, uniform or bisquare. The default is B." + (check-one-real width) + (with-smoother-data (x nil xvals nil) + (let ((code (kernel-type-code type)) + (error 0)) + (setf error (kernel-dens-front px n width pxs pys ns code)) + (if (/= 0 error) (error "bad kernel density data"))))) + +(defun kernel-smooth (x y &key (type 'b) (width -1.0) (xvals 30)) +"Args: (x y &key xvals width type) +Returns list of x and y values of kernel smooth of (X,Y). XVALS can be an +integer, the number of equally spaced points to use in the range of X, or it +can be a sequence of points at which to interpolate. WIDTH specifies the +window width. TYPE specifies the lernel and should be one of the symbols G, T, +U or B for Gaussian, triangular, uniform or bisquare. The default is B." + (check-one-real width) + (with-smoother-data (x y xvals t) + (let ((code (kernel-type-code type)) + (error 0)) + (kernel-smooth-front px py n width pxs pys ns code) + (if (/= 0 error) (error "bad kernel density data"))))) + +;;;; +;;;; Lowess Smoother Interface +;;;; + +(defun |base-lowess| (s1 s2 f nsteps delta) + (check-sequence s1) + (check-sequence s2) + (check-real s1) + (check-real s2) + (check-one-real f) + (check-one-fixnum nsteps) + (check-one-real delta) + (let* ((n (length s1)) + (result (make-list n))) + (if (/= n (length s2)) (error "sequences not the same length")) + (let ((x (la-data-to-vector s1 mode-re)) + (y (la-data-to-vector s2 mode-re)) + (ys (la-vector n mode-re)) + (rw (la-vector n mode-re)) + (res (la-vector n mode-re)) + (error 0)) + (unwind-protect + (progn + (setf error (base-lowess-front x y n f nsteps delta ys rw res)) + (la-vector-to-data ys n mode-re result)) + (la-free-vector x) + (la-free-vector y) + (la-free-vector ys) + (la-free-vector rw) + (la-free-vector res)) + (if (/= error 0) (error "bad data for lowess")) + result))) + +#| +static LVAL add_contour_point(i, j, k, l, x, y, z, v, result) + int i, j, k, l; + RVector x, y; + RMatrix z; + double v; + LVAL result; +{ + LVAL pt; + double p, q; + + if ((z[i][j] <= v && v < z[k][l]) || (z[k][l] <= v && v < z[i][j])) { + xlsave(pt); + pt = mklist(2, NIL); + p = (v - z[i][j]) / (z[k][l] - z[i][j]); + q = 1.0 - p; + rplaca(pt, cvflonum((FLOTYPE) (q * x[i] + p * x[k]))); + rplaca(cdr(pt), cvflonum((FLOTYPE) (q * y[j] + p * y[l]))); + result = cons(pt, result); + xlpop(); + } + return(result); +} + +LVAL xssurface_contour() +{ + LVAL s1, s2, mat, result; + RVector x, y; + RMatrix z; + double v; + int i, j, n, m; + + s1 = xsgetsequence(); + s2 = xsgetsequence(); + mat = xsgetmatrix(); + v = makedouble(xlgetarg()); + xllastarg(); + + n = seqlen(s1); m = seqlen(s2); + if (n != numrows(mat) || m != numcols(mat)) xlfail("dimensions do not match"); + if (data_mode(s1) == CX || data_mode(s2) == CX || data_mode(mat) == CX) + xlfail("data must be real"); + + x = (RVector) data_to_vector(s1, RE); + y = (RVector) data_to_vector(s2, RE); + z = (RMatrix) data_to_matrix(mat, RE); + + xlsave1(result); + result = NIL; + for (i = 0; i < n - 1; i++) { + for (j = 0; j < m - 1; j++) { + result = add_contour_point(i, j, i, j+1, x, y, z, v, result); + result = add_contour_point(i, j+1, i+1, j+1, x, y, z, v, result); + result = add_contour_point(i+1, j+1, i+1, j, x, y, z, v, result); + result = add_contour_point(i+1, j, i, j, x, y, z, v, result); + } + } + xlpop(); + + free_vector(x); + free_vector(y); + free_matrix(z, n); + + return(result); +} +|# + +;;;; +;;;; FFT +;;;; + +(defun fft (x &optional inverse) +"Args: (x &optional inverse) +Returns unnormalized Fourier transform of X, or inverse transform if INVERSE +is true." + (check-sequence x) + (let* ((n (length x)) + (mode (la-data-mode x)) + (isign (if inverse -1 1)) + (result (if (consp x) (make-list n) (make-array n)))) + (let ((px (la-data-to-vector x mode-cx)) + (work (la-vector (+ (* 4 n) 15) mode-re))) + (unwind-protect + (progn + (fft-front n px work isign) + (la-vector-to-data px n mode-cx result)) + (la-free-vector px) + (la-free-vector work)) + result))) + +;;;; +;;;; SWEEP Operator +;;;; + +(defun make-sweep-front (x y w n p mode has_w x_mean result) + (declare (fixnum n p mode has_w)) + (let ((x_data nil) + (result_data nil) + (val 0.0) + (dxi 0.0) + (dyi 0.0) + (dv 0.0) + (dw 0.0) + (sum_w 0.0) + (dxik 0.0) + (dxjk 0.0) + (dyj 0.0) + (dx_meani 0.0) + (dx_meanj 0.0) + (dy_mean 0.0) + (has-w (if (/= 0 has_w) t nil)) + (RE 1)) + (declare-double val dxi dyi dv dw sum_w dxik dxjk dyj + dx_meani dx_meanj dy_mean) + + (if (> mode RE) (error "not supported for complex data yet")) + + (setf x_data (compound-data-seq x)) + (setf result_data (compound-data-seq result)) + + ;; find the mean of y + (setf val 0.0) + (setf sum_w 0.0) + (dotimes (i n) + (declare (fixnum i)) + (setf dyi (makedouble (aref y i))) + (when has-w + (setf dw (makedouble (aref w i))) + (incf sum_w dw) + (setf dyi (* dyi dw))) + (incf val dyi)) + (if (not has-w) (setf sum_w (float n 0.0))) + (if (<= sum_w 0.0) (error "non positive sum of weights")) + (setf dy_mean (/ val sum_w)) + + ;; find the column means + (dotimes (j p) + (declare (fixnum j)) + (setf val 0.0) + (dotimes (i n) + (declare (fixnum i)) + (setf dxi (makedouble (aref x_data (+ (* p i) j)))) + (when has-w + (setf dw (makedouble (aref w i))) + (setf dxi (* dxi dw))) + (incf val dxi)) + (setf (aref x_mean j) (/ val sum_w))) + + ;; put 1/sum_w in topleft, means on left, minus means on top + (setf (aref result_data 0) (/ 1.0 sum_w)) + (dotimes (i p) + (declare (fixnum i)) + (setf dxi (makedouble (aref x_mean i))) + (setf (aref result_data (+ i 1)) (- dxi)) + (setf (aref result_data (* (+ i 1) (+ p 2))) dxi)) + (setf (aref result_data (+ p 1)) (- dy_mean)) + (setf (aref result_data (* (+ p 1) (+ p 2))) dy_mean) + + ;; put sums of adjusted cross products in body + (dotimes (i p) + (declare (fixnum i)) + (dotimes (j p) + (declare (fixnum j)) + (setf val 0.0) + (dotimes (k n) + (declare (fixnum k)) + (setf dxik (makedouble (aref x_data (+ (* p k) i)))) + (setf dxjk (makedouble (aref x_data (+ (* p k) j)))) + (setf dx_meani (makedouble (aref x_mean i))) + (setf dx_meanj (makedouble (aref x_mean j))) + (setf dv (* (- dxik dx_meani) (- dxjk dx_meanj))) + (when has-w + (setf dw (makedouble (aref w k))) + (setf dv (* dv dw))) + (incf val dv)) + (setf (aref result_data (+ (* (+ i 1) (+ p 2)) (+ j 1))) val) + (setf (aref result_data (+ (* (+ j 1) (+ p 2)) (+ i 1))) val)) + (setf val 0.0) + (dotimes (j n) + (declare (fixnum j)) + (setf dxik (makedouble (aref x_data (+ (* p j) i)))) + (setf dyj (makedouble (aref y j))) + (setf dx_meani (makedouble (aref x_mean i))) + (setf dv (* (- dxik dx_meani) (- dyj dy_mean))) + (when has-w + (setf dw (makedouble (aref w j))) + (setf dv (* dv dw))) + (incf val dv)) + (setf (aref result_data (+ (* (+ i 1) (+ p 2)) (+ p 1))) val) + (setf (aref result_data (+ (* (+ p 1) (+ p 2)) (+ i 1))) val)) + (setf val 0.0) + (dotimes (j n) + (declare (fixnum j)) + (setf dyj (makedouble (aref y j))) + (setf dv (* (- dyj dy_mean) (- dyj dy_mean))) + (when has-w + (setf dw (makedouble (aref w j))) + (setf dv (* dv dw))) + (incf val dv)) + (setf (aref result_data (+ (* (+ p 1) (+ p 2)) (+ p 1))) val))) + +(defun sweep-in-place-front (a rows cols mode k tol) + (declare-double tol) + (declare (fixnum rows cols mode k)) + (let ((data nil) + (pivot 0.0) + (aij 0.0) + (aik 0.0) + (akj 0.0) + (akk 0.0) + (RE 1)) + (declare-double pivot aij aik akj akk) + + (if (> mode RE) (error "not supported for complex data yet")) + (if (or (< k 0) (>= k rows) (>= k cols)) (error "index out of range")) + + (setf tol (max tol machine-epsilon)) + (setf data (compound-data-seq a)) + + (setf pivot (makedouble (aref data (+ (* cols k) k)))) + + (cond + ((or (> pivot tol) (< pivot (- tol))) + (dotimes (i rows) + (declare (fixnum i)) + (dotimes (j cols) + (declare (fixnum j)) + (when (and (/= i k) (/= j k)) + (setf aij (makedouble (aref data (+ (* cols i) j)))) + (setf aik (makedouble (aref data (+ (* cols i) k)))) + (setf akj (makedouble (aref data (+ (* cols k) j)))) + (setf aij (- aij (/ (* aik akj) pivot))) + (setf (aref data (+ (* cols i) j)) aij)))) + + (dotimes (i rows) + (declare (fixnum i)) + (setf aik (makedouble (aref data (+ (* cols i) k)))) + (when (/= i k) + (setf aik (/ aik pivot)) + (setf (aref data (+ (* cols i) k)) aik))) + + (dotimes (j cols) + (declare (fixnum j)) + (setf akj (makedouble (aref data (+ (* cols k) j)))) + (when (/= j k) + (setf akj (- (/ akj pivot))) + (setf (aref data (+ (* cols k) j)) akj))) + + (setf akk (/ 1.0 pivot)) + (setf (aref data (+ (* cols k) k)) akk) + 1) + (t 0)))) + +(defun make-sweep-matrix (x y &optional w) +"Args: (x y &optional weights) +X is a matrix, Y and WEIGHTS are sequences. Returns the sweep matrix for the +(possibly weighted) regression of Y on X." + (check-matrix x) + (check-sequence y) + (if w (check-sequence w)) + (let ((n (num-rows x)) + (p (num-cols x))) + (if (/= n (length y)) (error "dimensions do not match")) + (if (and w (/= n (length w))) (error "dimensions do not match")) + (let ((mode (max (la-data-mode x) + (la-data-mode x) + (if w (la-data-mode w) 0))) + (result (make-array (list (+ p 2) (+ p 2)))) + (x-mean (make-array p)) + (y (coerce y 'vector)) + (w (if w (coerce w 'vector))) + (has-w (if w 1 0))) + (make-sweep-front x y w n p mode has-w x-mean result) + result))) + +(defun sweep-in-place (a k tol) + (check-matrix a) + (check-one-fixnum k) + (check-one-real tol) + (let ((rows (num-rows a)) + (cols (num-cols a)) + (mode (la-data-mode a))) + (let ((swept (sweep-in-place-front a rows cols mode k tol))) + (if (/= 0 swept) t nil)))) + +(defun sweep-operator (a columns &optional tolerances) +"Args: (a indices &optional tolerances) +A is a matrix, INDICES a sequence of the column indices to be swept. Returns +a list of the swept result and the list of the columns actually swept. (See +MULTREG documentation.) If supplied, TOLERANCES should be a list of real +numbers the same length as INDICES. An index will only be swept if its pivot +element is larger than the corresponding element of TOLERANCES." + (check-matrix a) + (check-sequence columns) + (if tolerances (check-sequence tolerances)) + (check-real a) + (check-fixnum columns) + (if tolerances (check-real tolerances)) + (do ((tol .0000001) + (result (copy-array a)) + (swept-columns nil) + (columns (coerce columns 'list) (cdr columns)) + (tolerances (if (consp tolerances) (coerce tolerances 'list)) + (if (consp tolerances) (cdr tolerances)))) + ((null columns) (list result swept-columns)) + (let ((col (first columns)) + (tol (if (consp tolerances) (first tolerances) tol))) + (if (sweep-in-place result col tol) + (setf swept-columns (cons col swept-columns)))))) + + +;;;; +;;;; AX+Y +;;;; + +;;;*** this could probably be made more efficient *** +(defun ax+y (a x y &optional lower) +"Args (a x y &optional lower) +Returns (+ (matmult A X) Y). If LOWER is not nil, A is taken to be lower +triangular." + (check-square-matrix a) + (check-sequence x) + (check-sequence y) + (check-real a) + (check-real x) + (check-real y) + (let* ((n (num-rows a)) + (result (make-list n)) + (a (compound-data-seq a))) + (declare (fixnum n)) + (if (or (/= n (length x)) (/= n (length y))) + (error "dimensions do not match")) + (do* ((tx (make-next-element x) (make-next-element x)) + (ty (make-next-element y)) + (tr (make-next-element result)) + (i 0 (+ i 1)) + (start 0 (+ start n)) + (end (if lower (+ i 1) n) (if lower (+ i 1) n))) + ((<= n i) result) + (declare (fixnum i start end)) + (let ((val (get-next-element ty i))) + (dotimes (j end) + (declare (fixnum j)) + (setf val (+ val (* (get-next-element tx j) + (aref a (+ start j)))))) + (set-next-element tr i val))))) + +;;;; +;;;; Maximization and Numerical Derivatives +;;;; + +(defvar *maximize-callback-function* nil) +(defvar *maximize-callback-arg* nil) + +(defun data2double (n data ptr) + (declare (fixnum n)) + (let* ((seq (compound-data-seq data)) + (elem (make-next-element seq))) + (if (/= (length seq) n) (error "bad data size")) + (dotimes (i n) + (declare (fixnum i)) + (la-put-double ptr i (get-next-element elem i))))) + +(defun maximize-callback (n px pfval pgrad phess pderivs) + (la-vector-to-data px n mode-re *maximize-callback-arg*) + (let* ((val (funcall *maximize-callback-function* *maximize-callback-arg*)) + (derivs (if (consp val) (- (length val) 1) 0))) + (la-put-integer pderivs 0 derivs) + (la-put-double pfval 0 (if (consp val) (first val) val)) + (if (<= 1 derivs) (data2double n (second val) pgrad)) + (if (<= 2 derivs) (data2double (* n n) (third val) phess)))) + +(defun numgrad (f x &optional scale (h -1.0)) +"Args: (f x &optional scale derivstep) +Computes the numerical gradient of F at X." + (check-sequence x) + (check-real x) + (when scale + (check-sequence scale) + (check-real scale)) + (check-one-real h) + (let* ((n (length x)) + (result (make-list n))) + (if (and scale (/= n (length scale))) + (error "scale not the same length as x")) + (let ((*maximize-callback-function* f) + (*maximize-callback-arg* (make-list n))) + (let ((px (la-data-to-vector x mode-re)) + (pgrad (la-vector n mode-re)) + (pscale (la-data-to-vector + (if scale scale (make-list n :initial-element 1.0)) + mode-re))) + (unwind-protect + (progn + (numgrad-front n px pgrad h pscale) + (la-vector-to-data pgrad n mode-re result)) + (la-free-vector px) + (la-free-vector pgrad) + (la-free-vector pscale)))) + result)) + +(defun numhess (f x &optional scale (h -1.0) all) +"Args: (f x &optional scale derivstep) +Computes the numerical Hessian matrix of F at X." + (check-sequence x) + (check-real x) + (when scale + (check-sequence scale) + (check-real scale)) + (check-one-real h) + (let* ((n (length x)) + (result (if all + (list nil (make-list n) (make-array (list n n))) + (make-array (list n n))))) + (if (and scale (/= n (length scale))) + (error "scale not the same length as x")) + (let ((*maximize-callback-function* f) + (*maximize-callback-arg* (make-list n))) + (let ((hess-data (compound-data-seq (if all (third result) result))) + (px (la-data-to-vector x mode-re)) + (pf (la-vector 1 mode-re)) + (pgrad (la-vector n mode-re)) + (phess (la-vector (* n n) mode-re)) + (pscale (la-data-to-vector + (if scale scale (make-list n :initial-element 1.0)) + mode-re))) + (unwind-protect + (progn + (numhess-front n px pf pgrad phess h pscale) + (when all + (setf (first result) (la-get-double pf 0)) + (la-vector-to-data pgrad n mode-re (second result))) + (la-vector-to-data phess (* n n) mode-re hess-data)) + (la-free-vector pf) + (la-free-vector px) + (la-free-vector pgrad) + (la-free-vector phess) + (la-free-vector pscale)))) + result)) + +(defun init-minfo-ipar-values (n ipars) + (let* ((TRUE 1) + (FALSE 0) + (k 0) + (m 0) + (itnlimit -1) + (backtrack TRUE) + (verbose 0) + (vals_suppl FALSE) + (exptilt TRUE) + (count 0) + (termcode 0)) + (setf (aref ipars 0) n) + (setf (aref ipars 1) m) + (setf (aref ipars 2) k) + (setf (aref ipars 3) itnlimit) + (setf (aref ipars 4) backtrack) + (setf (aref ipars 5) verbose) + (setf (aref ipars 6) vals_suppl) + (setf (aref ipars 7) exptilt) + (setf (aref ipars 8) count) + (setf (aref ipars 9) termcode))) + +(defun init-minfo-dpar-values (h dpars) + (let ((typf 1.0) + (gradtol -1.0) + (steptol -1.0) + (maxstep -1.0) + (dflt 0.0) + (tilt 0.0) + (newtilt 0.0) + (hessadd 0.0)) + (setf (aref dpars 0) typf) + (setf (aref dpars 1) h) + (setf (aref dpars 2) gradtol) + (setf (aref dpars 3) steptol) + (setf (aref dpars 4) maxstep) + (setf (aref dpars 5) dflt) + (setf (aref dpars 6) tilt) + (setf (aref dpars 7) newtilt) + (setf (aref dpars 8) hessadd))) + +(defun init-minfo-internals (n h internals) + (let ((ipars (aref internals 8)) + (dpars (aref internals 9))) + (init-minfo-ipar-values n ipars) + (init-minfo-dpar-values h dpars))) + +(defun new-minfo-internals (f x &key scale ((:derivstep h) -1.0)) + (check-sequence x) + (check-real x) + (check-one-real h) + (let ((n (length x))) + (when scale + (check-sequence scale) + (check-real scale) + (if (/= n (length scale)) (error "scale and x not the same length"))) + (let ((internals (make-array 12))) + (setf (aref internals 0) f) + (setf (aref internals 3) (if (consp x) (copy-list x) (coerce x 'list))) + (setf (aref internals 4) + (if scale (copy-seq scale) (make-array n :initial-element 1.0))) + (setf (aref internals 5) (make-list (+ 1 n (* n n)))) + (setf (aref internals 8) (make-array 10)) + (setf (aref internals 9) (make-array 9)) + (init-minfo-internals n h internals) + internals))) + +(defun minfo-maximize (internals &optional verbose) + (let* ((f (aref internals 0)) + (x (aref internals 3)) + (fvals (aref internals 5)) + (n (length x)) + (v (if verbose (if (integerp verbose) verbose 1) -1))) + (setf (aref internals 3) (copy-list x)) + (setf (aref internals 5) (copy-list fvals)) + (let ((*maximize-callback-function* f) + (*maximize-callback-arg* (make-list n))) + (let* ((x (aref internals 3)) + (scale (aref internals 4)) + (fvals (aref internals 5)) + (ip (aref internals 8)) + (dp (aref internals 9)) + (px (la-data-to-vector x mode-re)) + (pscale (la-data-to-vector scale mode-re)) + (pfvals (la-vector (length fvals) mode-re)) + (pip (la-data-to-vector ip mode-in)) + (pdp (la-data-to-vector dp mode-re))) + (unwind-protect + (progn + (base-minfo-maximize px pfvals pscale pip pdp v)) + (la-vector-to-data px n mode-re x) + (la-vector-to-data pfvals (+ 1 n (* n n)) mode-re fvals) + (la-vector-to-data pip (length ip) mode-in ip) + (la-vector-to-data pdp (length dp) mode-re dp)) + (get-buf))))) + +;;;; +;;;; Miscellaneous Routines +;;;; + + +(defun split-list (x n) +"Args: (list cols) +Returns a list of COLS lists of equal length of the elements of LIST. +Example: (split-list '(1 2 3 4 5 6) 2) returns ((1 2 3) (4 5 6))" + (check-one-fixnum n) + (if (/= (rem (length x) n) 0) (error "length not divisible by ~a" n)) + (flet ((next-split () + (let ((result nil) + (end nil)) + (dotimes (i n result) + (declare (fixnum i)) + (let ((c-elem (list (first x)))) + (cond ((null result) + (setf result c-elem) + (setf end result)) + (t + (setf (rest end) c-elem) + (setf end (rest end))))) + (setf x (rest x)))))) + (let ((result nil) + (end nil) + (k (/ (length x) n))) + (declare (fixnum k)) + (dotimes (i k result) + (declare (fixnum i)) + (let ((c-sub (list (next-split)))) + (cond ((null result) + (setf result c-sub) + (setf end result)) + (t + (setf (rest end) c-sub) + (setf end (rest end))))))))) + diff --git a/lsbasics.lsp b/lsbasics.lsp new file mode 100644 index 0000000..866e030 --- /dev/null +++ b/lsbasics.lsp @@ -0,0 +1,717 @@ +;;;; lsbasics -- Low level Lisp-Stat functions +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +(provide "lsbasics") + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(progn + (defpackage "LISP-STAT-BASICS" + (:nicknames "LS-BASICS") + (:use "COMMON-LISP" "LISP-STAT-OBJECT-SYSTEM")) + + (in-package lisp-stat-basics)) +#-:CLtL2 +(in-package 'lisp-stat-basics + :nicknames '(ls-basics) + :use '(lisp lsos)) + +(shadowing-import (package-shadowing-symbols 'lisp-stat-object-system)) + +(use-package 'lisp-stat-object-system) + +(export '(sequencep copy-vector copy-array iseq which repeat select + permute-array sum prod count-elements mean if-else + sample sort-data order rank)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Type Checking Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun fixnump (x) +"Args: (x) +Returns T if X is a fixnum; NIL otherwise." + (declare (inline typep)) + (typep x 'fixnum)) + +(defun check-nonneg-fixnum (x) + (if (and (fixnump x) (<= 0 x)) x (error "not a non-negative fixnum"))) + +(defun check-one-fixnum (x) + (if (not (fixnump x)) (error "not a fixnum - ~a" x))) + +(defun check-one-real (a) + (if (not (or (rationalp a) (floatp a))) (error "not a real number ~s" a))) + +(defun check-one-number (a) + (if (not (numberp a)) (error "not a number ~s" a))) + +(defun check-sequence (a) + (if (not (or (vectorp a) (consp a))) (error "not a sequence - ~s" a))) + +(defun check-matrix (a) + (if (not (and (arrayp a) (= (array-rank a) 2))) + (error "not a matrix - ~s" a))) + +(defun check-square-matrix (a) + (check-matrix a) + (let ((m (array-dimension a 0)) + (n (array-dimension a 1))) + (if (/= n m) (error "not a square matrix - ~s" a)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Sequence Element Access +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun get-next-element (x i) + (let ((seq (first x))) + (if (consp seq) + (let ((elem (first seq))) + (setf (first x) (rest seq)) + elem) + (aref seq i)))) + +(defun set-next-element (x i v) + (let ((seq (first x))) + (cond ((consp seq) + (setf (first seq) v) + (setf (first x) (rest seq))) + (t (setf (aref seq i) v))))) + +(defun make-next-element (x) (list x)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Array to Row-Major Data Vector Conversion Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun array-data-vector (a) +"Args: (a) +Displaces array A to a vector" + (make-array (array-total-size a) :displaced-to a + :element-type (array-element-type a))) + +(defun vector-to-array (v dims) +"Args: (v dims) +Displaces vector V to array with dimensions DIMS" + (make-array dims :displaced-to v :element-type (array-element-type v))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Copying Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; +;;; COPY-VECTOR function +;;; + +(defun copy-vector (x) +"Args: (x) +Returns a copy of the vector X" + (copy-seq x)) + +;;; +;;; COPY-ARRAY function +;;; + +(defun copy-array (a) +"Args: (a) +Returns a copy of the array A" + (vector-to-array (copy-seq (array-data-vector a)) (array-dimensions a))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Sequence Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; +;;; sequence predicate SEQUENCEP +;;; + +(defun sequencep (x) +"Args: (x) +Returns NIL unless X is a list or vector." + (or (listp x) (vectorp x))) + +;;; +;;; ISEQ - generate a sequence of consecutive integers from a to b +;;; + +(defun iseq (a &optional b) +"Args: (n &optional m) +With one argumant returns a list of consecutive integers from 0 to N - 1. +With two returns a list of consecutive integers from N to M. +Examples: (iseq 4) returns (0 1 2 3) + (iseq 3 7) returns (3 4 5 6 7) + (iseq 3 -3) returns (3 2 1 0 -1 -2 -3)" + (if b + (let ((n (+ 1 (abs (- b a)))) + (x nil)) + (dotimes (i n x) + (setq x (cons (if (< a b) (- b i) (+ b i)) x)))) + (cond + ((= 0 a) nil) + ((< a 0) (iseq (+ a 1) 0)) + ((< 0 a) (iseq 0 (- a 1)))))) + +;;;; +;;;; WHICH function +;;;; + +(defun which (x) +"Args: (x) +Returns a list of the indices where elements of sequence X are not NIL." + (let ((x (list (compound-data-seq x))) + (result nil) + (tail nil)) + (flet ((add-result (x) + (if result (setf (rest tail) (list x)) (setf result (list x))) + (setf tail (if tail (rest tail) result))) + (get-next-element (seq-list i) + (cond ((consp (first seq-list)) + (let ((elem (first (first seq-list)))) + (setf (first seq-list) (rest (first seq-list))) + elem)) + (t (aref (first seq-list) i))))) + (let ((n (length (first x)))) + (dotimes (i n result) + (if (get-next-element x i) (add-result i))))))) + +;;;; +;;;; REPEAT function +;;;; + +(defun repeat (a b) +"Args: (vals times) +Repeats VALS. If TIMES is a number and VALS is a non-null, non-array atom, +a list of length TIMES with all elements eq to VALS is returned. If VALS +is a list and TIMES is a number then VALS is appended TIMES times. If +TIMES is a list of numbers then VALS must be a list of equal length and +the simpler version of repeat is mapped down the two lists. +Examples: (repeat 2 5) returns (2 2 2 2 2) + (repeat '(1 2) 3) returns (1 2 1 2 1 2) + (repeat '(4 5 6) '(1 2 3)) returns (4 5 5 6 6 6) + (repeat '((4) (5 6)) '(2 3)) returns (4 4 5 6 5 6 5 6)" + (cond ((compound-data-p b) + (let* ((reps (coerce (compound-data-seq (map-elements #'repeat a b)) + 'list)) + (result (first reps)) + (tail (last (first reps)))) + (dolist (next (rest reps) result) + (when next + (setf (rest tail) next) + (setf tail (last next)))))) + (t (let* ((a (if (compound-data-p a) + (coerce (compound-data-seq a) 'list) + (list a))) + (result nil)) + (dotimes (i b result) + (let ((next (copy-list a))) + (if result (setf (rest (last next)) result)) + (setf result next))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Subset Selection and Mutation Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; is x an ordered sequence of nonnegative positive integers? +(defun ordered-nneg-seq(x) + (if (sequencep x) + (let ((n (length x)) + (cx (make-next-element x)) + (m 0)) + (dotimes (i n t) + (let ((elem (check-nonneg-fixnum (get-next-element cx i)))) + (if (> m elem) (return nil) (setf m elem))))))) + +;;;; select or set the subsequence corresponding to the specified indices +(defun sequence-select(x indices &optional (values nil set-values)) + (let ((rlen 0) + (dlen 0) + (vlen 0) + (data nil) + (result nil)) + (declare (fixnum rlen dlen vlen)) + + ;; Check the input data + (check-sequence x) + (check-sequence indices) + (if set-values (check-sequence values)) + + ;; Find the data sizes + (setf data (if (ordered-nneg-seq indices) x (coerce x 'vector))) + (setf dlen (length data)) + (setf rlen (length indices)) + (when set-values + (setf vlen (length values)) + (if (/= vlen rlen) (error "value and index sequences do not match"))) + + ;; set up the result/value sequence + (setf result + (if set-values + values + (make-sequence (if (listp x) 'list 'vector) rlen))) + + ;; get or set the sequence elements */ + (if set-values + (do ((nextx x) + (cr (make-next-element result)) + (ci (make-next-element indices)) + (i 0 (+ i 1)) + (j 0) + (index 0)) + ((>= i rlen)) + (declare (fixnum i j index)) + (setf index (get-next-element ci i)) + (if (<= dlen index) (error "index out of range - ~a" index)) + (let ((elem (get-next-element cr i))) + (cond + ((listp x) + (when (> j index) + (setf j 0) + (setf nextx x)) + (do () + ((not (and (< j index) (consp nextx)))) + (incf j 1) + (setf nextx (rest nextx))) + (setf (first nextx) elem)) + (t (setf (aref x index) elem))))) + (do ((nextx data) + (cr (make-next-element result)) + (ci (make-next-element indices)) + (i 0 (+ i 1)) + (j 0) + (index 0) + (elem nil)) + ((>= i rlen)) + (declare (fixnum i j index)) + (setf index (get-next-element ci i)) + (if (<= dlen index) (error "index out of range - ~a" index)) + (cond + ((listp data) ;; indices must be ordered + (do () + ((not (and (< j index) (consp nextx)))) + (incf j 1) + (setf nextx (rest nextx))) + (setf elem (first nextx))) + (t (setf elem (aref data index)))) + (set-next-element cr i elem))) + + result)) + +;;;; translate row major index in resulting subarray to row major index +;;;; in the original array +;;;;*** is the floor in this function really needed??? +(defun old-rowmajor-index (index indices dim olddim) + (declare (fixnum index)) + (let ((rank (length dim)) + (face 1) + (oldface 1) + (oldindex 0)) + (declare (fixnum rank face oldface)) + + (dotimes (i rank) + (declare (fixnum i)) + (setf face (* face (aref dim i))) + (setf oldface (* oldface (aref olddim i)))) + + (dotimes (i rank) + (declare (fixnum i)) + (setf face (/ face (aref dim i))) + (setf oldface (/ oldface (aref olddim i))) + (incf oldindex + (* oldface (aref (aref indices i) (floor (/ index face))))) + (setf index (rem index face))) + + oldindex)) + +;;;; extract or set subarray for the indices from a displaced array +(defun subarray-select (a indexlist &optional (values nil set_values)) + (let ((indices nil) + (index) + (dim) + (vdim) + (data) + (result_data) + (olddim) + (result) + (rank 0) + (n 0) + (k 0)) + (declare (fixnum rank n)) + + (if (or (sequencep a) (not (arrayp a))) (error "not an array - ~a" a)) + (if (not (listp indexlist)) (error "bad index list - ~a" indices)) + (if (/= (length indexlist) (array-rank a)) + (error "wrong number of indices")) + + (setf indices (coerce indexlist 'vector)) + + (setf olddim (coerce (array-dimensions a) 'vector)) + + ;; compute the result dimension vector and fix up the indices + (setf rank (array-rank a)) + (setf dim (make-array rank)) + (dotimes (i rank) + (declare (fixnum i)) + (setf index (aref indices i)) + (setf n (aref olddim i)) + (setf index (if (fixnump index) (vector index) (coerce index 'vector))) + (setf k (length index)) + (dotimes (j k) + (declare (fixnum j)) + (if (<= n (check-nonneg-fixnum (aref index j))) + (error "index out of bounds - ~a" (aref index j))) + (setf (aref indices i) index)) + (setf (aref dim i) (length index))) + + ;; set up the result or check the values + (let ((dim-list (coerce dim 'list))) + (cond + (set_values + (cond + ((compound-data-p values) + (if (or (not (arrayp values)) (/= rank (array-rank values))) + (error "bad values array - ~a" values)) + (setf vdim (coerce (array-dimensions values) 'vector)) + (dotimes (i rank) + (declare (fixnum i)) + (if (/= (aref vdim i) (aref dim i)) + (error "bad value array dimensions - ~a" values))) + (setf result values)) + (t (setf result (make-array dim-list :initial-element values))))) + (t (setf result (make-array dim-list))))) + + ;; compute the result or set the values + (setf data (compound-data-seq a)) + (setf result_data (compound-data-seq result)) + (setf n (length result_data)) + (dotimes (i n) + (declare (fixnum i)) + (setf k (old-rowmajor-index i indices dim olddim)) + (if (or (> 0 k) (>= k (length data))) (error "index out of range")) + (if set_values + (setf (aref data k) (aref result_data i)) + (setf (aref result_data i) (aref data k)))) + + result)) + +;;;; +;;;; SELECT function +;;;; + +(defun select (x &rest args) +"Args: (a &rest indices) +A can be a list or an array. If A is a list and INDICES is a single number +then the appropriate element of A is returned. If is a list and INDICES is +a list of numbers then the sublist of the corresponding elements is returned. +If A in an array then the number of INDICES must match the ARRAY-RANK of A. +If each index is a number then the appropriate array element is returned. +Otherwise the INDICES must all be lists of numbers and the corresponding +submatrix of A is returned. SELECT can be used in setf." + (cond + ((every #'fixnump args) + (if (listp x) (nth (first args) x) (apply #'aref x args))) + ((sequencep x) (sequence-select x (first args))) + (t (subarray-select x args)))) + + +;; Built in SET-SELECT (SETF method for SELECT) +(defun set-select (x &rest args) + (let ((indices (butlast args)) + (values (first (last args)))) + (cond + ((sequencep x) + (if (not (consp indices)) (error "bad indices - ~a" indices)) + (let* ((indices (first indices)) + (i-list (if (fixnump indices) (list indices) indices)) + (v-list (if (fixnump indices) (list values) values))) + (sequence-select x i-list v-list))) + ((arrayp x) + (subarray-select x indices values)) + (t (error "bad argument type - ~a" x))) + values)) + +(defsetf select set-select) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Array Permutation Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; permute x into y using perm; all should be vectors; If check is TRUE +;;;; the routine will check to make sure no indices are reused, but x +;;;; will be destroyed. +(defun permute-indices (x y perm check) + (let ((rank (length x))) + (declare (fixnum rank)) + (dotimes (i rank) + (declare (fixnum i)) + (let ((k (aref perm i))) + (if (not (fixnump k)) (error "bad permutation sequence - ~a" perm)) + (if (or (< k 0) (>= k rank)) + (error "bad permutation sequence - ~a" perm)) + (setf (aref y i) (aref x k)) + ;; to insure dimensions are not re-used + (if check (setf (aref x k) NIL)))))) + +;;;; compute indices in a from rowmajor index k, put in vector result +(defun indices-from-rowmajor (a k result) + (declare (fixnum k)) + + (if (not (arrayp a)) (error "not an array - ~a" a)) + (if (or (> 0 k) (>= k (array-total-size a))) (error "index out of range")) + + (let ((face 1) + (rank (array-rank a)) + (dim (array-dimensions a))) + (declare (fixnum face rank)) + + (let ((cdim (make-next-element dim))) + (dotimes (i rank) + (declare (fixnum i)) + (setf face (* face (get-next-element cdim i))))) + + (let ((cdim (make-next-element dim))) + (dotimes (i rank) + (setf face (/ face (get-next-element cdim i))) + (setf (aref result i) (floor (/ k face))) + (setf k (rem k face)))))) + +;;;; Translate row major index in original array to row major index in new +;;;; array. Use indices vectors and ilist for temporary storage. +(defun translate-index (i result x perm indices oldindices ilist) + (declare (fixnum i)) + (let ((rank (array-rank x))) + (declare (fixnum rank)) + + (indices-from-rowmajor x i oldindices) + (permute-indices oldindices indices perm nil) + + (do ((next ilist (rest next)) + (k 0 (+ k 1))) + ((not (and (< k rank) (consp next)))) + (setf (first next) (aref indices k))) + + (apply #'array-row-major-index result ilist))) + +;;;; +;;;; PERMUTE-ARRAY function +;;;; + +(defun permute-array (x perm) +"Args: (a p) +Returns a copy of the array A permuted according to the permutation P." + (if (not (arrayp x)) (error "not an array - ~a" x)) + (check-sequence perm) + (if (/= (length perm) (array-rank x)) + (error "bad permutation sequence - ~a" perm)) + (let* ((perm (coerce perm 'vector)) + (rank (array-rank x)) + (dim (make-array rank)) + (olddim (coerce (array-dimensions x) 'vector))) + (declare (fixnum rank)) + + ;; construct new dimension vector + (permute-indices olddim dim perm t) + + ;; make result array and the index vectors and lists */ + (let* ((result (make-array (coerce dim 'list))) + (indices (make-array rank)) + (oldindices (make-array rank)) + (ilist (make-list rank)) + (data (compound-data-seq x)) + (result_data (compound-data-seq result)) + (n (length data))) + (declare (fixnum n)) + + (dotimes (i rank) + (declare (fixnum i)) + (setf (aref oldindices i) (list nil))) + + ;; fill in the result + (if (/= n (length result_data)) (error "bad data")) + (dotimes (i n result) + (declare (fixnum i)) + (let ((k (translate-index i result x perm indices oldindices ilist))) + (declare (fixnum k)) + (setf (aref result_data k) (aref data i))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; SUM, PROD, COUNT-ELEMENTS, and MEAN Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun sum-1 (x) + (if (numberp x) + x + (let ((seq (compound-data-seq x)) + (sum 0)) + (if (consp seq) + (dolist (x seq sum) + (setf sum (+ sum (if (numberp x) x (sum-1 x))))) + (let ((n (length seq))) + (declare (fixnum n)) + (dotimes (i n sum) + (declare (fixnum i)) + (let ((x (aref seq i))) + (setf sum (+ sum (if (numberp x) x (sum-1 x))))))))))) + +(defun sum (&rest args) +"Args: (&rest number-data) +Returns the sum of all the elements of its arguments. Returns 0 if there +are no arguments. Vector reducing." + (if args + (sum-1 (if (rest args) args (first args))) + 0)) + +(defun prod-1 (x) + (if (numberp x) + x + (let ((seq (compound-data-seq x)) + (prod 1)) + (if (consp seq) + (dolist (x seq prod) + (setf prod (* prod (if (numberp x) x (prod-1 x))))) + (let ((n (length seq))) + (declare (fixnum n)) + (dotimes (i n prod) + (declare (fixnum i)) + (let ((x (aref seq i))) + (setf prod (* prod (if (numberp x) x (prod-1 x))))))))))) + +(defun prod (&rest args) +"Args: (&rest number-data) +Returns the product of all the elements of its arguments. Returns 1 if there +are no arguments. Vector reducing." + (if args + (prod-1 (if (rest args) args (first args))) + 1)) + +(defun count-elements (x) +"Args: (number &rest more-numbers) +Returns the number of its arguments. Vector reducing" + (if (compound-data-p x) + (let ((seq (compound-data-seq x)) + (count 0)) + (if (consp seq) + (dolist (x seq count) + (incf count (if (compound-data-p x) (count-elements x) 1))) + (let ((n (length seq))) + (declare (fixnum n)) + (dotimes (i n count) + (declare (fixnum i)) + (let ((x (aref seq i))) + (incf count (if (compound-data-p x) (count-elements x) 1))))))) + 1)) + +(defun mean (x) +"Args: (x) +Returns the mean of the elements x. Vector reducing." + (let ((mean 0.0) + (count 0.0)) + (labels ((add-to-mean (x) + (let ((count+1 (+ count 1.0))) + (setf mean (+ (* (/ count count+1) mean) (* (/ count+1) x))) + (setf count count+1))) + (find-mean (x) + (if (numberp x) + (add-to-mean x) + (let ((seq (compound-data-seq x))) + (if (consp seq) + (dolist (x seq) + (if (numberp x) (add-to-mean x) (find-mean x))) + (let ((n (length seq))) + (dotimes (i n) + (declare (fixnum i)) + (let ((x (aref seq i))) + (if (numberp x) + (add-to-mean x) + (find-mean x)))))))))) + (find-mean x) + mean))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Sorting Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun sort-data (x) +"Args: (sequence) +Returns a sequence with the numbers or strings in the sequence X in order." + (flet ((less (x y) (if (numberp x) (< x y) (string-lessp x y)))) + (stable-sort (copy-seq (compound-data-seq x)) #'less))) + +(defun order (x) +"Args (x) +Returns a sequence of the indices of elements in the sequence of numbers +or strings X in order." + (let* ((seq (compound-data-seq x)) + (type (if (consp seq) 'list 'vector)) + (i -1)) + (flet ((entry (x) (setf i (+ i 1)) (list x i)) + (less (a b) + (let ((x (first a)) + (y (first b))) + (if (numberp x) (< x y) (string-lessp x y))))) + (let ((sorted-seq (stable-sort (map type #'entry seq) #'less))) + (map type #'second sorted-seq))))) + +(defun rank (x) +"Args (x) +Returns a sequence with the elements of the list or array of numbers or +strings X replaced by their ranks." + (let ((ranked-seq (order (order x)))) + (make-compound-data (compound-data-shape x) ranked-seq))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; IF-ELSE and SAMPLE Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun if-else (a x y) +"Args: (first x y) +Takes simple or compound data items FIRST, X and Y and returns result of +elementswise selecting from X if FIRST is not NIL and from Y otherwise." + (flet ((base-if-else (a x y) (if a x y))) + (recursive-map-elements #'base-if-else #'if-else a x y))) + +(defun sample (x ssize &optional replace) +"Args: (x n &optional (replace nil)) +Returns a list of a random sample of size N from sequence X drawn with or +without replacement." + (check-sequence x) + (let ((n (length x)) + (x (if (consp x) (coerce x 'vector) (copy-vector x))) + (result nil)) + (if (< 0 n) + (dotimes (i ssize result) + (let ((j (if replace (random n) (+ i (random (- n i)))))) + (setf result (cons (aref x j) result)) + (unless replace ;; swap elements i and j + (let ((temp (aref x i))) + (setf (aref x i) (aref x j)) + (setf (aref x j) temp)))))))) + diff --git a/lsfloat.lsp b/lsfloat.lsp new file mode 100644 index 0000000..0deeaad --- /dev/null +++ b/lsfloat.lsp @@ -0,0 +1,207 @@ +;;;; lsfloat -- Floating point specs and transcendental functions +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. +;;;; +;;;; Common Lisp allows for four different floating point types that need +;;;; not be distinct. For statistical work, the type I prefer to use is +;;;; the one that is closest to a C double. This type is named stat-float. +;;;; By setting the variable *read-default-float-format* to this type, you +;;;; insure that data entered as floating point data is read in with this +;;;; type. The problem arises with data read as integers that is passed to +;;;; a transcendental, like sqrt. Floating point contagion rules say these +;;;; integers are to be converted to type single-float. Unless single-float +;;;; is equivalent to C double, as it is in Mac CL and KCL, this is not +;;;; what I want. Hence this file redefines the transcendentals to first +;;;; coerce their arguments to stat-float before applying the built-in +;;;; functions. +;;;; +;;;; No actual modifications to the transcendentals are needed if +;;;; single-float is the same as stat-float. The fearure +;;;; :stat-float-is-double-float is used to indicate this. +;;;; +;;;; KCL NOTE: +;;;; In (A)KCL the type short-float corresponds to C float and the types +;;;; single-float, double-float and long-float correspond to C double. +;;;; But in the implementation of the transcendentals (A)KCL coerces +;;;; rationals to short-float, not single-float. CLtL1 is a little vague +;;;; on this (it talks about "single precision") but CLtL2 clarifies that +;;;; rationals should produce single-float results. So (A)KCL is wrong, at +;;;; least relative to the clarification in CLtL2. I therefore decided +;;;; to fix (A)KCL in files c/num_sfun.c and lsp/numlib.lsp. If these +;;;; fixes are applied, the feature :stat-float-is-double-float should be +;;;; defined. +;;;; + +(provide "lsfloat") + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(in-package lisp-stat-basics) +#-:CLtL2 +(in-package 'lisp-stat-basics) + +(export '(*stat-float-type* *stat-cfloat-type* *stat-float-template* + machine-epsilon)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Constants determining default floating point type for statistical +;;;; operations. This type generally corresponds to a C double. +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconstant *stat-float-type* 'long-float) +(defconstant *stat-cfloat-type* '(complex long-float)) +(defconstant *stat-float-template* 0.d0) + +(deftype stat-float () 'long-float) +(deftype stat-cfloat () '(complex long-float)) + +(defconstant machine-epsilon + (do ((epsilon (float 1.0 *stat-float-template*) (/ epsilon 2.0))) + ((= (+ 1.0 (/ epsilon 2.0)) 1.0) epsilon))) + +(defmacro declare-double (&rest vars) `(declare (long-float ,@vars))) + +(setf *read-default-float-format* *stat-float-type*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Functions and Macros for modifying functions to coerce to standard +;;;; floating point type. +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; FFIX - coerces its arguments to standard real or complex floating +;;; point number +#-:stat-float-is-double-float +(defmacro ffix (x) + `(if (complexp ,x) + (coerce ,x ',*stat-cfloat-type*) + (float ,x ',*stat-float-template*))) + +#+:stat-float-is-double-float +(defmacro ffix (x) x) + +;;; MAKEDOUBLE coerces its argument to the standard floating point type + +(defun makedouble (x) (float x *stat-float-template*)) + +#+:stat-float-is-double-float +(eval-when (compile) + (proclaim '(function makedouble (t) long-float))) + +;;; +;;; MAKE-BASE-TRANS-FUN Macro for re-defining one argument transcendental +;;; functions +;;; +#-:stat-float-is-double-float +(defmacro make-base-trans-fun (sym) + (let* ((base-sym (intern (string-upcase (format nil "BASE-~s" sym)))) + (doc (documentation sym 'function)) + (doc-list (if doc (list (fix-base-doc doc))))) + `(defun ,base-sym (x) + ,@doc-list + (declare (inline ,sym coerce float)) + (,sym (ffix x))))) + +#+:stat-float-is-double-float +(defmacro make-base-trans-fun (sym) + (let* ((base-sym (intern (string-upcase (format nil "BASE-~s" sym)))) + (doc (documentation sym 'function))) + `(progn (setf (symbol-function ',base-sym) (symbol-function ',sym)) + (if ,doc (setf (documentation ',base-sym 'function) ,doc))))) + +;;; +;;; MAKE-BASE-TRANS-FUN-2 Macro for re-defining transcendental functions +;;; with an optional second argument +;;; +#-:stat-float-is-double-float +(defmacro make-base-trans-fun-2 (sym) + (let* ((base-sym (intern (string-upcase (format nil "BASE-~s" sym)))) + (doc (documentation sym 'function)) + (doc-list (if doc (list (fix-base-doc doc))))) + `(defun ,base-sym (x &optional y) + ,@doc-list + (declare (inline ,sym coerce float)) + (if y (,sym (ffix x) (ffix y)) (,sym (ffix x)))))) + +#+:stat-float-is-double-float +(defmacro make-base-trans-fun-2 (sym) + (let* ((base-sym (intern (string-upcase (format nil "BASE-~s" sym)))) + (doc (documentation sym 'function))) + `(progn (setf (symbol-function ',base-sym) (symbol-function ',sym)) + (if ,doc (setf (documentation ',base-sym 'function) ,doc))))) + +;;; FIX-BASE-DOC adds note about modification to documentation string argument +(defmacro fix-base-doc (doc) + `(format nil + "~a~%Modified to coerce arguments(s) to stat-float or stat-cfloat." + ,doc)) + +;;; FIX-BASE-FUN-DOC fixes documentation of SYM and installs in BASE-SYM +(defun fix-base-fun-doc (sym base-sym) + (let ((doc (documentation sym 'function))) + (if doc (setf (documentation base-sym 'function) (fix-base-doc doc))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Modified base functions to coerce to standard floating point type +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; BASE-FLOAT +#-:stat-float-is-double-float +(progn + (defun base-float (x &optional (y *stat-float-template*)) (float x y)) + (fix-base-fun-doc 'float 'base-float)) + +#+:stat-float-is-double-float +(make-base-trans-fun float) + +;;; BASE-EXPT +#-:stat-float-is-double-float +(progn + (defun base-expt (x y) + (declare (inline expt coerce float integerp)) + (if (integerp y) (expt x y) (expt (ffix x) (ffix y)))) + + (fix-base-fun-doc 'expt 'base-expt)) + +#+:stat-float-is-double-float +(make-base-trans-fun expt) + +;;; Others +(make-base-trans-fun-2 log) +(make-base-trans-fun exp) +(make-base-trans-fun sqrt) +(make-base-trans-fun sin) +(make-base-trans-fun cos) +(make-base-trans-fun tan) +(make-base-trans-fun asin) +(make-base-trans-fun acos) +(make-base-trans-fun-2 atan) +(make-base-trans-fun sinh) +(make-base-trans-fun cosh) +(make-base-trans-fun tanh) +(make-base-trans-fun asinh) +(make-base-trans-fun acosh) +(make-base-trans-fun atanh) +(make-base-trans-fun abs) +(make-base-trans-fun phase) +(make-base-trans-fun-2 ffloor) +(make-base-trans-fun-2 fceiling) +(make-base-trans-fun-2 ftruncate) +(make-base-trans-fun-2 fround) +(make-base-trans-fun signum) +(make-base-trans-fun cis) diff --git a/lsmacros.lsp b/lsmacros.lsp new file mode 100644 index 0000000..719f21c --- /dev/null +++ b/lsmacros.lsp @@ -0,0 +1,105 @@ +;;;; lsmacros -- Various macros +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. +;;;; + +(provide "lsmacros") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Macros for LISP-STAT-BASICS Package +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(progn + (defpackage "LISP-STAT-BASICS" + (:nicknames "LS-BASICS") + (:use "COMMON-LISP" "LISP-STAT-OBJECT-SYSTEM")) + + (in-package lisp-stat-basics)) +#-:CLtL2 +(in-package 'lisp-stat-basics + :nicknames '(ls-basics) + :use '(lisp lsos)) + +;;;; +;;;; Floating Point Macros +;;;; + +(defmacro declare-double (&rest vars) `(declare (long-float ,@vars))) + +;;;; +;;;; Macros for Defining Vectorized Funcitons +;;;; + +(defmacro make-vectorized-function (sym fcn) + `(defun ,sym (&rest args) + (apply #'map-elements #',fcn args))) + +(defmacro fixup-vectorized-doc-list (sym) + `(let ((doc (documentation ',sym 'function))) + (if doc (list (format nil "~s~%Vectorized."))))) + +(defmacro make-rv-function (sym fcn &rest args) + (cond + ((and args (= (length args) 1)) + `(defun ,sym (,@args) + ,@(fixup-vectorized-doc-list fcn) + (declare (inline cmpndp ,fcn ,sym recursive-map-elements list)) + (if (cmpndp ,@args) + (recursive-map-elements #',fcn #',sym ,@args) + (,fcn ,@args)))) + (args + `(defun ,sym (,@args) + ,@(fixup-vectorized-doc-list fcn) + (declare (inline cmpndp ,fcn ,sym recursive-map-elements list)) + (if ,(cons 'or (mapcar #'(lambda (x) (list 'cmpndp x)) args)) + (recursive-map-elements #',fcn #',sym ,@args) + (,fcn ,@args)))) + (t + `(defun ,sym (&optional (x nil has-x) (y nil has-y) &rest args) + ,@(fixup-vectorized-doc-list fcn) + (declare (inline cmpndp ,fcn ,sym recursive-map-elements list)) + (if has-x + (if has-y + (if (or args (cmpndp x) (cmpndp y)) + (apply #'recursive-map-elements #',fcn #',sym x y args) + (,fcn x y)) + (if (cmpndp x) + (recursive-map-elements #',fcn #',sym x) + (,fcn x))) + (,fcn)))))) + +(defmacro make-rv-function-1 (sym fcn &rest args) + (cond + ((and args (= (length args) 1)) + `(defun ,sym (,@args) + ,@(fixup-vectorized-doc-list fcn) + (declare (inline cmpndp ,fcn ,sym recursive-map-elements list)) + (if (cmpndp ,@args) + (recursive-map-elements #',fcn #',sym ,@args) + (,fcn ,@args)))) + (args + `(defun ,sym (,@args) + ,@(fixup-vectorized-doc-list fcn) + (declare (inline cmpndp ,fcn ,sym recursive-map-elements list)) + (if ,(cons 'or (mapcar #'(lambda (x) (list 'cmpndp x)) args)) + (recursive-map-elements #',fcn #',sym ,@args) + (,fcn ,@args)))) + (t + `(defun ,sym (x &optional (y nil has-y) &rest args) + ,@(fixup-vectorized-doc-list fcn) + (declare (inline cmpndp ,fcn ,sym recursive-map-elements list)) + (if has-y + (if (or args (cmpndp x) (cmpndp y)) + (apply #'recursive-map-elements #',fcn #',sym x y args) + (,fcn x y)) + (if (cmpndp x) + (recursive-map-elements #',fcn #',sym x) + (,fcn x))))))) diff --git a/lsmath.lsp b/lsmath.lsp new file mode 100644 index 0000000..44f5f4b --- /dev/null +++ b/lsmath.lsp @@ -0,0 +1,212 @@ +;;;; lsmath -- Install vectorized arithmetic functions +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +(provide "lsmath") + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(progn + (defpackage "LISP-STAT" + (:nicknames "LS" "STATS") + (:use "COMMON-LISP" "LISP-STAT-BASICS" "LISP-STAT-OBJECT-SYSTEM")) + + (in-package lisp-stat)) +#-:CLtL2 +(in-package 'lisp-stat + :nicknames '(ls stats) + :use '(lisp ls-basics lsos)) + +(shadowing-import (package-shadowing-symbols 'lisp-stat-object-system)) +(shadowing-import (package-shadowing-symbols 'lisp-stat-basics)) +(use-package 'lisp-stat-object-system) +(use-package 'lisp-stat-basics) + +;;; +;;; Shadow the symbols in the lisp package that will be redefined +;;; + +(shadow '(expt + - * / ** mod rem abs 1+ 1- log exp sqrt sin cos tan + asin acos atan sinh cosh tanh asinh acosh atanh float random + truncate floor ceiling round minusp zerop plusp evenp oddp + < <= = /= >= > complex conjugate realpart imagpart phase + min max logand logior logxor lognot ffloor fceiling + ftruncate fround signum cis)) + +(export '(^ ** expt + - * / mod rem pmin pmax abs 1+ 1- log exp sqrt sin cos + tan asin acos atan sinh cosh tanh asinh acosh atanh float random + truncate floor ceiling round minusp zerop plusp evenp oddp < <= = + /= >= > complex conjugate realpart imagpart phase min max + logand logior logxor lognot ffloor fceiling ftruncate fround + signum cis)) + +;;;; +;;;; Import some symbols +;;;; + +(import '(ls-basics::make-rv-function ls-basics::make-rv-function-1)) + +#+(and kcl fast-c-code internal-c-math) +(progn +(import 'ls-basics::install-rv-function) +(import '(ls-basics::rv-expt ls-basics::rv-+ ls-basics::rv-- + ls-basics::rv-* ls-basics::rv-/ ls-basics::rv-mod + ls-basics::rv-rem ls-basics::rv-pmin ls-basics::rv-pmax + ls-basics::rv-1+ ls-basics::rv-1- ls-basics::rv-exp + ls-basics::rv-log ls-basics::rv-sqrt ls-basics::rv-sin + ls-basics::rv-cos ls-basics::rv-tan ls-basics::rv-atan + ls-basics::rv-float ls-basics::rv-random ls-basics::rv-floor + ls-basics::rv-ceiling ls-basics::rv-truncate ls-basics::rv-round + ls-basics::rv-zerop ls-basics::rv-plusp ls-basics::rv-minusp + ls-basics::rv-oddp ls-basics::rv-evenp ls-basics::rv-< + ls-basics::rv-<= ls-basics::rv-= ls-basics::rv-/= + ls-basics::rv->= ls-basics::rv-> ls-basics::rv-complex + ls-basics::rv-realpart ls-basics::rv-imagpart + ls-basics::rv-conjugate)) +) + +(import '(ls-basics::base-expt ls-basics::base-log ls-basics::base-exp + ls-basics::base-sqrt ls-basics::base-sin ls-basics::base-cos + ls-basics::base-tan ls-basics::base-asin ls-basics::base-acos + ls-basics::base-atan ls-basics::base-sinh ls-basics::base-cosh + ls-basics::base-tanh ls-basics::base-asinh ls-basics::base-acosh + ls-basics::base-atanh ls-basics::base-float ls-basics::base-abs + ls-basics::base-phase ls-basics::base-ffloor + ls-basics::base-fceiling ls-basics::base-ftruncate + ls-basics::base-fround ls-basics::base-signum + ls-basics::base-cis)) + +;;;; +;;;; Patch up some type definitions +;;;; + +(deftype float () 'lisp:float) +(deftype complex () 'lisp:complex) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Install the vectorized math functions +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(make-rv-function ^ base-expt x y) +(make-rv-function ** base-expt x y) +(make-rv-function expt base-expt x y) + +(make-rv-function + lisp:+) +(make-rv-function-1 - lisp:-) +(make-rv-function * lisp:*) +(make-rv-function-1 / lisp:/) +(make-rv-function mod lisp:mod x y) +(make-rv-function rem lisp:rem x y) +(make-rv-function-1 pmin lisp:min) +(make-rv-function-1 pmax lisp:max) +(make-rv-function abs base-abs x) +(make-rv-function 1+ lisp:1+ x) +(make-rv-function 1- lisp:1- x) + +(make-rv-function-1 log base-log) +(make-rv-function exp base-exp x) +(make-rv-function sqrt base-sqrt x) + +(make-rv-function sin base-sin x) +(make-rv-function cos base-cos x) +(make-rv-function tan base-tan x) +(make-rv-function asin base-asin x) +(make-rv-function acos base-acos x) +(make-rv-function-1 atan base-atan) +(make-rv-function sinh base-sinh x) +(make-rv-function cosh base-cosh x) +(make-rv-function tanh base-tanh x) +(make-rv-function asinh base-asinh x) +(make-rv-function acosh base-acosh x) +(make-rv-function atanh base-atanh x) + +(make-rv-function-1 float base-float) +(make-rv-function-1 random lisp:random) + +(make-rv-function-1 floor lisp:floor) +(make-rv-function-1 ceiling lisp:ceiling) +(make-rv-function-1 truncate lisp:truncate) +(make-rv-function-1 round lisp:round) + +(make-rv-function zerop lisp:zerop x) +(make-rv-function plusp lisp:plusp x) +(make-rv-function minusp lisp:minusp x) +(make-rv-function oddp lisp:oddp x) +(make-rv-function evenp lisp:evenp x) + +(make-rv-function-1 < lisp:<) +(make-rv-function-1 <= lisp:<=) +(make-rv-function-1 = lisp:=) +(make-rv-function-1 /= lisp:/=) +(make-rv-function-1 >= lisp:>=) +(make-rv-function-1 > lisp:>) + +(make-rv-function-1 complex lisp:complex) +(make-rv-function realpart lisp:realpart x) +(make-rv-function imagpart lisp:imagpart x) +(make-rv-function conjugate lisp:conjugate x) +(make-rv-function phase base-phase x) + +(defun min-1 (x) + (if (numberp x) + x + (let* ((seq (compound-data-seq x)) + (first (elt seq 0)) + (result (if (numberp first) first (min-1 first)))) + (if (consp seq) + (dolist (x (rest seq) result) + (let ((r (if (numberp x) x (min-1 x)))) + (if (lisp:< r result) (setf result r)))) + (let ((n (length seq))) + (declare (fixnum n)) + (dotimes (i n result) + (declare (fixnum i)) + (let* ((x (aref seq i)) + (r (if (numberp x) x (min-1 x)))) + (if (lisp:< r result) (setf result r))))))))) + +(defun min (x &optional (y nil has-y) &rest args) + (if (and (null args) (numberp x) (numberp y)) + (lisp:min x y) + (if has-y (min-1 (cons x (cons y args))) (min-1 x)))) + +(defun max-1 (x) + (if (numberp x) + x + (let* ((seq (compound-data-seq x)) + (first (elt seq 0)) + (result (if (numberp first) first (max-1 first)))) + (if (consp seq) + (dolist (x (rest seq) result) + (let ((r (if (numberp x) x (max-1 x)))) + (if (lisp:> r result) (setf result r)))) + (let ((n (length seq))) + (declare (fixnum n)) + (dotimes (i n result) + (declare (fixnum i)) + (let* ((x (aref seq i)) + (r (if (numberp x) x (max-1 x)))) + (if (lisp:> r result) (setf result r))))))))) + +(defun max (x &optional (y nil has-y) &rest args) + (if (and (null args) (numberp x) (numberp y)) + (lisp:max x y) + (if has-y (max-1 (cons x (cons y args))) (max-1 x)))) + +(make-rv-function logand lisp:logand) +(make-rv-function logior lisp:logior) +(make-rv-function logxor lisp:logxor) +(make-rv-function lognot lisp:lognot x) + +(make-rv-function-1 ffloor base-ffloor) +(make-rv-function-1 fceiling base-fceiling) +(make-rv-function-1 ftruncate base-ftruncate) +(make-rv-function-1 fround base-fround) +(make-rv-function signum base-signum x) +(make-rv-function cis base-cis x) diff --git a/lsobjects.lsp b/lsobjects.lsp new file mode 100644 index 0000000..c3d355e --- /dev/null +++ b/lsobjects.lsp @@ -0,0 +1,816 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; LISP-STAT Object System +;;;; +;;;; +;;;; Simple CL implementation of the object system for Lisp-Stat (LSOS) +;;;; as described in Tierney (1990). +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. +;;;; +;;;; +;;;; NOTES: +;;;; +;;;; If your CL's handling of packages is compliant with CLtL, 2nd +;;;; Edition (like Macintosh CL version 2), add the feature :CLtL2 +;;;; before loading or compiling this code. +;;;; +;;;; This implementation does not make use of CLOS. It can coexist +;;;; with CLOS, but there are two name conflicts: slot-value and +;;;; call-next-method. These two symbols are shadowed in the LSOS +;;;; package and must be shadowed in any package that uses LSOS. +;;;; Evaluating the function (lsos::use-lsos) from a package after +;;;; loading this code shadows these two symbols and does a +;;;; use-package for LSOS. +;;;; +;;;; The :compile-method method uses function-lambda-expression +;;;; defined in CLtL, 2nd Edition. (This method is only needed if +;;;; you want to force compilation of an interpreted method. It is +;;;; not used by the compiler.) +;;;; +;;;; The efficiency of this code could be improved by low level +;;;; coding of the dispatching functions send, call-method and +;;;; call-next-method to avoid creating an argument list. Other +;;;; efficiency improvements are possible as well, in particular +;;;; by good use of declarations. It may also be possible to build +;;;; a more efficient implementation using the CLOS metaclass +;;;; protocol. +;;;; +;;;; There are a few minimal tools for experimenting with constraints +;;;; in the code; they are marked by #+:constreinthooks. Sometime +;;;; soon I hope to augment or replace these hooks with a CORAL-like +;;;; constraint system (as used in GARNET). +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide "lsobjects") + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(progn + (defpackage "LISP-STAT-OBJECT-SYSTEM" + (:nicknames "LS-OBJECTS" "LSOS") + (:use "COMMON-LISP") + (:shadow "CALL-NEXT-METHOD" "SLOT-VALUE")) + + (in-package lisp-stat-object-system)) + +#-:CLtL2 +(progn + (in-package 'lisp-stat-object-system + :nicknames '(ls-objects lsos) + :use '(lisp)) + + (shadow '(call-next-method slot-value))) + +(export '(ls-object objectp *object* kind-of-p make-object *message-hook* + *set-slot-hook* slot-value self send call-next-method call-method + defmeth defproto instance-slots proto-name)) + +(defun use-lsos () + (shadowing-import (package-shadowing-symbols 'lisp-stat-object-system)) + (use-package 'lisp-stat-object-system)) + +;;;; +;;;; Structure Implementation of Lisp-Stat Object System +;;;; + +(defvar *object-serial* 0) + +(defstruct (ls-object + (:constructor make-object-structure) + (:print-function print-object-structure) + (:predicate objectp)) + slots + methods + parents + preclist + (serial (incf *object-serial*))) + +(defun print-object-structure (object stream depth) + (send object :print stream)) + +(setf (documentation 'objectp 'function) +"Args: (x) +Returns T if X is an object, NIL otherwise.") + +(defvar *object* (make-object-structure)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Utility Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; special variable to hold current value of SELF +(defvar *self* nil) + +(defun get-self () + (if (not (objectp *self*)) (error "not in a method")) + *self*) + +(defun has-duplicates (list) + (do ((next list (rest next))) + ((not (consp next)) nil) + (if (member (first next) (rest next)) (return t)))) + +;;; version of assoc using eq -- should be faster than regular assoc +(defun assoc-eq (item alist) + (declare (inline car eq)) + (dolist (i alist) + (if (eq (car i) item) (return i)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Predicate and Checking Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun check-non-nil-symbol (x) + (unless (and x (symbolp x)) (error "bad symbol - ~s" x))) + +(defun check-object (x) + (if (objectp x) x (error "bad object - ~s" x))) + +(defun kind-of-p (x y) +"Args: (x y) +Returns T is X and Y are objects and X inherits from Y, NIL otherwise." + (if (and (objectp x) (objectp y)) + (if (member y (ls-object-preclist x)) t nil) + nil)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Precedence List Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; find set of object and ancestors +(defun find-SC (object) + (copy-list (ls-object-preclist (check-object object)))) + +;;;; find set of object and ancestors +(defun find-S (object) + (do ((result nil) + (parents (ls-object-parents object) (cdr parents))) + ((not (consp parents)) + (delete-duplicates (cons object result))) + (setf result (nconc (find-SC (first parents)) result)))) + +;;;; find local precedence ordering +(defun find-RC (object) + (let ((list (copy-list (ls-object-parents (check-object object))))) + (do ((next list (rest next))) + ((not (consp next)) list) + (setf (first next) (cons object (first next))) + (setf object (rest (first next)))))) + +;;;; find partial precedence ordering +(defun find-R (S) + (do ((result nil) + (S S (rest S))) + ((not (consp S)) + (delete-duplicates result)) + (setf result (nconc result (find-RC (first S)))))) + +;;;; check if x has a predecessor according to R +(defun has-predecessor (x R) + (dolist (cell R nil) + (if (and (consp cell) (eq x (rest cell))) (return t)))) + +;;;; find list of objects in S without predecessors, by R +(defun find-no-predecessor-list (S R) + (let ((result nil)) + (dolist (x S result) + (unless (has-predecessor x R) (setf result (cons x result)))))) + +;;;; find the position of child, if any, of x in P, the list found so far +(defun child-position (x P) + (let ((count 0)) + (declare (fixnum count)) + (dolist (next P -1) + (if (member x (ls-object-parents next)) (return count)) + (incf count)))) + +;;;; find the next object in the precedence list from objects with no +;;;; predecessor and current list. +(defun next-object (no-preds P) + (cond + ((not (consp no-preds)) nil) + ((not (consp (rest no-preds))) (first no-preds)) + (t + (let ((count -1) + (result nil)) + (declare (fixnum count)) + (dolist (x no-preds result) + (let ((tcount (child-position x P))) + (declare (fixnum tcount)) + (when (> tcount count) + (setf result x) + (setf count tcount)))))))) + +;;;; remove object x from S +(defun trim-S (x S) (delete x S)) + +;;;; remove all pairs containing x from R. x is assumed to have no +;;;; predecessors, so only the first position is checked. +(defun trim-R (x R) (delete x R :key #'first)) + +;;;; calculat the object's precedence list +(defun precedence-list (object) + (do* ((S (find-S object)) + (R (find-R S)) + (P nil) + (no-preds nil) + (next nil)) + ((not (consp S)) P) + (setf no-preds (find-no-predecessor-list S R)) + (setf next (next-object no-preds P)) + (if (null next) (error "inconsistent precedence order")) + (setf P (nconc P (list next))) + (setf S (trim-S next S)) + (setf R (trim-R next R)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Object Construction Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun calculate-preclist (object) + (let ((parents (ls-object-parents (check-object object)))) + (if (not (consp parents)) (error "bad parent list - ~s" parents)) + (if (consp (rest parents)) + (precedence-list object) + (let ((parent (check-object (first parents)))) + (cons object (ls-object-preclist parent)))))) + +(defun check-parents (parents) + (cond + ((or (null parents) (objectp parents)) parents) + ((consp parents) + (dolist (x parents) (check-object x)) + (if (has-duplicates parents) (error "parents may not contain duplicates"))) + (t (error "bad parents - ~s" parents)))) + +(defun make-basic-object (parents object) + (check-parents parents) + + (if (not (objectp object)) (setf object (make-object-structure))) + + (setf (ls-object-preclist object) (ls-object-preclist *object*)) + (setf (ls-object-parents object) + (cond ((null parents) (list *object*)) + ((objectp parents) (list parents)) + (t parents))) + (setf (ls-object-preclist object) (calculate-preclist object)) + + object) + +(defun make-object (&rest parents) +"Args: (&rest parents) +Returns a new object with parents PARENTS. If PARENTS is NIL, +(list *OBJECT*) is used." + (make-basic-object parents NIL)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Constraint Hook Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(pushnew :constrainthooks *features*) +#+:constrainthooks (defvar *message-hook* nil) +#+:constrainthooks (defvar *set-slot-hook* nil) + +#+:constrainthooks +(defun check-constraint-hooks (object sym slot) + (let ((hook (if slot *set-slot-hook* *message-hook*))) + (if hook + (if slot + (let ((*set-slot-hook* nil)) + (funcall hook object sym)) + (let ((*message-hook* nil)) + (funcall hook object sym)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Slot Access Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun make-slot-entry (x y) (cons x y)) +(defun slot-entry-p (x) (consp x)) +(defun slot-entry-key (x) (first x)) +(defun slot-entry-value (x) (rest x)) +(defun set-slot-entry-value (x v) (setf (rest x) v)) +(defsetf slot-entry-value set-slot-entry-value) + +(defun find-own-slot (x slot) + (if (objectp x) (assoc-eq slot (ls-object-slots x)))) + +(defun find-slot (x slot) + (if (objectp x) + (let ((preclist (ls-object-preclist x))) + (dolist (object preclist) + (let ((slot-entry (find-own-slot object slot))) + (if slot-entry (return slot-entry))))))) + +(defun add-slot (x slot value) + (check-object x) + (check-non-nil-symbol slot) + (let ((slot-entry (find-own-slot x slot))) + (if slot-entry + (setf (slot-entry-value slot-entry) value) + (setf (ls-object-slots x) + (cons (make-slot-entry slot value) (ls-object-slots x))))) + nil) + +(defun delete-slot (x slot) + (check-object x) + (setf (ls-object-slots x) + (delete slot (ls-object-slots x) :key #'slot-entry-key))) + +(defun get-slot-value (x slot &optional no-err) + (check-object x) + (let ((slot-entry (find-slot x slot))) + (if (slot-entry-p slot-entry) + (slot-entry-value slot-entry) + (unless no-err (error "no slot named ~s in this object" slot))))) + +(defun set-slot-value (x slot value) + (check-object x) + (let ((slot-entry (find-own-slot x slot))) + (cond + ((slot-entry-p slot-entry) + (set-slot-entry-value slot-entry value) + #+:constrainthooks (check-constraint-hooks x slot t)) + (t + (if (find-slot x slot) + (error "object does not own slot ~s" slot) + (error "no slot named ~s in this object" slot)))))) + +(defun slot-value (slot) +"Args: (slot) +Must be used in a method. Returns the value of current objects slot +named SLOT." + (get-slot-value (get-self) slot)) + +(defun slot-value-setf (slot value) + (set-slot-value (get-self) slot value)) + +(defsetf slot-value slot-value-setf) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Method Access Functions; +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun make-method-entry (x y) (cons x y)) +(defun method-entry-p (x) (consp x)) +(defun method-entry-key (x) (first x)) +(defun method-entry-method (x) (rest x)) +(defun set-method-entry-method (x v) (setf (rest x) v)) +(defsetf method-entry-method set-method-entry-method) + +;(defun find-own-method (x selector) +; (if (objectp x) (assoc selector (ls-object-methods x)))) +(defun find-own-method (x selector) + (if (objectp x) (assoc-eq selector (ls-object-methods x)))) + +(defun find-lsos-method (x selector) + (if (objectp x) + (let ((preclist (ls-object-preclist x))) + (dolist (object preclist) + (let ((method-entry (find-own-method object selector))) + (if method-entry (return method-entry))))))) + +(defun add-lsos-method (x selector value) + (check-object x) + (check-non-nil-symbol selector) + (let ((method-entry (find-own-method x selector))) + (if method-entry + (setf (method-entry-method method-entry) value) + (setf (ls-object-methods x) + (cons (make-method-entry selector value) (ls-object-methods x))))) + nil) + +(defun delete-method (x selector) + (check-object x) + (setf (ls-object-methods x) + (delete selector (ls-object-methods x) :key #'method-entry-key))) + +(defun get-message-method (x selector &optional no-err) + (check-object x) + (let ((method-entry (find-lsos-method x selector))) + (if (method-entry-p method-entry) + (method-entry-method method-entry) + (unless no-err (error "no method for selector ~s" selector))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Message Sending Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *current-preclist* nil) +(defvar *current-selector* nil) + +(defun sendmsg (object selector preclist args) + (let ((method-entry nil) + (method nil)) + + ;; look for the message in the precedence list + (loop + (setf method-entry (find-own-method (first preclist) selector)) + (if (or method-entry (not (consp preclist))) (return)) + (setf preclist (rest preclist))) + (cond + ((null method-entry) (error "no method for selector ~s" selector)) + ((not (method-entry-p method-entry)) (error "bad method entry")) + (t (setf method (method-entry-method method-entry)))) + + ;; invoke the method + (let ((*current-preclist* preclist) + (*current-selector* selector) + (*self* object)) + (multiple-value-prog1 + (apply method object args) + #+:constrainthooks (check-constraint-hooks object selector nil))))) + +;;;; built-in send function +(defun send (object selector &rest args) +"Args: (object selector &rest args) +Applies first method for SELECTOR found in OBJECT's precedence list to +OBJECT and ARGS." + (sendmsg object selector (ls-object-preclist object) args)) + +;;;; call-next-method - call inherited version of current method +(defun call-next-method (&rest args) +"Args (&rest args) +Funcalls next method for current selector and precedence list. Can only be +used in a method." + (sendmsg *self* *current-selector* (rest *current-preclist*) args)) + +;;;; call-method - call method belonging to another object on current object +(defun call-method (object selector &rest args) +"Args (object selector &rest args) +Funcalls method for SELECTOR found in OBJECT to SELF. Can only be used in +a method." + (sendmsg *self* selector (ls-object-preclist object) args)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Object Documentation Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun find-documentation (x sym add) + (if (objectp x) + (let ((doc (find-own-slot x 'documentation))) + (if (and (null doc) add) (add-slot x 'documentation nil)) + (if (slot-entry-p doc) (assoc sym (slot-entry-value doc)))))) + +(defun add-documentation (x sym value) + (check-object x) + (check-non-nil-symbol sym) + (let ((doc-entry (find-documentation x sym t))) + (cond + ((not (null doc-entry)) + (setf (rest doc-entry) value)) + (t + (set-slot-value x + 'documentation + (cons (cons sym value) + (get-slot-value x 'documentation)))))) + nil) + +(defun get-documentation (x sym) + (check-object x) + (dolist (object (ls-object-preclist x)) + (let ((doc-entry (find-documentation x sym nil))) + (if doc-entry (return (rest doc-entry)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; DEFMETH Macro +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro defmeth (object name arglist first &rest body) +"Syntax: (defmeth object name lambda-list [doc] {form}*) +OBJECT must evaluate to an existing object. Installs a method for NAME in +the value of OBJECT and installs DOC in OBJECTS's documentation." + (if (and body (stringp first)) + `(progn + (add-lsos-method ,object ,name + #'(lambda (self ,@arglist) (block ,name ,@body))) + (add-documentation ,object ,name ,first) + ,name) + `(progn + (add-lsos-method ,object ,name + #'(lambda (self ,@arglist) (block ,name ,first ,@body))) + ,name))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Prototype Construction Functions and Macros +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun find-instance-slots (x slots) + (let ((result (nreverse (delete-duplicates (copy-list slots))))) + (dolist (parent (ls-object-parents x) (nreverse result)) + (dolist (slot (get-slot-value parent 'instance-slots)) + (pushnew slot result))))) + +(defun get-initial-slot-value (object slot) + (let ((entry (find-slot object slot))) + (if (slot-entry-p entry) (slot-entry-value entry)))) + +(defun make-prototype (object name ivars cvars doc set) + (setf ivars (find-instance-slots object ivars)) + (add-slot object 'instance-slots ivars) + (add-slot object 'proto-name name) + + (dolist (slot ivars) + (add-slot object slot (get-initial-slot-value object slot))) + + (dolist (slot cvars) + (add-slot object slot nil)) + + (if (and doc (stringp doc)) + (add-documentation object 'proto doc)) + + (if set (set name object))) + +(defmacro defproto (name &optional ivars cvars parents doc) +"Syntax (defproto name &optional ivars cvars (parent *object*) doc) +Makes a new object prototype with instance variables IVARS, 'class' +variables CVARS and parents PARENT. PARENT can be a single object or +a list of objects. IVARS and CVARS must be lists." + (let ((obsym (gensym)) + (namesym (gensym)) + (parsym (gensym))) + `(progn + (let* ((,namesym ',name) + (,parsym ,parents) + (,obsym (make-basic-object (if (listp ,parsym) + ,parsym + (list ,parsym)) + nil))) + (make-prototype ,obsym ,namesym ,ivars ,cvars ,doc t) + ,namesym)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Initialize the Root Object +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(setf (ls-object-preclist *object*) (list *object*)) +(add-slot *object* 'instance-slots nil) +(add-slot *object* 'proto-name '*object*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; *OBJECT* Methods +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmeth *object* :isnew (&rest args) +"Method args: (&rest args) +Checks ARGS for keyword arguments matching slots and uses them to +initialize slots." + (if args + (dolist (slot-entry (ls-object-slots self)) + (let* ((slot (slot-entry-key slot-entry)) + (key (intern (symbol-name slot) (find-package 'keyword))) + (val (slot-value slot)) + (new-val (getf args key val))) + (unless (eq val new-val) (setf (slot-value slot) new-val))))) + self) + +(defmeth *object* :has-slot (slot &key own) +"Method args: (slot &optional own) +Returns T if slot SLOT exists, NIL if not. If OWN is not NIL +only checks the object; otherwise check the entire precedence list." + (let ((entry (if own (find-own-slot self slot) (find-slot self slot)))) + (if entry t nil))) + +(defmeth *object* :add-slot (slot &optional value) +"Method args: (slot &optional value) +Installs slot SLOT in object, if it does not already exist, and +sets its value to VLAUE." + (add-slot self slot value) + value) + +(defmeth *object* :delete-slot (slot) +"Method args: (slot) +Deletes slot SLOT from object if it exists." + (delete-slot self slot) + nil) + +(defmeth *object* :own-slots () +"Method args: () +Returns list of names of slots owned by object." + (mapcar #'slot-entry-key (ls-object-slots self))) + +(defmeth *object* :has-method (selector &key own) +"Method args: (selector &optional own) +Returns T if method for SELECTOR exists, NIL if not. If OWN is not NIL +only checks the object; otherwise check the entire precedence list." + (let ((entry (if own + (find-own-method self selector) + (find-lsos-method self selector)))) + (if entry t nil))) + +(defmeth *object* :add-method (selector method) +"Method args: (selector method) +Installs METHOD for SELECTOR in object." + (add-lsos-method self selector method) + nil) + +(defmeth *object* :delete-method (selector) +"Method args: (selector) +Deletes method for SELECTOR in object if it exists." + (delete-method self selector) + nil) + +(defmeth *object* :get-method (selector) +"Method args: (selector) +Returns method for SELECTOR symbol from object's precedence list." + (get-message-method self selector)) + +(defmeth *object* :own-methods () +"Method args () +Returns copy of selectors for methods owned by object." + (mapcar #'method-entry-key (ls-object-methods self))) + +(defmeth *object* :parents () +"Method args: () +Returns copy of parents list." + (copy-list (ls-object-parents self))) + +(defmeth *object* :precedence-list () +"Method args: () +Returns copy of the precedence list." + (copy-list (ls-object-preclist self))) + +(defmeth *object* :show (&optional (stream t)) +"Method Args: () +Prints object's internal data." + (format stream "Slots = ~s~%" (ls-object-slots self)) + (format stream "Methods = ~s~%" (ls-object-methods self)) + (format stream "Parents = ~s~%" (ls-object-parents self)) + (format stream "Precedence List = ~s~%" (ls-object-preclist self)) + nil) + +(defmeth *object* :reparent (&rest parents) +"Method args: (&rest parents) +Changes precedence list to correspond to PARENTS. Does not change descendants." + (make-basic-object parents self)) + +(defmeth *object* :make-prototype (name &optional ivars) + (make-prototype self name ivars nil nil nil) + self) + +(defmeth *object* :internal-doc (sym &optional new) +"Method args (topic &optional value) +Retrieves or installs documentation for topic." + (if new (add-documentation self sym new)) + (get-documentation self sym)) + +(defmeth *object* :new (&rest args) +"Method args: (&rest args) +Creates new object using self as prototype." + (let* ((object (make-object self))) + (if (slot-value 'instance-slots) + (dolist (s (slot-value 'instance-slots)) + (send object :add-slot s (slot-value s)))) + (apply #'send object :isnew args) + object)) + +(defmeth *object* :retype (proto &rest args) +"Method args: (proto &rest args) +Changes object to inherit directly from prototype PROTO. PROTO +must be a prototype and SELF must not be one." + (if (send self :has-slot 'instance-slots :own t) + (error "can't retype a prototype")) + (if (not (send proto :has-slot 'instance-slots :own t)) + (error "not a prototype - ~a" proto)) + (send self :reparent proto) + (dolist (s (send proto :slot-value 'instance-slots)) + (send self :add-slot s (slot-value s))) + (apply #'send self :isnew args) + self) + +(defmeth *object* :print (&optional (stream *standard-output*)) +"Method args: (&optional (stream *standard-output*)) +Default object printing method." + (cond + ((send self :has-slot 'proto-name) + (format stream + "#" + (ls-object-serial self) + (slot-value 'proto-name))) + (t (format stream "#" (ls-object-serial self))))) + +(defmeth *object* :slot-value (sym &optional (val nil set)) +"Method args: (sym &optional val) +Sets and retrieves value of slot named SYM. Sugnals an error if slot +does not exist." + (if set (setf (slot-value sym) val)) + (slot-value sym)) + +(defmeth *object* :slot-names () +"Method args: () +Returns list of slots available to the object." + (apply #'append + (mapcar #'(lambda (x) (send x :own-slots)) + (send self :precedence-list)))) + +(defmeth *object* :method-selectors () +"Method args: () +Returns list of method selectors available to object." + (apply #'append + (mapcar #'(lambda (x) (send x :own-methods)) + (send self :precedence-list)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Object Help Methods +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmeth *object* :doc-topics () +"Method args: () +Returns all topics with documentation for this object." + (remove-duplicates + (mapcar #'car + (apply #'append + (mapcar + #'(lambda (x) + (if (send x :has-slot 'documentation :own t) + (send x :slot-value (quote documentation)))) + (send self :precedence-list)))))) + +(defmeth *object* :documentation (topic &optional (val nil set)) +"Method args: (topic &optional val) +Retrieves or sets object documentation for topic." + (if set (send self :internal-doc topic val)) + (let ((val (dolist (i (send self :precedence-list)) + (let ((val (send i :internal-doc topic))) + (if val (return val)))))) + val)) + +(defmeth *object* :delete-documentation (topic) +"Method args: (topic) +Deletes object documentation for TOPIC." + (setf (slot-value 'documentation) + (remove :title nil :test #'(lambda (x y) (eql x (first y))))) + nil) + +(defmeth *object* :help (&optional topic) +"Method args: (&optional topic) +Prints help message for TOPIC, or genreal help if TOPIC is NIL." + (if topic + (let ((doc (send self :documentation topic))) + (cond + (doc (princ topic) (terpri) (princ doc) (terpri)) + (t (format t "Sorry, no help available on ~a~%" topic)))) + (let ((topics (stable-sort (copy-seq (send self :doc-topics)) + #'(lambda (x y) + (string-lessp (string x) (string y))))) + (proto-doc (send self :documentation 'proto))) + (if (send self :has-slot 'proto-name) + (format t "~s~%" (slot-value 'proto-name))) + (when proto-doc (princ proto-doc) (terpri)) + (format t "Help is available on the following:~%~%") + (dolist (i topics) (format t "~s " i)) + (terpri))) + (values)) + +(defmeth *object* :compile-method (name) +"Method args: (name) +Compiles method NAME unless it is already compiled. The object must +own the method." + (unless (send self :has-method name) + (error "No ~s method in this object" name)) + (unless (send self :has-method name :own t) + (error "Object does not own ~s method" name)) + (let ((fun (send self :get-method name))) + (unless (compiled-function-p fun) + (multiple-value-bind (form env) (function-lambda-expression fun) + (if env + (error + "method may have been defined in non-null environment")) + (send self :add-method name (compile nil form)))))) diff --git a/lspackages.lsp b/lspackages.lsp new file mode 100644 index 0000000..af61cb4 --- /dev/null +++ b/lspackages.lsp @@ -0,0 +1,244 @@ +;;;; lspackages -- Lisp-Stat package specifications +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +(provide "lspackages") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; +;;;;; LISP-STAT-OBJECT-SYSTEM Package +;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; lsobjects.lsp +;;;; + +#+:CLtL2 +(progn + (defpackage "LISP-STAT-OBJECT-SYSTEM" + (:nicknames "LS-OBJECTS" "LSOS") + (:use "COMMON-LISP") + (:shadow "CALL-NEXT-METHOD" "SLOT-VALUE")) + + (in-package lisp-stat-object-system)) + +#-:CLtL2 +(progn + (in-package 'lisp-stat-object-system + :nicknames '(ls-objects lsos) + :use '(lisp)) + + (shadow '(call-next-method slot-value))) + +(export '(ls-object objectp *object* kind-of-p make-object *message-hook* + *set-slot-hook* slot-value self send call-next-method call-method + defmeth defproto instance-slots proto-name)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; +;;;;; LISP-STAT-BASICS Package +;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; lsbasics.lsp +;;;; + +#+:CLtL2 +(progn + (defpackage "LISP-STAT-BASICS" + (:nicknames "LS-BASICS") + (:use "COMMON-LISP" "LISP-STAT-OBJECT-SYSTEM")) + + (in-package lisp-stat-basics)) +#-:CLtL2 +(in-package 'lisp-stat-basics + :nicknames '(ls-basics) + :use '(lisp lsos)) + +(shadowing-import (package-shadowing-symbols 'lisp-stat-object-system)) +(use-package 'lisp-stat-object-system) + +(export '(sequencep copy-vector copy-array iseq which repeat select + permute-array sum prod count-elements mean if-else + sample sort-data order rank)) + +;;;; +;;;; kclpatch.lsp +;;;; + +#+:kcl +(export '(function-lambda-expression realp fixnump)) + +;;;; +;;;; compound.lsp +;;;; + +(export '(compound-data-p map-elements compound-data-seq + compound-data-length element-seq compound-data-proto)) + +;;;; +;;;; dists.lsp +;;;; + +(export '(log-gamma uniform-rand normal-cdf normal-quant normal-dens + normal-rand bivnorm-cdf cauchy-cdf cauchy-quant cauchy-dens + cauchy-rand gamma-cdf gamma-quant gamma-dens gamma-rand + chisq-cdf chisq-quant chisq-dens chisq-rand beta-cdf beta-quant + beta-dens beta-rand t-cdf t-quant t-dens t-rand f-cdf f-quant + f-dens f-rand poisson-cdf poisson-quant poisson-pmf poisson-rand + binomial-cdf binomial-quant binomial-pmf binomial-rand)) + +;;;; +;;;; linalg.lsp +;;;; + +(export '(chol-decomp lu-decomp lu-solve determinant inverse sv-decomp + qr-decomp rcondest make-rotation spline kernel-dens kernel-smooth + fft make-sweep-matrix sweep-operator ax+y numgrad numhess + split-list eigen)) + +;;;; +;;;; matrices.lsp +;;;; + +(export '(matrixp num-rows num-cols matmult identity-matrix diagonal + row-list column-list inner-product outer-product cross-product + transpose bind-columns bind-rows)) + +;;;; +;;;; lsfloat.lsp +;;;; + +(export '(*stat-float-type* *stat-cfloat-type* *stat-float-template* + machine-epsilon)) + +;;;; +;;;; mclglue.lsp +;;;; + +#+:mcl +(import '(ccl:def-logical-directory ccl:ff-load ccl:deffcfun ccl:defccallable)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; +;;;;; LISP-STAT Package +;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; lsmath.lsp +;;;; + +#+:CLtL2 +(progn + (defpackage "LISP-STAT" + (:nicknames "LS" "STATS") + (:use "COMMON-LISP" "LISP-STAT-BASICS" "LISP-STAT-OBJECT-SYSTEM")) + + (in-package lisp-stat)) +#-:CLtL2 +(in-package 'lisp-stat + :nicknames '(ls stats) + :use '(lisp ls-basics lsos)) + +(shadowing-import (package-shadowing-symbols 'lisp-stat-object-system)) +(shadowing-import (package-shadowing-symbols 'lisp-stat-basics)) +(use-package 'lisp-stat-object-system) +(use-package 'lisp-stat-basics) + +(shadow '(expt + - * / ** mod rem abs 1+ 1- log exp sqrt sin cos tan + asin acos atan sinh cosh tanh asinh acosh atanh float random + truncate floor ceiling round minusp zerop plusp evenp oddp + < <= = /= >= > complex conjugate realpart imagpart phase + min max logand logior logxor lognot ffloor fceiling + ftruncate fround signum cis)) + +(export '(^ ** expt + - * / mod rem pmin pmax abs 1+ 1- log exp sqrt sin cos + tan asin acos atan sinh cosh tanh asinh acosh atanh float random + truncate floor ceiling round minusp zerop plusp evenp oddp < <= = + /= >= > complex conjugate realpart imagpart phase min max + logand logior logxor lognot ffloor fceiling ftruncate fround + signum cis)) + +(import 'ls-basics::install-rv-function) +(import '(ls-basics::rv-expt ls-basics::rv-+ ls-basics::rv-- + ls-basics::rv-* ls-basics::rv-/ ls-basics::rv-mod + ls-basics::rv-rem ls-basics::rv-pmin ls-basics::rv-pmax + ls-basics::rv-1+ ls-basics::rv-1- ls-basics::rv-exp + ls-basics::rv-log ls-basics::rv-sqrt ls-basics::rv-sin + ls-basics::rv-cos ls-basics::rv-tan ls-basics::rv-atan + ls-basics::rv-float ls-basics::rv-random ls-basics::rv-floor + ls-basics::rv-ceiling ls-basics::rv-truncate ls-basics::rv-round + ls-basics::rv-zerop ls-basics::rv-plusp ls-basics::rv-minusp + ls-basics::rv-oddp ls-basics::rv-evenp ls-basics::rv-< + ls-basics::rv-<= ls-basics::rv-= ls-basics::rv-/= + ls-basics::rv->= ls-basics::rv-> ls-basics::rv-complex + ls-basics::rv-realpart ls-basics::rv-imagpart + ls-basics::rv-conjugate)) + +(import '(ls-basics::base-expt ls-basics::base-log ls-basics::base-exp + ls-basics::base-sqrt ls-basics::base-sin ls-basics::base-cos + ls-basics::base-tan ls-basics::base-asin ls-basics::base-acos + ls-basics::base-atan ls-basics::base-sinh ls-basics::base-cosh + ls-basics::base-tanh ls-basics::base-asinh ls-basics::base-acosh + ls-basics::base-atanh ls-basics::base-float ls-basics::base-abs + ls-basics::base-phase ls-basics::base-ffloor + ls-basics::base-fceiling ls-basics::base-ftruncate + ls-basics::base-fround ls-basics::base-signum + ls-basics::base-cis)) + +(import '(ls-basics::make-rv-function ls-basics::make-rv-function-1)) + +;;;; +;;;; statistics.lsp +;;;; + +(export '(open-file-dialog read-data-file read-data-columns load-data + load-example *variables* *ask-on-redefine* def variables savevar + undef standard-deviation quantile median interquartile-range + fivnum covariance-matrix difference rseq matrix print-matrix solve + backsolve eigenvalues eigenvectors accumulate cumsum combine + lowess)) + +(import 'ls-basics::|base-lowess|) + +;;;; +;;;; regression.lsp +;;;; + +(export '(regression-model regression-model-proto x y intercept sweep-matrix + basis weights included total-sum-of-squares residual-sum-of-squares + predictor-names response-name case-labels)) + +;;;; +;;;; nonlin.lsp +;;;; + +(export '(nreg-model nreg-model-proto mean-function theta-hat epsilon + count-limit verbose)) + +;;;; +;;;; maximize.lsp +;;;; + +(export '(newtonmax nelmeadmax)) + +(import '(ls-basics::new-minfo-internals ls-basics::minfo-maximize)) + +;;;; +;;;; bayes.lsp +;;;; + +(export '(bayes-model bayes-model-proto bayes-internals)) + +;;;; +;;;; lstoplevel.lsp +;;;; + +#+:kcl +(import '(si::*quit-tag* si::*eof* si::*lisp-initialized* + si::reset-stack-limits si::break-current)) diff --git a/lstoplevel.lsp b/lstoplevel.lsp new file mode 100644 index 0000000..970eae0 --- /dev/null +++ b/lstoplevel.lsp @@ -0,0 +1,145 @@ +#+:CLtL2 +(in-package lisp-stat) +#-:CLtL2 +(in-package 'lisp-stat) + +;;;; +;;;; AKCL Top Level (Modified from AKCL source file unixport/kcltop.lsp) +;;;; + +#+:kcl +(import '(si::*quit-tag* si::*eof* si::*lisp-initialized* + si::reset-stack-limits si::break-current)) + +(defvar +) +(defvar ++) +(defvar +++) +(defvar -) +(defvar *) +(defvar **) +(defvar ***) +(defvar /) +(defvar //) +(defvar ///) + +#+:kcl +(defun ls-top-level () + (when (> (system:argc) 1) + (setq system:*system-directory* (system:argv 1))) + (let ((lslib (si:getenv "LSLIB"))) + (if lslib (setf *default-path* lslib))) + (format t + "AKCL (Austin Kyoto Common Lisp)~%~ + Contains Enhancements by W. Schelter~%~ + Lisp-Stat ~a, Copyright (c) by Luke Tierney, 1990~%~ + Type :q to continue after an error~2%" + *common-lisp-stat-version*) + (setq si::*ihs-top* 1) + + (in-package 'system::user) + (incf system::*ihs-top* 2) + (let ((+ nil) (++ nil) (+++ nil) + (- nil) + (* nil) (** nil) (*** nil) + (/ nil) (// nil) (/// nil)) + (setq *lisp-initialized* t) + (catch *quit-tag* (when (probe-file "init.lsp") (load "init.lsp"))) + (catch *quit-tag* (when (probe-file "statinit.lsp") (load "statinit.lsp"))) + (loop + (setq +++ ++ ++ + + -) + (format t "~%~a>" + (if (eq *package* (find-package 'user)) + "" + (package-name *package*))) + (reset-stack-limits) + (when (catch *quit-tag* + (setq - (locally (declare (notinline read)) + (read *standard-input* nil *eof*))) + (when (eq - *eof*) (bye)) + (let ((values (multiple-value-list + (locally (declare (notinline eval)) (eval -))))) + (setq /// // // / / values *** ** ** * * (car /)) + (fresh-line) + (dolist (val /) + (locally (declare (notinline prin1)) (prin1 val)) + (terpri)) + nil)) + (terpri *error-output*) + (break-current))))) + +;;;; +;;;; Macintosh CL Top Level +;;;; This does not quite properly work with the event loop of +;;;; the system. +;;;; + +#| +#+:mcl +(defun ls-init-top-level () + (in-package cl-user) + (setf + nil ++ nil +++ nil + - nil + * nil ** nil *** nil + / nil // nil /// nil) + (format t + "Lisp-Stat ~a, Copyright (c) by Luke Tierney, 1990~%~ + Type COMMAND-. to continue after an error~2%" + *common-lisp-stat-version*)) + +#+:mcl +(defun ls-top-level () + (catch :stat-abort + (catch :abort + (loop + (setq +++ ++ ++ + + -) + (format t "~%~a> " + (if (eq *package* (find-package 'cl-user)) + "" + (package-name *package*))) + (loop (if (listen *standard-input*) (return t)) + (event-dispatch)) + (setq - (locally (declare (notinline read)) + (read *standard-input* t))) + (if (consp -) (read-line *standard-input* t)) + (let ((*idle* nil) + (values (multiple-value-list + (locally (declare (notinline eval)) (eval -))))) + (setq /// // // / / values *** ** ** * * (car /)) + (fresh-line) + (dolist (val /) + (locally (declare (notinline prin1)) (prin1 val)) + (terpri)) + nil))))) +|# + +;;;; +;;;; EXCL (Allegro) Top Level +;;;; + +#+:excl +(defun ls-top-level-eval (expr) + (setq +++ ++ ++ + + - - expr) + (let ((values (multiple-value-list + (locally (declare (notinline eval)) (eval -))))) + (setq /// // // / / values *** ** ** * * (car /)) + (car values))) + +#+:excl +(defun ls-top-level () + (format t + "Lisp-Stat ~a, Copyright (c) by Luke Tierney, 1990~%~ + Type :reset to continue after an error~2%" + *common-lisp-stat-version*) + + (in-package 'user) + (let ((tpl:*eval* 'ls-top-level-eval) + (tpl:*prompt* " ") + (*read-default-float-format* *stat-float-type*) + (+ nil) (++ nil) (+++ nil) + (- nil) + (* nil) (** nil) (*** nil) + (/ nil) (// nil) (/// nil)) + (catch '*ls-quit-tag* (tpl:top-level-read-eval-print-loop)))) + +#+:excl +(defun exit-ls () (throw '*ls-quit-tag* nil)) diff --git a/makesys.excl b/makesys.excl new file mode 100644 index 0000000..185496e --- /dev/null +++ b/makesys.excl @@ -0,0 +1,13 @@ +(load "defsys") +(ls::load-stats) +(ls::use-stats) + +(setf *default-path* "/usr/statlocal/lib/xlispstat/") + +;; *** should force a gc here? + +(dumplisp :name "cls" + :checkpoint nil + :restart-actions (append (copy-list *restart-actions*) + (list (cons :eval '(ls::ls-top-level))))) + diff --git a/makesys.excl.dist b/makesys.excl.dist new file mode 100644 index 0000000..32c9b91 --- /dev/null +++ b/makesys.excl.dist @@ -0,0 +1,13 @@ +(load "defsys") +(ls::load-stats) +(ls::use-stats) + +(setf *default-path* "./") + +;; *** should force a gc here? + +(dumplisp :name "cls" + :checkpoint nil + :restart-actions (append (copy-list *restart-actions*) + (list (cons :eval '(ls::ls-top-level))))) + diff --git a/makesys.kcl b/makesys.kcl new file mode 100644 index 0000000..41fc852 --- /dev/null +++ b/makesys.kcl @@ -0,0 +1,11 @@ +(load "defsys") +(ls::load-stats) +(ls::use-stats) + +(defun si:top-level () + (in-package 'system::user) + (incf system::*ihs-top* 2) + (si:error-set (ls::ls-top-level))) + +(gbc nil) +(si:save-system "saved_kcls") diff --git a/matrices.lsp b/matrices.lsp new file mode 100644 index 0000000..8a22a8b --- /dev/null +++ b/matrices.lsp @@ -0,0 +1,287 @@ +;;;; matrices -- Basic matrix operations +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +(provide "matrices") + +;;;; +;;;; Package Setup +;;;; + +#+:CLtL2 +(in-package lisp-stat-basics) +#-:CLtL2 +(in-package 'lisp-stat-basics) + +(export '(matrixp num-rows num-cols matmult identity-matrix diagonal + row-list column-list inner-product outer-product cross-product + transpose bind-columns bind-rows)) + +(defun matrixp (x) +"Args: (x) +Returns T if X is a matrix, NIL otherwise." + (and (arrayp x) (= (array-rank x) 2))) + +(defun num-rows (x) +"Args: (x) +Returns number of rows in X." + (array-dimension x 0)) + +(defun num-cols (x) +"Args: (x) +Returns number of columns in X." + (array-dimension x 1)) + +(defun matmult (a b &rest args) +"Args: (a b &rest args) +Returns the matrix product of matrices a, b, etc. If a is a vector it is +treated as a row vector; if b is a vector it is treated as a column vector." + (let ((rtype (cond ((and (matrixp a) (matrixp b)) 'matrix) + ((and (sequencep a) (sequencep b)) 'number) + ((sequencep a) (if (consp a) 'list 'vector)) + ((sequencep b) (if (consp b) 'list 'vector))))) + + (if (sequencep a) + (setf a (vector-to-array (coerce a 'vector) (list 1 (length a))))) + (if (sequencep b) + (setf b (vector-to-array (coerce b 'vector) (list (length b) 1)))) + (if (not (= (array-dimension a 1) (array-dimension b 0))) + (error "dimensions do not match")) + (if args + (reduce #'matmult args :initial-value (matmult a b)) + (let* ((n (array-dimension a 0)) + (m (array-dimension b 1)) + (p (array-dimension a 1)) + (c (make-array (list n m))) + x) + (declare (fixnum n m p)) + (dotimes (i n) + (declare (fixnum i)) + (dotimes (j m) + (declare (fixnum j)) + (setq x 0) + (dotimes (k p) + (declare (fixnum k)) + (setq x (+ x + (* (aref a i k) (aref b k j))))) + (setf (aref c i j) x))) + (case rtype + (matrix c) + (number (aref c 0 0)) + (t (coerce (compound-data-seq c) rtype))))))) + +(defun identity-matrix (n) +"Args: (n) +Returns the identity matrix of rank N." + (let ((result (make-array (list n n) :initial-element 0))) + (dotimes (i n result) + (declare (fixnum i)) + (setf (aref result i i) 1)))) + +;; this thing is not very efficient at this point - too much coercing +(defun diagonal (x) +"Args: (x) +If X is a matrix, returns the diagonal of X. If X is a sequence, returns a +diagonal matrix of rank (length X) with diagonal elements eq to the elements +of X." + (cond ((matrixp x) + (let* ((n (min (num-rows x) (num-cols x))) + (result (make-array n))) + (dotimes (i n (coerce result 'list)) + (setf (aref result i) (aref x i i))))) + ((sequencep x) + (let* ((x (coerce x 'vector)) + (n (length x)) + (result (make-array (list n n) :initial-element 0))) + (dotimes (i n result) + (setf (aref result i i) (aref x i))))) + (t (error "argument must be a matrix or a sequence")))) + +(defun row-list (x) +"Args: (m) +Returns a list of the rows of M as vectors" + (check-matrix x) + (let ((m (num-rows x)) + (n (num-cols x)) + (result nil)) + (declare (fixnum m n)) + (flet ((get-row (k) + (declare (fixnum k)) + (let ((row (make-array n))) + (dotimes (i n row) + (declare (fixnum i)) + (setf (aref row i) (aref x k i)))))) + (dotimes (i m result) + (declare (fixnum i)) + (setf result (cons (get-row (- m i 1)) result)))))) + +(defun column-list (x) +"Args: (m) +Returns a list of the columns of M as vectors" + (check-matrix x) + (let ((m (num-rows x)) + (n (num-cols x)) + (result nil)) + (declare (fixnum m n)) + (flet ((get-col (k) + (declare (fixnum k)) + (let ((col (make-array m))) + (dotimes (i m col) + (declare (fixnum i)) + (setf (aref col i) (aref x i k)))))) + (dotimes (i n result) + (declare (fixnum i)) + (setf result (cons (get-col (- n i 1)) result)))))) + +(defun inner-product (x y) +"Args: (x y) +Returns inner product of sequences X and Y." + (check-sequence x) + (check-sequence y) + (let ((n (length x)) + (cx (make-next-element x)) + (cy (make-next-element y)) + (result 0)) + (declare (fixnum n)) + (if (/= n (length y)) (error "sequence lengths do not match")) + (dotimes (i n result) + (declare (fixnum i)) + (setf result + (+ result (* (get-next-element cx i) (get-next-element cy i))))))) + +(defun outer-product (x y &optional (f #'*)) +"Args: (x y &optional (fcn #'*)) +Returns the generalized outer product of x and y, using fcn. Tat is, the result +is a matrix of dimension ((length x) (length y)) and the (i j) element of the +result is computed as (apply fcn (aref x i) (aref y j))." + (let* ((x (coerce x 'vector)) + (y (coerce y 'vector)) + (m (length x)) + (n (length y)) + (a (make-array (list m n)))) + (declare (fixnum m n)) + (dotimes (i m a) + (declare (fixnum i)) + (dotimes (j n) + (declare (fixnum j)) + (setf (aref a i j) (funcall f (aref x i) (aref y j))))))) + +(defun cross-product (x) +"Args: (x) +If X is a matrix returns (matmult (transpose X) X). If X is a vector returns +(inner-product X X)." + (check-matrix x) + (let* ((n (num-rows x)) + (p (num-cols x)) + (c (make-array (list p p)))) + (declare (fixnum n p)) + (dotimes (i p c) + (declare (fixnum i)) + (dotimes (j (+ i 1)) + (declare (fixnum j)) + (let ((val 0)) + (dotimes (k n) + (declare (fixnum k)) + (incf val (* (aref x k i) (aref x k j)))) + (setf (aref c i j) val) + (setf (aref c j i) val)))))) + +(defun transpose-list (x) + (let ((m (length (first x)))) + (dolist (next x) + (if (not (consp next)) (error "not a list - ~a" x)) + (if (/= m (length next)) (error "sublists not the same length"))) + (do* ((cx (copy-list x)) + (result (make-list m)) + (next result (cdr next))) + ((null next) result) + (setf (first next) (mapcar #'first cx)) + (do ((next cx (cdr next))) + ((null next)) + (setf (first next) (rest (first next))))))) + +(defun transpose (x) +"Args: (m) +Returns the transpose of the matrix M." + (cond + ((consp x) (transpose-list x)) + (t + (check-matrix x) + (let* ((m (num-rows x)) + (n (num-cols x)) + (tx (make-array (list n m)))) + (declare (fixnum m n)) + (dotimes (i m tx) + (declare (fixnum i)) + (dotimes (j n) + (declare (fixnum j)) + (setf (aref tx j i) (aref x i j)))))))) + +(defun bind-columns (&rest args) +"Args (&rest args) +The ARGS can be matrices, vectors, or lists. Arguments are bound into a matrix +along their columns. +Example: (bind-columns #2a((1 2)(3 4)) #(5 6)) returns #2a((1 2 5)(3 4 6))" + (flet ((check-arg (x) + (if (not (or (sequencep x) (matrixp x))) + (error "bad argument type"))) + (arg-cols (x) (if (sequencep x) 1 (num-cols x))) + (arg-rows (x) (if (sequencep x) (length x) (num-rows x)))) + (dolist (x args) (check-arg x)) + (let ((m (arg-rows (first args))) + (n (arg-cols (first args)))) + (declare (fixnum m n)) + (dolist (x (rest args)) + (if (/= m (arg-rows x)) (error "column lengths do not match")) + (incf n (arg-cols x))) + (do* ((result (make-array (list m n))) + (args args (rest args)) + (firstcol 0) + (x (first args) (first args))) + ((null args) result) + (cond + ((sequencep x) + (let ((cx (make-next-element x))) + (dotimes (i m) + (setf (aref result i firstcol) (get-next-element cx i))))) + (t + (let ((k (arg-cols x))) + (dotimes (i m) + (dotimes (j k) + (setf (aref result i (+ firstcol j)) (aref x i j))))))) + (incf firstcol (arg-cols x)))))) + +(defun bind-rows (&rest args) +"Args (&rest args) +The ARGS can be matrices, vectors, or lists. Arguments are bound into a matrix +along their rows. +Example: (bind-rows #2a((1 2)(3 4)) #(5 6)) returns #2a((1 2)(3 4)(5 6))" + (flet ((check-arg (x) + (if (not (or (sequencep x) (matrixp x))) + (error "bad argument type"))) + (arg-cols (x) (if (sequencep x) (length x) (num-cols x))) + (arg-rows (x) (if (sequencep x) 1 (num-rows x)))) + (dolist (x args) (check-arg x)) + (let ((m (arg-rows (first args))) + (n (arg-cols (first args)))) + (declare (fixnum m n)) + (dolist (x (rest args)) + (if (/= n (arg-cols x)) (error "row lengths do not match")) + (incf m (arg-rows x))) + (do* ((result (make-array (list m n))) + (args args (rest args)) + (firstrow 0) + (x (first args) (first args))) + ((null args) result) + (cond + ((sequencep x) + (let ((cx (make-next-element x))) + (dotimes (i n) + (setf (aref result firstrow i) (get-next-element cx i))))) + (t + (let ((k (arg-rows x))) + (dotimes (i n) + (dotimes (j k) + (setf (aref result (+ firstrow j) i) (aref x j i))))))) + (incf firstrow (arg-rows x)))))) diff --git a/maximize.lsp b/maximize.lsp new file mode 100644 index 0000000..f4b56be --- /dev/null +++ b/maximize.lsp @@ -0,0 +1,326 @@ +(provide "maximize") + +#+:CLtL2 +(in-package lisp-stat) +#-:CLtL2 +(in-package 'lisp-stat) + +(export '(newtonmax nelmeadmax)) + +(import '(ls-basics::new-minfo-internals ls-basics::minfo-maximize)) + +;;;; +;;;; Mode Info Prototype +;;;; + +(defproto minfo-proto '(internals)) + +#+xlisp (send minfo-proto :add-method :isnew #'|minfo-isnew|) +#+xlisp (send minfo-proto :add-method :maximize #'|minfo-maximize|) +#+xlisp (send minfo-proto :add-method :loglaplace #'|minfo-loglap|) +#-xlisp +(defmeth minfo-proto :isnew (&rest args) + (setf (slot-value 'internals) (apply #'new-minfo-internals args))) +#-xlisp +(defmeth minfo-proto :maximize (&rest args) + (apply #'minfo-maximize (slot-value 'internals) args)) + +(defmeth minfo-proto :x () (aref (slot-value 'internals) 3)) +(defmeth minfo-proto :scale () (aref (slot-value 'internals) 4)) +(defmeth minfo-proto :derivstep () (aref (aref (slot-value 'internals) 9) 1)) +(defmeth minfo-proto :tilt () (aref (aref (slot-value 'internals) 9) 6)) + +(defmeth minfo-proto :f (&optional (val nil set)) + (when set + (send self :set-no-vals-supplied) + (setf (aref (slot-value 'internals) 0) val)) + (aref (slot-value 'internals) 0)) + +(defmeth minfo-proto :set-no-vals-supplied () + (setf (aref (aref (slot-value 'internals) 8) 6) 0)) + +(defmeth minfo-proto :exptilt (&optional (val nil set)) + (if set + (let ((old (send self :exptilt))) + (setf (aref (aref (slot-value 'internals) 8) 7) (if val 1 0)) + (if (and (not (or (and old val) (and (not old) (not val)))) + (/= (send self :tilt) 0.0)) + (send self :set-no-vals-supplied)))) + (= 1 (aref (aref (slot-value 'internals) 8) 7))) + +(defmeth minfo-proto :newtilt (&optional (val nil set)) + (when set + (setf (aref (aref (slot-value 'internals) 9) 7) (float val)) + (if (/= (send self :tilt) 0.0) (send self :set-no-vals-supplied))) + (aref (aref (slot-value 'internals) 9) 7)) + +(defmeth minfo-proto :gfuns (&optional (val nil set)) + (when set + (if (or (not (consp val)) + (not (every #'functionp val))) + (error "not all functions")) + (setf (aref (slot-value 'internals) 1) val) + (setf (aref (aref (slot-value 'internals) 8) 1) (length val)) + (setf (aref (slot-value 'internals) 10) (repeat 1.0 (length val))) + (if (/= (send self :tilt) 0.0) (send self :set-no-vals-supplied))) + (aref (slot-value 'internals) 1)) + +(defmeth minfo-proto :cfuns (&optional (val nil set)) + (when set + (if (or (not (consp val)) + (not (every #'functionp val))) + (error "not all functions")) + (setf (aref (slot-value 'internals) 2) val) + (setf (aref (aref (slot-value 'internals) 8) 2) (length val)) + (setf (aref (slot-value 'internals) 7) (repeat 0.0 (length val))) + (setf (aref (slot-value 'internals) 11) (repeat 0.0 (length val))) + (send self :set-no-vals-supplied)) + (aref (slot-value 'internals) 2)) + +(defmeth minfo-proto :ctarget (&optional (val nil set)) + (when set + (if (/= (length val) (length (send self :ctarget))) + (error "bad target length")) + (setf (aref (slot-value 'internals) 7) val)) + (aref (slot-value 'internals) 7)) + +(defmeth minfo-proto :fvals () + (let* ((fv (aref (slot-value 'internals) 5)) + (n (length (send self :x))) + (val (select fv 0)) + (grad (select fv (iseq 1 n))) + (hess (matrix (list n n) (select fv (iseq (+ 1 n) (+ n (* n n))))))) + (list val grad hess))) + +(defmeth minfo-proto :copy () + (let ((obj (make-object minfo-proto)) + (internals (copy-seq (slot-value 'internals)))) + (dotimes (i (length internals)) + (let ((x (aref internals i))) + (if (sequencep x) + (setf (aref internals i) (copy-seq x))))) + (send obj :add-slot 'internals internals) + obj)) + +(defmeth minfo-proto :derivscale () + (let* ((step (^ machine-epsilon (/ 1 6))) + (hess (numhess (send self :f) (send self :x) (send self :scale) step)) + (scale (pmax (abs (send self :x)) (sqrt (abs (/ (diagonal hess))))))) + (setf hess (numhess (send self :f) (send self :x) scale step)) + (setf scale (pmax (abs (send self :x)) (sqrt (abs (/ (diagonal hess)))))) + (setf (aref (slot-value 'internals) 4) scale) + (setf (aref (aref (slot-value 'internals) 9) 1) step))) + +(defmeth minfo-proto :verbose (&optional (val nil set)) + (when set + (setf (aref (aref (slot-value 'internals) 8) 5) + (cond ((integerp val) val) + ((null val) 0) + (t 1)))) + (aref (aref (slot-value 'internals) 8) 5)) + +(defmeth minfo-proto :backtrack (&optional (val nil set)) + (if set (setf (aref (aref (slot-value 'internals) 8) 4) (if val 1 0))) + (aref (aref (slot-value 'internals) 8) 4)) + +(defmeth minfo-proto :maxiter (&optional (val nil set)) + (if set (setf (aref (aref (slot-value 'internals) 8) 3) + (if (integerp val) val -1))) + (aref (aref (slot-value 'internals) 8) 3)) + +(defmeth minfo-proto :tiltscale (&optional (val nil set)) + (when set + (if (/= (length val) (length (send self :gfuns))) + (error "wrong size tilt scale sequence")) + (setf (aref (slot-value 'internals) 10) val)) + (aref (slot-value 'internals) 10)) + +;;;; +;;;; +;;;; Newton's Method with Backtracking +;;;; +;;;; + +(defun newtonmax (f start &key + scale + (derivstep -1.0) + (count-limit -1) + (verbose 1) + return-derivs) +"Args:(f start &key scale derivstep (verbose 1) return-derivs) +Maximizes F starting from START using Newton's method with backtracking. +If RETURN-DERIVS is NIL returns location of maximum; otherwise returns +list of location, unction value, gradient and hessian at maximum. +SCALE should be a list of the typical magnitudes of the parameters. +DERIVSTEP is used in numerical derivatives and VERBOSE controls printing +of iteration information. COUNT-LIMIT limits the number of iterations" + (let ((verbose (if verbose (if (integerp verbose) verbose 1) 0)) + (minfo (send minfo-proto :new f start + :scale scale :derivstep derivstep))) + (send minfo :maxiter count-limit) + (send minfo :derivscale) + (send minfo :maximize verbose) + (if return-derivs + (cons (send minfo :x) (- (send minfo :fvals))) + (send minfo :x)))) + +;;;; +;;;; +;;;; Nelder-Mead Simplex Method +;;;; +;;;; + +(defun nelmeadmax (f start &key + (size 1) + (epsilon (sqrt machine-epsilon)) + (count-limit 500) + (verbose t) + (alpha 1.0) + (beta 0.5) + (gamma 2.0) + (delta 0.5)) +"Args: (f start &key (size 1) (epsilon (sqrt machine-epsilon)) + (count-limit 500) (verbose t) alpha beta gamma delta) +Maximizes F using the Nelder-Mead simplex method. START can be a +starting simplex - a list of N+1 points, with N=dimension of problem, +or a single point. If start is a single point you should give the +size of the initial simplex as SIZE, a sequence of length N. Default is +all 1's. EPSILON is the convergence tolerance. ALPHA-DELTA can be used to +control the behavior of simplex algorithm." + (let ((s (send simplex-proto :new f start size))) + (do ((best (send s :best-point) (send s :best-point)) + (count 0 (+ count 1)) + next) + ((or (< (send s :relative-range) epsilon) (>= count count-limit)) + (if (and verbose (>= count count-limit)) + (format t "Iteration limit exceeded.~%")) + (send s :point-location (send s :best-point))) + (setf next (send s :extrapolate-from-worst (- alpha))) + (if (send s :is-worse best next) + (setf next (send s :extrapolate-from-worst gamma)) + (when (send s :is-worse next (send s :second-worst-point)) + (setf next (send s :extrapolate-from-worst beta)) + (if (send s :is-worse next (send s :worst-point)) + (send s :shrink-to-best delta)))) + (if verbose + (format t "Value = ~10g~%" + (send s :point-value (send s :best-point))))))) + + +;;; +;;; Simplex Prototype +;;; + +(defproto simplex-proto '(f simplex)) + +;;; +;;; Simplex Points +;;; + +(defmeth simplex-proto :make-point (x) + (let ((f (send self :f))) + (if f + (let ((val (funcall f x))) + (cons (if (consp val) (car val) val) x)) + (cons nil x)))) + +(defmeth simplex-proto :point-value (x) (car x)) + +(defmeth simplex-proto :point-location (x) (cdr x)) + +(defmeth simplex-proto :is-worse (x y) + (< (send self :point-value x) (send self :point-value y))) + +;;; +;;; Making New Simplices +;;; + +(defmeth simplex-proto :isnew (f start &optional size) + (send self :simplex start size) + (send self :f f)) + +;;; +;;; Slot Accessors and Mutators +;;; + +(defmeth simplex-proto :simplex (&optional new size) + (if new + (let ((simplex + (if (and (consp new) (sequencep (car new))) + (if (/= (length new) (+ 1 (length (car new)))) + (error "bad simplex data") + (copy-list new)) + (let* ((n (length new)) + (size (if size size (repeat 1 n))) + ; (pts (- (* 2 (uniform-rand (repeat n (+ n 1)))) 1))) + (diag (* 2 size (- (random (repeat 2 n)) .5))) + (pts (cons (repeat 0 n) + (mapcar #'(lambda (x) (coerce x 'list)) + (column-list (diagonal diag)))))) + (mapcar #'(lambda (x) (+ (* size x) new)) pts))))) + (setf (slot-value 'simplex) + (mapcar #'(lambda (x) (send self :make-point x)) simplex)) + (send self :sort-simplex))) + (slot-value 'simplex)) + +(defmeth simplex-proto :f (&optional f) + (when f + (setf (slot-value 'f) f) + (let ((simplex + (mapcar #'(lambda (x) (send self :point-location x)) + (send self :simplex)))) + (send self :simplex simplex))) + (slot-value 'f)) + +(defmeth simplex-proto :sort-simplex () + (if (send self :f) + (setf (slot-value 'simplex) + (sort (slot-value 'simplex) + #'(lambda (x y) (send self :is-worse x y)))))) + +;;; +;;; Other Methods Using List Representation of SImplex +;;; + +(defmeth simplex-proto :best-point () (car (last (send self :simplex)))) +(defmeth simplex-proto :worst-point () (first (send self :simplex))) +(defmeth simplex-proto :second-worst-point () (second (send self :simplex))) +(defmeth simplex-proto :replace-point (new old) + (let* ((simplex (send self :simplex)) + (n (position old simplex))) + (when n + (setf (nth n simplex) new) + (send self :sort-simplex)))) +(defmeth simplex-proto :mean-opposite-face (x) + (let ((face (mapcar #'(lambda (x) (send self :point-location x)) + (remove x (send self :simplex))))) + (/ (apply #'+ face) (length face)))) + +;;; +;;; Iteration Step Methods +;;; + +(defmeth simplex-proto :extrapolate-from-worst (fac) + (let* ((worst (send self :worst-point)) + (wloc (send self :point-location worst)) + (delta (- (send self :mean-opposite-face worst) wloc)) + (new (send self :make-point (+ wloc (* (- 1 fac) delta))))) + (if (send self :is-worse worst new) (send self :replace-point new worst)) + new)) + +(defmeth simplex-proto :shrink-to-best (fac) + (let* ((best (send self :best-point)) + (bloc (send self :point-location best))) + (dolist (x (copy-list (send self :simplex))) + (if (not (eq x best)) + (send self :replace-point + (send self :make-point + (+ bloc + (* fac + (- (send self :point-location x) bloc)))) + x))))) + +(defmeth simplex-proto :relative-range () + (let ((best (send self :point-value (send self :best-point))) + (worst (send self :point-value (send self :worst-point)))) + (* 2 (/ (abs (- best worst)) (+ 1 (abs best) (abs worst)))))) diff --git a/mclglue.lsp b/mclglue.lsp new file mode 100644 index 0000000..fe7c401 --- /dev/null +++ b/mclglue.lsp @@ -0,0 +1,468 @@ +;;;; mclglue -- Interface to C library +;;;; +;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for +;;;; unrestricted use. + +(require :ff) +;(require :traps) + +(in-package ls-basics) + +(import '(ccl:def-logical-directory ccl:ff-load ccl:deffcfun ccl:defccallable)) + +(def-logical-directory "mclslib;" "mcls;lib:") +(def-logical-directory "clib;" "ccl;:mpw:libraries:clibraries:") +(def-logical-directory "mpwlib;" "ccl;:mpw:libraries:libraries:") + +(defvar mcls-libs '("mclslib;clib.o" + "clib;CRuntime.o" + "mpwlib;Interface.o" + "clib;StdCLib.o" + "clib;CSANELib.o" + "clib;Math.o" + "clib;CInterface.o")) +(defvar mcls-libs-881 '("mclslib;clib.o" + "clib;CLib881.o" + "mpwlib;Interface.o" + "clib;StdCLib.o" + "clib;CSANELib881.o" + "clib;Math881.o" + "clib;CInterface.o")) + +(ff-load "mclslib;mclglue.c.o" + :ffenv-name 'mcls1 + :replace t + :libraries mcls-libs) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Basic Utilities +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Callback Support Functions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(deffcfun (ccl-store-integer "ccl_store_integer") (fixnum) :novalue) +(deffcfun (ccl-store-double "ccl_store_double") (float) :novalue) +(deffcfun (ccl-store-ptr "ccl_store_ptr") ((t :ptr)) :novalue) + +;;;; +;;;; Lisp-Managed Calloc/Free +;;;; + +#| +(defccallable lisp-new-ptr ((n :long) (:result :void)) + (ccl-store-ptr (ccl:_NewPtr :d0 n :a0))) +(deffcfun (register-new-ptr "register_new_ptr") ((t :ptr)) :novalue) +(register-new-ptr lisp-new-ptr) + +(defccallable lisp-free-ptr ((p :ptr) (:result :void)) + (ccl:_DisposPtr :a0 p :d0)) +(deffcfun (register-free-ptr "register_free_ptr") ((t :ptr)) :novalue) +(register-free-ptr lisp-free-ptr) +|# +;;;; +;;;; Storage Allocation Functions +;;;; + +(defun null-ptr-p (p) (ccl:%null-ptr-p p)) +(defun ptr-eq (p q) (= (ccl:%ptr-to-int p) (ccl:%ptr-to-int q))) + +(deffcfun (ccl-la-base-allocate "la_base_allocate") (fixnum fixnum) :ptr) +(defun la-base-allocate (n m) (ccl-la-base-allocate n m)) + +(deffcfun (ccl-la-base-free-alloc "la_base_free_alloc") ((t :ptr)) :novalue) +(defun la-base-free (p) (ccl-la-base-free-alloc p)) + +(deffcfun (ccl-la-mode-size "la_mode_size") (fixnum) :long) +(defun la-mode-size (mode) (ccl-la-mode-size mode)) + +;;;; +;;;; Callbacks for Internal Storage +;;;; + +(defccallable lisp-la-allocate ((n :long) (m :long) (:result :void)) + (ccl-store-ptr (la-allocate n m))) +(deffcfun (register-la-allocate "register_la_allocate") ((t :ptr)) :novalue) +(register-la-allocate lisp-la-allocate) +(deffcfun (la "la_allocate") (fixnum fixnum) :ptr) + +(defccallable lisp-la-free-alloc ((p :ptr) (:result :void)) (la-free p)) +(deffcfun (register-la-free-alloc "register_la_free_alloc") ((t :ptr)) :novalue) +(register-la-free-alloc lisp-la-free-alloc) +(deffcfun (lf "la_free_alloc") ((t :ptr)) :novalue) + +;;;; +;;;; Storage Access Functions +;;;; + +(deffcfun (ccl-la-get-integer "la_get_integer") ((t :ptr) fixnum) :long) +(defun la-get-integer (p i) (ccl-la-get-integer p i)) + +(deffcfun (ccl-la-get-double "la_get_double") ((t :ptr) fixnum) :float) +(defun la-get-double (p i) (ccl-la-get-double p i)) + +(deffcfun (ccl-la-get-complex-real "la_get_complex_real") ((t :ptr) fixnum) :float) +(defun la-get-complex-real (p i) (ccl-la-get-complex-real p i)) + +(deffcfun (ccl-la-get-complex-imag "la_get_complex_imag") ((t :ptr) fixnum) :float) +(defun la-get-complex-imag (p i) (ccl-la-get-complex-imag p i)) + +(defun la-get-complex (p i) + (complex (la-get-complex-real p i) (la-get-complex-imag p i))) + +(deffcfun (ccl-la-get-pointer "la_get_pointer") ((t :ptr) fixnum) :ptr) +(defun la-get-pointer (p i) (ccl-la-get-pointer p i)) + +;;;; +;;;; Storage Mutation Functions +;;;; + +(deffcfun (ccl-la-put-integer "la_put_integer") ((t :ptr) fixnum fixnum) :novalue) +(defun la-put-integer (p i x) (ccl-la-put-integer p i x)) + +(deffcfun (ccl-la-put-double "la_put_double") ((t :ptr) fixnum float) :novalue) +(defun la-put-double (p i x) (ccl-la-put-double p i (float x))) + +(deffcfun (ccl-la-put-complex "la_put_complex") ((t :ptr) fixnum float float) :novalue) +(defun la-put-complex (p i x y) (ccl-la-put-complex p i (float x) (float y))) + +(deffcfun (ccl-la-put-pointer "la_put_pointer") ((t :ptr) fixnum (t :ptr)) :novalue) +(defun la-put-pointer (p i q) (ccl-la-put-pointer p i q)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; XLISP Internal Error Message Emulation +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *buf* (make-string 1000)) + +(defun set-buf-char (i c) (setf (elt *buf* i) (code-char c))) + +(defun get-buf (&optional (n (position (code-char 0) *buf*))) + (subseq *buf* 0 n)) + +(deffcfun (register-set-buf-char "register_set_buf_char") ((t :ptr)) :novalue) +(defccallable ccl-set-buf-char ((n :long) (c :long) (:result :long)) + (set-buf-char n c)) +(register-set-buf-char ccl-set-buf-char) + +(deffcfun (register-print-buffer "register_print_buffer") ((t :ptr)) :novalue) +(defccallable ccl-print-buffer ((n :long) (type :long) (:result :long)) + (case type + (0 (princ (get-buf n))) + (1 (error (get-buf n)))) + n) +(register-print-buffer ccl-print-buffer) + +(deffcfun (stdputstr "stdputstr") ((string :by-reference)) :novalue) +(deffcfun (xlfail "xlfail") ((string :by-reference)) :novalue) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Lisp Interfaces to Linear Algebra Routines +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; +;;;; Cholesky Decomposition +;;;; + +(deffcfun (ccl-chol-decomp-front "ccl_chol_decomp_front") + ((t :ptr) fixnum (t :ptr)) + :long) +(defun chol-decomp-front (x y z) (ccl-chol-decomp-front x y z)) + +;;;; +;;;; LU Decomposition +;;;; + +(deffcfun (ccl-lu-decomp-front "ccl_lu_decomp_front") + ((t :ptr) fixnum (t :ptr) fixnum (t :ptr)) + :long) +(defun lu-decomp-front (x y z u v) (ccl-lu-decomp-front x y z u v)) + +(deffcfun (ccl-lu-solve-front "ccl_lu_solve_front") + ((t :ptr) fixnum (t :ptr) (t :ptr) fixnum) + :long) +(defun lu-solve-front (x y z u v) (ccl-lu-solve-front x y z u v)) + +(deffcfun (ccl-lu-inverse-front "ccl_lu_inverse_front") + ((t :ptr) fixnum (t :ptr) (t :ptr) fixnum (t :ptr)) + :long) +(defun lu-inverse-front (x y z u v w) (ccl-lu-inverse-front x y z u v w)) + +;;;; +;;;; SV Decomposition +;;;; + +(deffcfun (ccl-sv-decomp-front "ccl_sv_decomp_front") + ((t :ptr) fixnum fixnum (t :ptr) (t :ptr)) + :long) +(defun sv-decomp-front (x y z u v) (ccl-sv-decomp-front x y z u v)) + +;;;; +;;;; QR Decomposition +;;;; + +(deffcfun (ccl-qr-decomp-front "ccl_qr_decomp_front") + ((t :ptr) fixnum fixnum (t :ptr) (t :ptr) fixnum) + :long) +(defun qr-decomp-front (x y z u v w) (ccl-qr-decomp-front x y z u v w)) + +;;;; +;;;; Estimate of Condition Number for Lower Triangular Matrix +;;;; + +(deffcfun (ccl-rcondest-front "ccl_rcondest_front") ((t :ptr) fixnum) :float) +(defun rcondest-front (x y) (ccl-rcondest-front x y)) + +;;;; +;;;; Make Rotation Matrix +;;;; + +(deffcfun (ccl-make-rotation-front "ccl_make_rotation_front") + (fixnum (t :ptr) (t :ptr) (t :ptr) fixnum float) + :long) +(defun make-rotation-front (x y z u v w) + (ccl-make-rotation-front x y z u v (float w))) + +;;;; +;;;; Eigenvalues and Eigenvectors +;;;; + +(deffcfun (ccl-eigen-front "ccl_eigen_front") + ((t :ptr) fixnum (t :ptr) (t :ptr) (t :ptr)) + :long) +(defun eigen-front (x y z u v) (ccl-eigen-front x y z u v)) + +;;;; +;;;; Spline Interpolation +;;;; + +(deffcfun (ccl-range-to-rseq "ccl_range_to_rseq") + (fixnum (t :ptr) fixnum (t :ptr)) + :long) +(defun la-range-to-rseq (x y z u) (ccl-range-to-rseq x y z u)) + +(deffcfun (ccl-spline-front "ccl_spline_front") + (fixnum (t :ptr) (t :ptr) fixnum (t :ptr) (t :ptr) (t :ptr)) + :long) +(defun spline-front (x y z u v w a) (ccl-spline-front x y z u v w a)) + +;;;; +;;;; Kernel Density Estimators and Smoothers +;;;; + +(deffcfun (ccl-kernel-dens-front "ccl_kernel_dens_front") + ((t :ptr) fixnum float (t :ptr) (t :ptr) fixnum fixnum) + :long) +(defun kernel-dens-front (x y z u v w a) + (ccl-kernel-dens-front x y (float z) u v w a)) + +(deffcfun (ccl-kernel-smooth-front "ccl_kernel_smooth_front") + ((t :ptr) (t :ptr) fixnum float (t :ptr) (t :ptr) fixnum fixnum) + :long) +(defun kernel-smooth-front (x y z u v w a b) + (ccl-kernel-smooth-front x y z (float u) v w a b)) + +;;;; +;;;; Lowess Smoother Interface +;;;; + +(deffcfun (ccl-base-lowess-front "ccl_base_lowess_front") + ((t :ptr) (t :ptr) fixnum float fixnum float (t :ptr) (t :ptr) (t :ptr)) + :long) +(defun base-lowess-front (x y z u v w a b c) + (ccl-base-lowess-front x y z (float u) v (float w) a b c)) + +;;;; +;;;; FFT +;;;; + +(deffcfun (ccl-fft-front "ccl_fft_front") (fixnum (t :ptr) (t :ptr) fixnum) :long) +(defun fft-front (x y z u) (ccl-fft-front x y z u)) + +;;;; +;;;; Maximization and Numerical Derivatives +;;;; + +(defccallable ccl-maximize-callback ((n :long) + (px :ptr) + (pfval :ptr) + (pgrad :ptr) + (phess :ptr) + (pderivs :ptr) + (:result :void)) + (maximize-callback n px pfval pgrad phess pderivs)) +(deffcfun (register-maximize-callback "register_maximize_callback") + ((t :ptr)) + :novalue) +(register-maximize-callback ccl-maximize-callback) + +(deffcfun (ccl-numgrad-front "ccl_numgrad_front") + (fixnum (t :ptr) (t :ptr) float (t :ptr)) + :long) +(defun numgrad-front (x y z u v) (ccl-numgrad-front x y z (float u) v)) + +(deffcfun (ccl-numhess-front "ccl_numhess_front") + (fixnum (t :ptr) (t :ptr) (t :ptr) (t :ptr) float (t :ptr)) + :long) +(defun numhess-front (x y z u v w a) (ccl-numhess-front x y z u v (float w) a)) + +(deffcfun (ccl-minfo-maximize "ccl_minfo_maximize") + ((t :ptr) (t :ptr) (t :ptr) (t :ptr) (t :ptr) fixnum) + :long) +(defun base-minfo-maximize (x y z u v w) (ccl-minfo-maximize x y z u v w)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +;;;; Probability Distributions +;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;;; +;;;; C-callable uniform generator +;;;; + +(deffcfun (register-uni "register_uni") ((t :ptr)) :novalue) +(defccallable ccl-uni ((:result :long)) (ccl-store-double (random 1.0)) 0) +(register-uni ccl-uni) + +(defun one-uniform-rand () (random 1.0)) + +;;;; +;;;; Log-gamma function +;;;; + +(deffcfun (ccl-base-log-gamma "ccl_gamma") (float) :float) +(defun base-log-gamma (x) (ccl-base-log-gamma (float x))) + +;;;; +;;;; Normal distribution +;;;; + +(deffcfun (ccl-base-normal-cdf "ccl_normalcdf") (float) :float) +(defun base-normal-cdf (x) (ccl-base-normal-cdf (float x))) +(deffcfun (ccl-base-normal-quant "ccl_normalquant") (float) :float) +(defun base-normal-quant (x) (ccl-base-normal-quant (float x))) +(deffcfun (ccl-base-normal-dens "ccl_normaldens") (float) :float) +(defun base-normal-dens (x) (ccl-base-normal-dens (float x))) +(deffcfun (one-normal-rand "ccl_normalrand") () :float) +(deffcfun (ccl-base-bivnorm-cdf "ccl_bnormcdf") (float float float) :float) +(defun base-bivnorm-cdf (x y z) (ccl-base-bivnorm-cdf (float x) (float y) (float z))) + +;;;; +;;;; Cauchy distribution +;;;; + +(deffcfun (ccl-base-cauchy-cdf "ccl_cauchycdf") (float) :float) +(defun base-cauchy-cdf (x) (ccl-base-cauchy-cdf (float x))) +(deffcfun (ccl-base-cauchy-quant "ccl_cauchyquant") (float) :float) +(defun base-cauchy-quant (x) (ccl-base-cauchy-quant (float x))) +(deffcfun (ccl-base-cauchy-dens "ccl_cauchydens") (float) :float) +(defun base-cauchy-dens (x) (ccl-base-cauchy-dens (float x))) +(deffcfun (one-cauchy-rand "ccl_cauchyrand") () :float) + +;;;; +;;;; Gamma distribution +;;;; + +(deffcfun (ccl-base-gamma-cdf "ccl_gammacdf") (float float) :float) +(defun base-gamma-cdf (x y) (ccl-base-gamma-cdf (float x) (float y))) +(deffcfun (ccl-base-gamma-quant "ccl_gammaquant") (float float) :float) +(defun base-gamma-quant (x y) (ccl-base-gamma-quant (float x) (float y))) +(deffcfun (ccl-base-gamma-dens "ccl_gammadens") (float float) :float) +(defun base-gamma-dens (x y) (ccl-base-gamma-dens (float x) (float y))) +(deffcfun (ccl-gamma-rand "ccl_gammarand") (float) :float) +(defun one-gamma-rand (x) (ccl-gamma-rand (float x))) + +;;;; +;;;; Chi-square distribution +;;;; + +(deffcfun (ccl-base-chisq-cdf "ccl_chisqcdf") (float float) :float) +(defun base-chisq-cdf (x y) (ccl-base-chisq-cdf (float x) (float y))) +(deffcfun (ccl-base-chisq-quant "ccl_chisqquant") (float float) :float) +(defun base-chisq-quant (x y) (ccl-base-chisq-quant (float x) (float y))) +(deffcfun (ccl-base-chisq-dens "ccl_chisqdens") (float float) :float) +(defun base-chisq-dens (x y) (ccl-base-chisq-dens (float x) (float y))) +(deffcfun (ccl-chisq-rand "ccl_chisqrand") (float) :float) +(defun one-chisq-rand (x) (ccl-chisq-rand (float x))) + +;;;; +;;;; Beta distribution +;;;; + +(deffcfun (ccl-base-beta-cdf "ccl_betacdf") (float float float) :float) +(defun base-beta-cdf (x y z) (ccl-base-beta-cdf (float x) (float y) (float z))) +(deffcfun (ccl-base-beta-quant "ccl_betaquant") (float float float) :float) +(defun base-beta-quant (x y z) (ccl-base-beta-quant (float x) (float y) (float z))) +(deffcfun (ccl-base-beta-dens "ccl_betadens") (float float float) :float) +(defun base-beta-dens (x y z) (ccl-base-beta-dens (float x) (float y) (float z))) +(deffcfun (ccl-beta-rand "ccl_betarand") (float float) :float) +(defun one-beta-rand (x y) (ccl-beta-rand (float x) (float y))) + +;;;; +;;;; t distribution +;;;; + +(deffcfun (ccl-base-t-cdf "ccl_tcdf") (float float) :float) +(defun base-t-cdf (x y) (ccl-base-t-cdf (float x) (float y))) +(deffcfun (ccl-base-t-quant "ccl_tquant") (float float) :float) +(defun base-t-quant (x y) (ccl-base-t-quant (float x) (float y))) +(deffcfun (ccl-base-t-dens "ccl_tdens") (float float) :float) +(defun base-t-dens (x y) (ccl-base-t-dens (float x) (float y))) +(deffcfun (ccl-t-rand "ccl_trand") (float) :float) +(defun one-t-rand (x) (ccl-t-rand (float x))) + +;;;; +;;;; F distribution +;;;; + +(deffcfun (ccl-base-f-cdf "ccl_fcdf") (float float float) :float) +(defun base-f-cdf (x y z) (ccl-base-f-cdf (float x) (float y) (float z))) +(deffcfun (ccl-base-f-quant "ccl_fquant") (float float float) :float) +(defun base-f-quant (x y z) (ccl-base-f-quant (float x) (float y) (float z))) +(deffcfun (ccl-base-f-dens "ccl_fdens") (float float float) :float) +(defun base-f-dens (x y z) (ccl-base-f-dens (float x) (float y) (float z))) +(deffcfun (ccl-f-rand "ccl_frand") (float float) :float) +(defun one-f-rand (x y) (ccl-f-rand (float x) (float y))) + +;;;; +;;;; Poisson distribution +;;;; + +(deffcfun (ccl-base-poisson-cdf "ccl_poissoncdf") (float float) :float) +(defun base-poisson-cdf (x y) (ccl-base-poisson-cdf (float x) (float y))) +(deffcfun (ccl-base-poisson-quant "ccl_poissonquant") (float float) :long) +(defun base-poisson-quant (x y) (ccl-base-poisson-quant (float x) (float y))) +(deffcfun (ccl-base-poisson-pmf "ccl_poissonpmf") (fixnum float) :float) +(defun base-poisson-pmf (x y) (ccl-base-poisson-pmf x (float y))) +(deffcfun (ccl-poisson-rand "ccl_poissonrand") (float) :long) +(defun one-poisson-rand (x) (ccl-poisson-rand (float x))) + +;;;; +;;;; Binomial distribution +;;;; + +(deffcfun (ccl-base-binomial-cdf "ccl_binomialcdf") (float fixnum float) :float) +(defun base-binomial-cdf (x y z) (ccl-base-binomial-cdf (float x) y (float z))) +(deffcfun (ccl-base-binomial-quant "ccl_binomialquant") (float fixnum float) :long) +(defun base-binomial-quant (x y z) (ccl-base-binomial-quant (float x) y (float z))) +(deffcfun (ccl-base-binomial-pmf "ccl_binomialpmf") (fixnum fixnum float) :float) +(defun base-binomial-pmf (x y z) (ccl-base-binomial-pmf x y (float z))) +(deffcfun (ccl-binomial-rand "ccl_binomialrand") (fixnum float) :long) +(defun one-binomial-rand (x y) (ccl-binomial-rand x (float y))) diff --git a/nonlin.lsp b/nonlin.lsp new file mode 100644 index 0000000..81ee14d --- /dev/null +++ b/nonlin.lsp @@ -0,0 +1,286 @@ +;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney +;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz +;;;; You may give out copies of this software; for conditions see the file +;;;; COPYING included with this distribution. + +(provide "nonlin") + +#+:CLtL2 +(in-package lisp-stat) +#-:CLtL2 +(in-package 'lisp-stat) + +(export '(nreg-model nreg-model-proto mean-function theta-hat epsilon + count-limit verbose)) + + +;;;; +;;;; +;;;; Nonlinear Regression Model Prototype +;;;; +;;;; + +(defproto nreg-model-proto + '(mean-function theta-hat epsilon count-limit verbose) + '() + regression-model-proto) + +(defun nreg-model (mean-function y theta + &key + (epsilon .0001) + (print t) + (count-limit 20) + parameter-names + response-name + case-labels + weights + included + (verbose print)) +"Args: (mean-function y theta &key (epsilon .0001) (count-limit 20) + (print t) parameter-names response-name case-labels + weights included (vetbose print)) +Fits nonlinear regression model with MEAN-FUNCTION and response Y using initial +parameter guess THETA. Returns model object." + (let ((m (send nreg-model-proto :new))) + (send m :mean-function mean-function) + (send m :y y) + (send m :new-initial-guess theta) + (send m :epsilon epsilon) + (send m :count-limit count-limit) + (send m :parameter-names parameter-names) + (send m :response-name response-name) + (send m :case-labels case-labels) + (send m :weights weights) + (send m :included included) + (send m :verbose verbose) + (if print (send m :display)) + m)) + +(defmeth nreg-model-proto :save () +"Message args: () +Returns an expression that will reconstruct the regression model." + `(nreg-model ',(send self :mean-function) + ',(send self :y) + ',(send self :coef-estimates) + :epsilon ',(send self :epsilon) + :count-limit ',(send self :count-limit) + :predictor-names ',(send self :predictor-names) + :response-name ',(send self :response-name) + :case-labels ',(send self :case-labels) + :weights ',(send self :weights) + :included ',(send self :included) + :verbose ',(send self :verbose))) + +;;; +;;; Computing Method +;;; + +(defmeth nreg-model-proto :compute () +"Message args: () +Recomputes the estimates. For internal use by other messages" + (let* ((y (send self :y)) + (weights (send self :weights)) + (inc (if-else (send self :included) 1 0)) + (w (if weights (* inc weights) inc))) + (setf (slot-value 'theta-hat) + (nlreg (send self :mean-function) + y + (slot-value 'theta-hat) + (send self :epsilon) + (send self :count-limit) + w + (send self :verbose))) + (setf (slot-value 'x) + (funcall (make-jacobian (slot-value 'mean-function) + (length (slot-value 'theta-hat))) + (slot-value 'theta-hat))) + (setf (slot-value 'intercept) nil) + (call-next-method) + (let ((r (send self :residuals))) + (setf (slot-value 'residual-sum-of-squares) + (sum (* inc r r)))))) + +;;; +;;; Slot Accessors and Mutators +;;; + +(defmeth nreg-model-proto :new-initial-guess (guess) +"Message args: (guess) +Sets a new initial uess for parmeters." + (setf (slot-value 'theta-hat) guess) + (send self :needs-computing t)) + +(defmeth nreg-model-proto :theta-hat () +"Message args: () +Returns current parameter estimate." + (if (send self :needs-computing) (send self :compute)) + (coerce (slot-value 'theta-hat) 'list)) + +(defmeth nreg-model-proto :mean-function (&optional f) +"Message args: (&optional f) +With no argument returns the mean function as supplied to m. With an +argument F sets the mean function of m to F and recomputes the +estimates." + (when (and f (functionp f)) + (setf (slot-value 'mean-function) f) + (send self :needs-computing t)) + (slot-value 'mean-function)) + +(defmeth nreg-model-proto :epsilon (&optional eps) +"Message args: (&optional eps) +With no argument returns the tolerance as supplied to m. With an argument +EPS sets the tolerance of m to EPS and recomputes the estimates." + (when (and eps (numberp eps)) + (setf (slot-value 'epsilon) eps) + (send self :needs-computing t)) + (slot-value 'epsilon)) + +(defmeth nreg-model-proto :count-limit (&optional count) +"Message args: (&optional new-count) +With no argument returns the iteration count limit as supplied to m. With +an argument COUNT sets the limit to COUNT and recomputes the +estimates." + (when (and count (numberp count)) + (setf (slot-value 'count-limit) count) + (send self :needs-computing t)) + (slot-value 'count-limit)) + +(defmeth nreg-model-proto :parameter-names (&optional (names nil set)) +"Method args: (&optional names) +Sets or returns parameter names." + (if set (setf (slot-value 'predictor-names) names)) + (let ((p-names (slot-value 'predictor-names)) + (p (length (slot-value 'theta-hat)))) + (if (not (and p-names (= p (length p-names)))) + (setf (slot-value 'predictor-names) + (mapcar #'(lambda (a) (format nil "Parameter ~a" a)) + (iseq 0 (- p 1)))))) + (slot-value 'predictor-names)) + +(defmeth nreg-model-proto :verbose (&optional (val nil set)) +"Method args: (&optional val) +Sets or retrieves verbose setting. If T iteration info is printed during +optimization." + (if set (setf (slot-value 'verbose) val)) + (slot-value 'verbose)) + +;;; +;;; Overrides for Linear Regression Methods +;;; + +(defmeth nreg-model-proto :x () +"Message args: () +Returns the Jacobian matrix at theta-hat." + (call-next-method)) + +(defmeth nreg-model-proto :intercept (&rest args) +"Message args: () +Always returns nil. (For compatibility with linear regression.)" + nil) + +(defmeth nreg-model-proto :fit-values () +"Message args: () +Returns the fitted values for the model." + (coerce (funcall (send self :mean-function) (send self :theta-hat)) + 'list)) + +(defmeth nreg-model-proto :coef-estimates (&optional guess) +"Message args: (&optional guess) +With no argument returns the current parameter estimate. With an +argument GUESS takes it as a new initial guess and recomputes +the estimates." + (if guess (send self :new-initial-guess guess)) + (send self :theta-hat)) + +(defmeth nreg-model-proto :predictor-names () (send self :parameter-names)) + +;;;; +;;;; +;;;; Linear Regression Coefficients +;;;; +;;;; + +(defun regression-coefficients (x y &key (intercept T) weights) +"Args: (x y &key (intercept T) weights) +Returns the coefficients of the regression of the sequence Y on the columns of +the matrix X." + (let* ((m (if weights + (make-sweep-matrix x y weights) + (make-sweep-matrix x y))) + (n (array-dimension x 1))) + (coerce (compound-data-seq + (if intercept + (select (car (sweep-operator m (iseq 1 n))) + (1+ n) + (iseq 0 n)) + (select (car (sweep-operator m (iseq 0 n))) + (1+ n) + (iseq 1 n)))) + 'vector))) + +;;;; +;;;; +;;;; Nonlinear Regression Functions +;;;; +;;;; +(defun nlreg1 (f j y initial-beta epsilon count-limit weights verbose) +"Args: (mean-function jacobian y initial-beta + epsilon count-limit weights verbose) +MEAN-FUNCTION returns the mean response vector for a given parameter vector. +JACOBIAN returns the jacobian of MEAN-FUNCTION at a given parameter vector. +Y is the observed response vector. Returns the estimated parameter vector +obtained by a Gauss-Newton algorithm with backtracking that continues until +the COUNT-LIMIT is reached or no component of the parameter vector changes +by more than EPSILON." + (labels ((rss (beta) ; residual sum of squares + (let ((res (- y (funcall f beta)))) + (sum (if weights (* res res weights) (* res res))))) + (next-beta (beta delta rss) ; next beta by backtracking + (do* ((lambda 1 (/ lambda 2)) + (new-rss (rss (+ beta delta)) + (rss (+ beta (* lambda delta))))) + ((or (< new-rss rss) (< lambda .0001)) + (if (>= lambda .0001) + (+ beta (* lambda delta)) + beta))))) + (do* ((delbeta (regression-coefficients + (funcall j initial-beta) + (- y (funcall f initial-beta)) + :intercept nil + :weights weights) + (regression-coefficients + (funcall j beta) + (- y (funcall f beta)) + :intercept nil + :weights weights)) + (beta initial-beta (next-beta beta delbeta rss)) + (rss (rss beta) (rss beta)) + (count 0 (1+ count))) + ((or (> count count-limit) (> epsilon (max (abs delbeta)))) + (if (and verbose (> count count-limit)) + (format t "Iteration limit exceeded.~%")) + beta) + (if verbose (format t "Residual sum of squares: ~10g~%" rss))))) + +(defun make-jacobian (f n) +"Args: (f n) +F is a function of an N-vector. Returns a function that approximates the +jacobian function iof F by a symmetric difference." + (let* ((h .0001) + (del (* h (column-list (identity-matrix n))))) + #'(lambda (b) + (let ((b+ (mapcar #'(lambda (x) (+ b x)) del)) + (b- (mapcar #'(lambda (x) (- b x)) del))) + (apply #'bind-columns (/ (- (mapcar f b+) (mapcar f b-)) (* 2 h))))))) + +(defun nlreg (f y guess &optional + (epsilon .0001) (count-limit 20) weights verbose) +"Args: (mean-function y guess &optional + (epsilon .0001) (count-limit 20) weights verbose) +MEAN-FUNCTION returns the mean response vector for a given parameter vector. +Y is the observed response vector. Returns the estimated parameter vector +obtained by a Gauss-Newton algorithm that continues until the ITERATION-LIMIT +is reached or no component of the parameter vector changes by more than +EPSILON. The jacobian of MEAN-FUNCTION is approximated by a symmetric difference." + (nlreg1 f (make-jacobian f (length guess)) y guess + epsilon count-limit weights verbose)) diff --git a/num_sfun.c b/num_sfun.c new file mode 100644 index 0000000..6e328a3 --- /dev/null +++ b/num_sfun.c @@ -0,0 +1,655 @@ +/* +(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. +Copying of this file is authorized to users who have executed the true and +proper "License Agreement for Kyoto Common LISP" with SIGLISP. +*/ + +#include "include.h" +#include "num_include.h" + +object imag_unit, minus_imag_unit, imag_two; + +int +fixnum_expt(x, y) +{ + int z; + + z = 1; + while (y > 0) + if (y%2 == 0) { + x *= x; + y /= 2; + } else { + z *= x; + --y; + } + return(z); +} + +object +number_exp(x) +object x; +{ + double exp(); + + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat(exp(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)exp((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(exp(lf(x)))); + + case t_complex: + { + object y, y1; + object number_sin(), number_cos(); + vs_mark; + + y = x->cmp.cmp_imag; + x = x->cmp.cmp_real; + x = number_exp(x); + vs_push(x); + y1 = number_cos(y); + vs_push(y1); + y = number_sin(y); + vs_push(y); + y = make_complex(y1, y); + vs_push(y); + x = number_times(x, y); + vs_reset; + return(x); + } + + default: + FEwrong_type_argument(Snumber, x); + } +} + +object +number_expt(x, y) +object x, y; +{ + enum type tx, ty; + object z, number_nlog(); + vs_mark; + + tx = type_of(x); + ty = type_of(y); + if (ty == t_fixnum && fix(y) == 0) + switch (tx) { + case t_fixnum: case t_bignum: case t_ratio: + return(small_fixnum(1)); + + case t_shortfloat: + return(make_shortfloat((shortfloat)1.0)); + + case t_longfloat: + return(make_longfloat(1.0)); + + case t_complex: + z = number_expt(x->cmp.cmp_real, y); + vs_push(z); + z = make_complex(z, small_fixnum(0)); + vs_reset; + return(z); + + default: + FEwrong_type_argument(Snumber, x); + } + if (number_zerop(x)) { + if (!number_plusp(ty==t_complex?y->cmp.cmp_real:y)) + FEerror("Cannot raise zero to the power ~S.", 1, y); + return(number_times(x, y)); + } + if (ty == t_fixnum || ty == t_bignum) { + if (number_minusp(y)) { + z = number_negate(y); + vs_push(z); + z = number_expt(x, z); + vs_push(z); + z = number_divide(small_fixnum(1), z); + vs_reset; + return(z); + } + z = small_fixnum(1); + vs_push(z); + vs_push(Cnil); + vs_push(Cnil); + while (number_plusp(y)) + if (number_evenp(y)) { + x = number_times(x, x); + vs_top[-1] = x; + y = integer_divide1(y, small_fixnum(2)); + vs_top[-2] = y; + } else { + z = number_times(z, x); + vs_top[-3] = z; + y = number_minus(y, small_fixnum(1)); + vs_top[-2] = y; + } + vs_reset; + return(z); + } + z = number_nlog(x); + vs_push(z); + z = number_times(z, y); + vs_push(z); + z = number_exp(z); + vs_reset; + return(z); +} + +object +number_nlog(x) +object x; +{ + double log(); + object r, i, a, p, number_sqrt(), number_atan2(); + vs_mark; + + if (type_of(x) == t_complex) { + r = x->cmp.cmp_real; + i = x->cmp.cmp_imag; + goto COMPLEX; + } + if (number_zerop(x)) + FEerror("Zero is the logarithmic singularity.", 0); + if (number_minusp(x)) { + r = x; + i = small_fixnum(0); + goto COMPLEX; + } + switch (type_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat(log(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)log((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(log(lf(x)))); + + default: + FEwrong_type_argument(Snumber, x); + } + +COMPLEX: + a = number_times(r, r); + vs_push(a); + p = number_times(i, i); + vs_push(p); + a = number_plus(a, p); + vs_push(a); + a = number_nlog(a); + vs_push(a); + a = number_divide(a, small_fixnum(2)); + vs_push(a); + p = number_atan2(i, r); + vs_push(p); + x = make_complex(a, p); + vs_reset; + return(x); +} + +object +number_log(x, y) +object x, y; +{ + object z; + vs_mark; + + if (number_zerop(y)) + FEerror("Zero is the logarithmic singularity.", 0); + if (number_zerop(x)) + return(number_times(x, y)); + x = number_nlog(x); + vs_push(x); + y = number_nlog(y); + vs_push(y); + z = number_divide(y, x); + vs_reset; + return(z); +} + +object +number_sqrt(x) +object x; +{ + object z; + double sqrt(); + vs_mark; + + if (type_of(x) == t_complex) + goto COMPLEX; + if (number_minusp(x)) + goto COMPLEX; + switch (type_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat(sqrt(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)sqrt((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(sqrt(lf(x)))); + + default: + FEwrong_type_argument(Snumber, x); + } + +COMPLEX: + z = make_ratio(small_fixnum(1), small_fixnum(2)); + vs_push(z); + z = number_expt(x, z); + vs_reset; + return(z); +} + +object +number_atan2(y, x) +object y, x; +{ + object z; + double atan(), dy, dx, dz; + + dy = number_to_double(y); + dx = number_to_double(x); + if (dx > 0.0) + if (dy > 0.0) + dz = atan(dy / dx); + else if (dy == 0.0) + dz = 0.0; + else + dz = -atan(-dy / dx); + else if (dx == 0.0) + if (dy > 0.0) + dz = PI / 2.0; + else if (dy == 0.0) + FEerror("Logarithmic singularity.", 0); + else + dz = -PI / 2.0; + else + if (dy > 0.0) + dz = PI - atan(dy / -dx); + else if (dy == 0.0) + dz = PI; + else + dz = -PI + atan(-dy / -dx); + z = make_longfloat(dz); + return(z); +} + +object +number_atan(y) +object y; +{ + object z, z1; + vs_mark; + + if (type_of(y) == t_complex) { + z = number_times(imag_unit, y); + vs_push(z); + z = one_plus(z); + vs_push(z); + z1 = number_times(y, y); + vs_push(z1); + z1 = one_plus(z1); + vs_push(z1); + z1 = number_sqrt(z1); + vs_push(z1); + z = number_divide(z, z1); + vs_push(z); + z = number_nlog(z); + vs_push(z); + z = number_times(minus_imag_unit, z); + vs_reset; + return(z); + } + return(number_atan2(y, small_fixnum(1))); +} + +object +number_sin(x) +object x; +{ + double sin(); + + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat(sin(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)sin((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(sin(lf(x)))); + + case t_complex: + { + object r; + object x0, x1, x2; + vs_mark; + + x0 = number_times(imag_unit, x); + vs_push(x0); + x0 = number_exp(x0); + vs_push(x0); + x1 = number_times(minus_imag_unit, x); + vs_push(x1); + x1 = number_exp(x1); + vs_push(x1); + x2 = number_minus(x0, x1); + vs_push(x2); + r = number_divide(x2, imag_two); + + vs_reset; + return(r); + } + + default: + FEwrong_type_argument(Snumber, x); + + } +} + +object +number_cos(x) +object x; +{ + double cos(); + + switch (type_of(x)) { + + case t_fixnum: + case t_bignum: + case t_ratio: + return(make_longfloat(cos(number_to_double(x)))); + + case t_shortfloat: + return(make_shortfloat((shortfloat)cos((double)(sf(x))))); + + case t_longfloat: + return(make_longfloat(cos(lf(x)))); + + case t_complex: + { + object r; + object x0, x1, x2; + vs_mark; + + x0 = number_times(imag_unit, x); + vs_push(x0); + x0 = number_exp(x0); + vs_push(x0); + x1 = number_times(minus_imag_unit, x); + vs_push(x1); + x1 = number_exp(x1); + vs_push(x1); + x2 = number_plus(x0, x1); + vs_push(x2); + r = number_divide(x2, small_fixnum(2)); + + vs_reset; + return(r); + } + + default: + FEwrong_type_argument(Snumber, x); + + } +} + +object +number_tan(x) +object x; +{ + object r, s, c; + vs_mark; + + s = number_sin(x); + vs_push(s); + c = number_cos(x); + vs_push(c); + if (number_zerop(c) == TRUE) + FEerror("Cannot compute the tangent of ~S.", 1, x); + r = number_divide(s, c); + vs_reset; + return(r); +} + +object +number_asin(x) + object x; +{ + double asin(); + double dx; + + /* check for a real argument in [-1,1] */ + if (type_of(x) != t_complex) { + switch (type_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + dx = number_to_double(x); + break; + case t_shortfloat: + dx = sf(x); + break; + case t_longfloat: + dx = lf(x); + break; + default: + FEwrong_type_argument(Snumber, x); + } + if (-1.0 <= dx && dx <= 1.0) return(make_longfloat(asin(dx))); + } + + /* treat as complex argument, result */ + { + object r; + object x0, x1; + vs_mark; + + x0 = number_times(x, x); + vs_push(x0); + x0 = number_minus(small_fixnum(1), x0); + vs_push(x0); + x0 = number_sqrt(x0); + vs_push(x0); + x1 = number_times(imag_unit, x); + vs_push(x1); + x0 = number_plus(x0, x1); + vs_push(x0); + x0 = number_nlog(x0); + vs_push(x0); + r = number_times(minus_imag_unit, x0); + vs_reset; + return(r); + } +} + +object +number_acos(x) + object x; +{ + double acos(); + double dx; + + /* check for a real argument in [-1,1] */ + if (type_of(x) != t_complex) { + switch (type_of(x)) { + case t_fixnum: + case t_bignum: + case t_ratio: + dx = number_to_double(x); + break; + case t_shortfloat: + dx = sf(x); + break; + case t_longfloat: + dx = lf(x); + break; + default: + FEwrong_type_argument(Snumber, x); + } + if (-1.0 <= dx && dx <= 1.0) return(make_longfloat(acos(dx))); + } + + /* treat as complex argument, result */ + { + object r; + object x0; + vs_mark; + + x0 = number_times(x, x); + vs_push(x0); + x0 = number_minus(small_fixnum(1), x0); + vs_push(x0); + x0 = number_sqrt(x0); + vs_push(x0); + x0 = number_times(imag_unit, x0); + vs_push(x0); + x0 = number_plus(x0, x); + vs_push(x0); + x0 = number_nlog(x0); + vs_push(x0); + r = number_times(minus_imag_unit, x0); + vs_reset; + return(r); + } +} + +Lexp() +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_exp(vs_base[0]); +} + +Lexpt() +{ + check_arg(2); + check_type_number(&vs_base[0]); + check_type_number(&vs_base[1]); + vs_base[0] = number_expt(vs_base[0], vs_base[1]); + vs_pop; +} + +Llog() +{ + int narg; + + narg = vs_top - vs_base; + if (narg < 1) + too_few_arguments(); + else if (narg == 1) { + check_type_number(&vs_base[0]); + vs_base[0] = number_nlog(vs_base[0]); + } else if (narg == 2) { + check_type_number(&vs_base[0]); + check_type_number(&vs_base[1]); + vs_base[0] = number_log(vs_base[1], vs_base[0]); + vs_pop; + } else + too_many_arguments(); +} + +Lsqrt() +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_sqrt(vs_base[0]); +} + +Lsin() +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_sin(vs_base[0]); +} + +Lcos() +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_cos(vs_base[0]); +} + +Ltan() +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_tan(vs_base[0]); +} + +Latan() +{ + int narg; + + narg = vs_top - vs_base; + if (narg < 1) + too_few_arguments(); + if (narg == 1) { + check_type_number(&vs_base[0]); + vs_base[0] = number_atan(vs_base[0]); + } else if (narg == 2) { + check_type_or_rational_float(&vs_base[0]); + check_type_or_rational_float(&vs_base[1]); + vs_base[0] = number_atan2(vs_base[0], vs_base[1]); + vs_pop; + } else + too_many_arguments(); +} + +Lasin() +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_asin(vs_base[0]); +} + +Lacos() +{ + check_arg(1); + check_type_number(&vs_base[0]); + vs_base[0] = number_acos(vs_base[0]); +} + +init_num_sfun() +{ + imag_unit + = make_complex(make_longfloat(0.0), make_longfloat(1.0)); + enter_mark_origin(&imag_unit); + minus_imag_unit + = make_complex(make_longfloat(0.0), make_longfloat(-1.0)); + enter_mark_origin(&minus_imag_unit); + imag_two + = make_complex(make_longfloat(0.0), make_longfloat(2.0)); + enter_mark_origin(&imag_two); + + make_constant("PI", make_longfloat(PI)); + + make_function("EXP", Lexp); + make_function("EXPT", Lexpt); + make_function("LOG", Llog); + make_function("SQRT", Lsqrt); + make_function("SIN", Lsin); + make_function("COS", Lcos); + make_function("TAN", Ltan); + make_function("ATAN", Latan); + make_function("ASIN", Lasin); + make_function("ACOS", Lacos); +} diff --git a/numlib.lsp b/numlib.lsp new file mode 100644 index 0000000..10f5241 --- /dev/null +++ b/numlib.lsp @@ -0,0 +1,197 @@ +;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved. +;; Copying of this file is authorized to users who have executed the true and +;; proper "License Agreement for Kyoto Common LISP" with SIGLISP. + +;;;; numlib.lsp +;;;; +;;;; number routines + + +(in-package 'lisp) +(export + '(isqrt abs phase signum cis asin acos sinh cosh tanh + asinh acosh atanh + rational rationalize + ffloor fround ftruncate fceiling + lognand lognor logandc1 logandc2 logorc1 logorc2 + lognot logtest + byte byte-size byte-position + ldb ldb-test mask-field dpb deposit-field + )) + + +(in-package 'system) + + +(proclaim '(optimize (safety 2) (space 3))) + + +(defconstant imag-one #C(0.0f0 1.0f0)) + + +(defun isqrt (i) + (unless (and (integerp i) (>= i 0)) + (error "~S is not a non-negative integer." i)) + (if (zerop i) + 0 + (let ((n (integer-length i))) + (do ((x (ash 1 (ceiling n 2))) + (y)) + (nil) + (setq y (floor i x)) + (when (<= x y) + (return x)) + (setq x (floor (+ x y) 2)))))) + +(defun abs (x) + (if (complexp x) + (sqrt (+ (* (realpart x) (realpart x)) + (* (imagpart x) (imagpart x)))) + (if (minusp x) + (- x) + x))) + +(defun phase (x) + (atan (imagpart x) (realpart x))) + +(defun signum (x) (if (zerop x) x (/ x (abs x)))) + +(defun cis (x) (exp (* imag-one x))) + + +#| +(defun asin (x) + (let ((c (- (* imag-one + (log (+ (* imag-one x) + (sqrt (- 1.0f0 (* x x))))))))) + (if (or (not (complexp x)) (zerop (imagpart c))) + (realpart c) + c))) + +(defun acos (x) + (let ((c (- (* imag-one + (log (+ x (* imag-one + (sqrt (- 1.0f0 (* x x)))))))))) + (if (or (not (complexp x)) (zerop (imagpart c))) + (realpart c) + c))) +|# + +(defun sinh (x) (/ (- (exp x) (exp (- x))) 2.0f0)) +(defun cosh (x) (/ (+ (exp x) (exp (- x))) 2.0f0)) +(defun tanh (x) (/ (sinh x) (cosh x))) + +(defun asinh (x) (log (+ x (sqrt (+ 1.0f0 (* x x)))))) +(defun acosh (x) + (log (+ x + (* (1+ x) + (sqrt (/ (1- x) (1+ x))))))) +(defun atanh (x) + (when (or (= x 1.0f0) (= x -1.0f0)) + (error "The argument, ~s, is a logarithmic singularity.~ + ~%Don't be foolish, GLS." + x)) + (log (/ (1+ x) (sqrt (- 1.0f0 (* x x)))))) + + +(defun rational (x) + (etypecase x + (float + (multiple-value-bind (i e s) (integer-decode-float x) + (if (>= s 0) + (* i (expt (float-radix x) e)) + (- (* i (expt (float-radix x) e)))))) + (rational x))) + + +(setf (symbol-function 'rationalize) (symbol-function 'rational)) + +;; although the following is correct code in that it approximates the +;; x to within eps, it does not preserve (eql (float (rationalize x) x) x) +;; since the test for eql is more strict than the float-epsilon + +;;; Rationalize originally by Skef Wholey. +;;; Obtained from Daniel L. Weinreb. +;(defun rationalize (x) +; (typecase x +; (rational x) +; (short-float (rationalize-float x short-float-epsilon 1.0s0)) +; (long-float (rationalize-float x long-float-epsilon 1.0d0)) +; (otherwise (error "~S is neither rational nor float." x)))) +; +;(defun rationalize-float (x eps one) +; (cond ((minusp x) (- (rationalize (- x)))) +; ((zerop x) 0) +; (t (let ((y ()) +; (a ())) +; (do ((xx x (setq y (/ one +; (- xx (float a x))))) +; (num (setq a (truncate x)) +; (+ (* (setq a (truncate y)) num) onum)) +; (den 1 (+ (* a den) oden)) +; (onum 1 num) +; (oden 0 den)) +; ((and (not (zerop den)) +; (not (> (abs (/ (- x (/ (float num x) +; (float den x))) +; x)) +; eps))) +; (/ num den))))))) + + +(defun ffloor (x &optional (y 1.0f0)) + (multiple-value-bind (i r) (floor (float x) (float y)) + (values (float i r) r))) + +(defun fceiling (x &optional (y 1.0f0)) + (multiple-value-bind (i r) (ceiling (float x) (float y)) + (values (float i r) r))) + +(defun ftruncate (x &optional (y 1.0f0)) + (multiple-value-bind (i r) (truncate (float x) (float y)) + (values (float i r) r))) + +(defun fround (x &optional (y 1.0f0)) + (multiple-value-bind (i r) (round (float x) (float y)) + (values (float i r) r))) + + +(defun lognand (x y) (boole boole-nand x y)) +(defun lognor (x y) (boole boole-nor x y)) +(defun logandc1 (x y) (boole boole-andc1 x y)) +(defun logandc2 (x y) (boole boole-andc2 x y)) +(defun logorc1 (x y) (boole boole-orc1 x y)) +(defun logorc2 (x y) (boole boole-orc2 x y)) + +(defun lognot (x) (logxor -1 x)) +(defun logtest (x y) (not (zerop (logand x y)))) + + +(defun byte (size position) + (cons size position)) + +(defun byte-size (bytespec) + (car bytespec)) + +(defun byte-position (bytespec) + (cdr bytespec)) + +(defun ldb (bytespec integer) + (logandc2 (ash integer (- (byte-position bytespec))) + (- (ash 1 (byte-size bytespec))))) + +(defun ldb-test (bytespec integer) + (not (zerop (ldb bytespec integer)))) + +(defun mask-field (bytespec integer) + (ash (ldb bytespec integer) (byte-position bytespec))) + +(defun dpb (newbyte bytespec integer) + (logxor integer + (mask-field bytespec integer) + (ash (logandc2 newbyte + (- (ash 1 (byte-size bytespec)))) + (byte-position bytespec)))) + +(defun deposit-field (newbyte bytespec integer) + (dpb (ash newbyte (- (byte-position bytespec))) bytespec integer)) diff --git a/regression.lsp b/regression.lsp new file mode 100644 index 0000000..753dbfc --- /dev/null +++ b/regression.lsp @@ -0,0 +1,447 @@ +;;;; +;;;; regression.lsp XLISP-STAT regression model proto and methods +;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney +;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz +;;;; You may give out copies of this software; for conditions see the file +;;;; COPYING included with this distribution. +;;;; +;;;; +;;;; Incorporates modifications suggested by Sandy Weisberg. +;;;; + + +(provide "regression") + +#+:CLtL2 +(in-package lisp-stat) +#-:CLtL2 +(in-package 'lisp-stat) + +(export '(regression-model regression-model-proto x y intercept sweep-matrix + basis weights included total-sum-of-squares residual-sum-of-squares + predictor-names response-name case-labels)) + +;;;; +;;;; +;;;; Regresion Model Prototype +;;;; +;;;; + +(defproto regression-model-proto + '(x y intercept sweep-matrix basis weights + included + total-sum-of-squares + residual-sum-of-squares + predictor-names + response-name + case-labels) + () + *object* + "Normal Linear Regression Model") + +;; The doc for this function string is at the limit of XLISP's string +;; constant size - making it longer may cause problems +(defun regression-model (x y &key + (intercept T) + (print T) + weights + (included (repeat t (length y))) + predictor-names + response-name + case-labels) +"Args: (x y &key (intercept T) (print T) weights + included predictor-names response-name case-labels) +X - list of independent variables or X matrix +Y - dependent variable. +INTERCEPT - T to include (default), NIL for no intercept +PRINT - if not NIL print summary information +WEIGHTS - if supplied should be the same length as Y; error variances are + assumed to be inversely proportional to WEIGHTS +PREDICTOR-NAMES +RESPONSE-NAME +CASE-LABELS - sequences of strings or symbols. +INCLUDED - if supplied should be the same length as Y, with elements nil + to skip a in computing estimates (but not in residual analysis). +Returns a regression model object. To examine the model further assign the +result to a variable and send it messages. +Example (data are in file absorbtion.lsp in the sample data directory/folder): + (def m (regression-model (list iron aluminum) absorbtion)) + (send m :help) + (send m :plot-residuals)" + (let ((x (cond + ((matrixp x) x) + ((vectorp x) (list x)) + ((and (consp x) (numberp (car x))) (list x)) + (t x))) + (m (send regression-model-proto :new))) + (send m :x (if (matrixp x) x (apply #'bind-columns x))) + (send m :y y) + (send m :intercept intercept) + (send m :weights weights) + (send m :included included) + (send m :predictor-names predictor-names) + (send m :response-name response-name) + (send m :case-labels case-labels) + (if print (send m :display)) + m)) + +(defmeth regression-model-proto :isnew () (send self :needs-computing t)) + +(defmeth regression-model-proto :save () +"Message args: () +Returns an expression that will reconstruct the regression model." + `(regression-model ',(send self :x) + ',(send self :y) + :intercept ',(send self :intercept) + :weights ',(send self :weights) + :included ',(send self :included) + :predictor-names ',(send self :predictor-names) + :response-name ',(send self :response-name) + :case-labels ',(send self :case-labels))) + +;;; +;;; Computing and Display Methods +;;; + +(defmeth regression-model-proto :compute () +"Message args: () +Recomputes the estimates. For internal use by other messages" + (let* ((included (if-else (send self :included) 1 0)) + (x (send self :x)) + (y (send self :y)) + (intercept (send self :intercept)) + (weights (send self :weights)) + (w (if weights (* included weights) included)) + (m (make-sweep-matrix x y w)) + (n (array-dimension x 1)) + (p (- (array-dimension m 0) 1)) + (tss (aref m p p)) + (tol (* .0001 (mapcar #'standard-deviation (column-list x)))) + (sweep-result + (if intercept + (sweep-operator m (iseq 1 n) tol) + (sweep-operator m (iseq 0 n) (cons 0.0 tol))))) + (setf (slot-value 'sweep-matrix) (first sweep-result)) + (setf (slot-value 'total-sum-of-squares) tss) + (setf (slot-value 'residual-sum-of-squares) + (aref (first sweep-result) p p)) + (setf (slot-value 'basis) + (let ((b (remove 0 (second sweep-result)))) + (if b + (- (reverse b) 1) + (error "no columns could be swept")))))) + +(defmeth regression-model-proto :needs-computing (&optional set) + (if set (setf (slot-value 'sweep-matrix) nil)) + (null (slot-value 'sweep-matrix))) + +(defmeth regression-model-proto :display () +"Message args: () +Prints the least squares regression summary. Variables not used in the fit +are marked as aliased." + (let ((coefs (coerce (send self :coef-estimates) 'list)) + (se-s (send self :coef-standard-errors)) + (x (send self :x)) + (p-names (send self :predictor-names))) + (if (send self :weights) + (format t "~%Weighted Least Squares Estimates:~2%") + (format t "~%Least Squares Estimates:~2%")) + (when (send self :intercept) + (format t "Constant ~10f ~A~%" + (car coefs) (list (car se-s))) + (setf coefs (cdr coefs)) + (setf se-s (cdr se-s))) + (dotimes (i (array-dimension x 1)) + (cond + ((member i (send self :basis)) + (format t "~22a ~10f ~A~%" + (select p-names i) (car coefs) (list (car se-s))) + (setf coefs (cdr coefs) se-s (cdr se-s))) + (t (format t "~22a aliased~%" (select p-names i))))) + (format t "~%") + (format t "R Squared: ~10f~%" (send self :r-squared)) + (format t "Sigma hat: ~10f~%" (send self :sigma-hat)) + (format t "Number of cases: ~10d~%" (send self :num-cases)) + (if (/= (send self :num-cases) (send self :num-included)) + (format t "Number of cases used: ~10d~%" (send self :num-included))) + (format t "Degrees of freedom: ~10d~%" (send self :df)) + (format t "~%"))) + +;;; +;;; Slot accessors and mutators +;;; + +(defmeth regression-model-proto :x (&optional new-x) +"Message args: (&optional new-x) +With no argument returns the x matrix as supplied to m. With an argument +NEW-X sets the x matrix to NEW-X and recomputes the estimates." + (when (and new-x (matrixp new-x)) + (setf (slot-value 'x) new-x) + (send self :needs-computing t)) + (slot-value 'x)) + +(defmeth regression-model-proto :y (&optional new-y) +"Message args: (&optional new-y) +With no argument returns the y sequence as supplied to m. With an argument +NEW-Y sets the y sequence to NEW-Y and recomputes the estimates." + (when (and new-y (or (matrixp new-y) (sequencep new-y))) + (setf (slot-value 'y) new-y) + (send self :needs-computing t)) + (slot-value 'y)) + +(defmeth regression-model-proto :intercept (&optional (val nil set)) +"Message args: (&optional new-intercept) +With no argument returns T if the model includes an intercept term, nil if +not. With an argument NEW-INTERCEPT the model is changed to include or +exclude an intercept, according to the value of NEW-INTERCEPT." + (when set + (setf (slot-value 'intercept) val) + (send self :needs-computing t)) + (slot-value 'intercept)) + +(defmeth regression-model-proto :weights (&optional (new-w nil set)) +"Message args: (&optional new-w) +With no argument returns the weight sequence as supplied to m; NIL means +an unweighted model. NEW-W sets the weights sequence to NEW-W and +recomputes the estimates." + (when set + (setf (slot-value 'weights) new-w) + (send self :needs-computing t)) + (slot-value 'weights)) + +(defmeth regression-model-proto :total-sum-of-squares () +"Message args: () +Returns the total sum of squares around the mean." + (if (send self :needs-computing) (send self :compute)) + (slot-value 'total-sum-of-squares)) + +(defmeth regression-model-proto :residual-sum-of-squares () +"Message args: () +Returns the residual sum of squares for the model." + (if (send self :needs-computing) (send self :compute)) + (slot-value 'residual-sum-of-squares)) + +(defmeth regression-model-proto :basis () +"Message args: () +Returns the indices of the variables used in fitting the model." + (if (send self :needs-computing) (send self :compute)) + (slot-value 'basis)) + +(defmeth regression-model-proto :sweep-matrix () +"Message args: () +Returns the swept sweep matrix. For internal use" + (if (send self :needs-computing) (send self :compute)) + (slot-value 'sweep-matrix)) + +(defmeth regression-model-proto :included (&optional new-included) +"Message args: (&optional new-included) +With no argument, NIL means a case is not used in calculating estimates, and non-nil means it is used. NEW-INCLUDED is a sequence of length of y of nil and t to select cases. Estimates are recomputed." + (when (and new-included + (= (length new-included) (send self :num-cases))) + (setf (slot-value 'included) (copy-seq new-included)) + (send self :needs-computing t)) + (if (slot-value 'included) + (slot-value 'included) + (repeat t (send self :num-cases)))) + +(defmeth regression-model-proto :predictor-names (&optional (names nil set)) +"Message args: (&optional (names nil set)) +With no argument returns the predictor names. NAMES sets the names." + (if set (setf (slot-value 'predictor-names) (mapcar #'string names))) + (let ((p (array-dimension (send self :x) 1)) + (p-names (slot-value 'predictor-names))) + (if (not (and p-names (= (length p-names) p))) + (setf (slot-value 'predictor-names) + (mapcar #'(lambda (a) (format nil "Variable ~a" a)) + (iseq 0 (- p 1)))))) + (slot-value 'predictor-names)) + +(defmeth regression-model-proto :response-name (&optional (name "Y" set)) +"Message args: (&optional name) +With no argument returns the response name. NAME sets the name." + (if set (setf (slot-value 'response-name) (if name (string name) "Y"))) + (slot-value 'response-name)) + +(defmeth regression-model-proto :case-labels (&optional (labels nil set)) +"Message args: (&optional labels) +With no argument returns the case-labels. LABELS sets the labels." + (if set (setf (slot-value 'case-labels) + (if labels + (mapcar #'string labels) + (mapcar #'(lambda (x) (format nil "~d" x)) + (iseq 0 (- (send self :num-cases) 1)))))) + (slot-value 'case-labels)) + +;;; +;;; Other Methods +;;; None of these methods access any slots directly. +;;; + +(defmeth regression-model-proto :num-cases () +"Message args: () +Returns the number of cases in the model." + (length (send self :y))) + +(defmeth regression-model-proto :num-included () +"Message args: () +Returns the number of cases used in the computations." + (sum (if-else (send self :included) 1 0))) + +(defmeth regression-model-proto :num-coefs () +"Message args: () +Returns the number of coefficients in the fit model (including the +intercept if the model includes one)." + (if (send self :intercept) + (+ 1 (length (send self :basis))) + (length (send self :basis)))) + +(defmeth regression-model-proto :df () +"Message args: () +Returns the number of degrees of freedom in the model." + (- (send self :num-included) (send self :num-coefs))) + +(defmeth regression-model-proto :x-matrix () +"Message args: () +Returns the X matrix for the model, including a column of 1's, if +appropriate. Columns of X matrix correspond to entries in basis." + (let ((m (select (send self :x) + (iseq 0 (- (send self :num-cases) 1)) + (send self :basis)))) + (if (send self :intercept) + (bind-columns (repeat 1 (send self :num-cases)) m) + m))) + +(defmeth regression-model-proto :leverages () +"Message args: () +Returns the diagonal elements of the hat matrix." + (let* ((weights (send self :weights)) + (x (send self :x-matrix)) + (raw-levs + (matmult (* (matmult x (send self :xtxinv)) x) + (repeat 1 (send self :num-coefs))))) + (if weights (* weights raw-levs) raw-levs))) + +(defmeth regression-model-proto :fit-values () +"Message args: () +Returns the fitted values for the model." + (matmult (send self :x-matrix) (send self :coef-estimates))) + +(defmeth regression-model-proto :raw-residuals () +"Message args: () +Returns the raw residuals for a model." + (- (send self :y) (send self :fit-values))) + +(defmeth regression-model-proto :residuals () +"Message args: () +Returns the raw residuals for a model without weights. If the model +includes weights the raw residuals times the square roots of the weights +are returned." + (let ((raw-residuals (send self :raw-residuals)) + (weights (send self :weights))) + (if weights (* (sqrt weights) raw-residuals) raw-residuals))) + +(defmeth regression-model-proto :sum-of-squares () +"Message args: () +Returns the error sum of squares for the model." + (send self :residual-sum-of-squares)) + +(defmeth regression-model-proto :sigma-hat () +"Message args: () +Returns the estimated standard deviation of the deviations about the +regression line." + (let ((ss (send self :sum-of-squares)) + (df (send self :df))) + (if (/= df 0) (sqrt (/ ss df))))) + +;; for models without an intercept the 'usual' formula for R^2 can give +;; negative results; hence the max. +(defmeth regression-model-proto :r-squared () +"Message args: () +Returns the sample squared multiple correlation coefficient, R squared, for +the regression." + (max (- 1 (/ (send self :sum-of-squares) (send self :total-sum-of-squares))) + 0)) + +(defmeth regression-model-proto :coef-estimates () +"Message args: () +Returns the OLS (ordinary least squares) estimates of the regression +coefficients. Entries beyond the intercept correspond to entries in basis." + (let ((n (array-dimension (send self :x) 1)) + (indices (if (send self :intercept) + (cons 0 (+ 1 (send self :basis))) + (+ 1 (send self :basis)))) + (m (send self :sweep-matrix))) + (coerce (compound-data-seq (select m (+ 1 n) indices)) 'list))) + +(defmeth regression-model-proto :xtxinv () +"Message args: () +Returns ((X^T) X)^(-1) or ((X^T) W X)^(-1)." + (let ((indices (if (send self :intercept) + (cons 0 (1+ (send self :basis))) + (1+ (send self :basis))))) + (select (send self :sweep-matrix) indices indices))) + +(defmeth regression-model-proto :coef-standard-errors () +"Message args: () +Returns estimated standard errors of coefficients. Entries beyond the +intercept correspond to entries in basis." + (let ((s (send self :sigma-hat))) + (if s (* (send self :sigma-hat) (sqrt (diagonal (send self :xtxinv))))))) + +(defmeth regression-model-proto :studentized-residuals () +"Message args: () +Computes the internally studentized residuals for included cases and externally studentized residuals for excluded cases." + (let ((res (send self :residuals)) + (lev (send self :leverages)) + (sig (send self :sigma-hat)) + (inc (send self :included))) + (if-else inc + (/ res (* sig (sqrt (pmax .00001 (- 1 lev))))) + (/ res (* sig (sqrt (+ 1 lev))))))) + +(defmeth regression-model-proto :externally-studentized-residuals () +"Message args: () +Computes the externally studentized residuals." + (let* ((res (send self :studentized-residuals)) + (df (send self :df))) + (if-else (send self :included) + (* res (sqrt (/ (- df 1) (- df (^ res 2))))) + res))) + +(defmeth regression-model-proto :cooks-distances () +"Message args: () +Computes Cook's distances." + (let ((lev (send self :leverages)) + (res (/ (^ (send self :studentized-residuals) 2) + (send self :num-coefs)))) + (if-else (send self :included) (* res (/ lev (- 1 lev) )) (* res lev)))) + +(defmeth regression-model-proto :plot-residuals (&optional x-values) +"Message args: (&optional x-values) +Opens a window with a plot of the residuals. If X-VALUES are not supplied +the fitted values are used. The plot can be linked to other plots with the +link-views function. Returns a plot object." + (plot-points (if x-values x-values (send self :fit-values)) + (send self :residuals) + :title "Residual Plot" + :point-labels (send self :case-labels))) + +(defmeth regression-model-proto :plot-bayes-residuals + (&optional x-values) +"Message args: (&optional x-values) +Opens a window with a plot of the standardized residuals and two standard +error bars for the posterior distribution of the actual deviations from the +line. See Chaloner and Brant. If X-VALUES are not supplied the fitted values +are used. The plot can be linked to other plots with the link-views function. +Returns a plot object." + (let* ((r (/ (send self :residuals) (send self :sigma-hat))) + (d (* 2 (sqrt (send self :leverages)))) + (low (- r d)) + (high (+ r d)) + (x-values (if x-values x-values (send self :fit-values))) + (p (plot-points x-values r :title "Bayes Residual Plot" + :point-labels (send self :case-labels)))) + (map 'list #'(lambda (a b c d) (send p :plotline a b c d nil)) + x-values low x-values high) + (send p :adjust-to-data) + p)) diff --git a/statistics.lsp b/statistics.lsp new file mode 100644 index 0000000..d26fb1d --- /dev/null +++ b/statistics.lsp @@ -0,0 +1,326 @@ +;;;; +;;;; statistics.lsp XLISP-STAT statistics functions +;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney +;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz +;;;; You may give out copies of this software; for conditions see the file +;;;; COPYING included with this distribution. +;;;; + +(provide "statistics") + +#+:CLtL2 +(in-package lisp-stat) +#-:CLtL2 +(in-package 'lisp-stat) + +(export '(open-file-dialog read-data-file read-data-columns load-data + load-example *variables* *ask-on-redefine* def variables savevar + undef standard-deviation quantile median interquartile-range + fivnum covariance-matrix difference rseq matrix print-matrix solve + backsolve eigenvalues eigenvectors accumulate cumsum combine + lowess)) + +(import 'ls-basics::|base-lowess|) + +;;;; +;;;; Data File Reading +;;;; + +(defun count-file-columns (fname) +"Args: (fname) +Returns the number of lisp items on the first nonblank line of file FNAME." + (with-open-file (f fname) + (if f + (let ((line (do ((line (read-line f) (read-line f))) + ((or (null line) (< 0 (length line))) line)))) + (if line + (with-input-from-string (s line) + (do ((n 0 (+ n 1)) (eof (gensym))) + ((eq eof (read s nil eof)) n)))))))) + +#+xlisp (defvar *xlisptable* *readtable*) + +(if (not (fboundp 'open-file-dialog)) + #+dialogs + (defun open-file-dialog (&optional set) + (get-string-dialog "Enter a data file name:")) + #-dialogs + (defun open-file-dialog (&optional set) + (error "You must provide a file name explicitly"))) + +(defun read-data-file (&optional (file (open-file-dialog t))) +"Args: (file) +Returns a list of all lisp objects in FILE. FILE can be a string or a symbol, +in which case the symbol'f print name is used." + (if file + (let ((eof (gensym))) + (with-open-file (f file) + (if f + (do* ((r (read f nil eof) (read f nil eof)) + (x (list nil)) + (tail x (cdr tail))) + ((eq r eof) (cdr x)) + (setf (cdr tail) (list r)))))))) + +;;; New definition to avoid stack size limit in apply +(defun read-data-columns (&optional (file (open-file-dialog t)) + (cols (if file + (count-file-columns file)))) +"Args: (&optional file cols) +Reads the data in FILE as COLS columns and returns a list of lists representing the columns." + (if (and file cols) + (transpose (split-list (read-data-file file) cols)))) + +#+unix +(defun load-data (file) +"Args: (file) +Read in data file from the data examples library." + (if (load (format nil "~aData/~a" *default-path* file)) + t + (load (format nil "~aExamples/~a" *default-path* file)))) + +#+unix +(defun load-example (file) +"Args: (file) +Read in lisp example file from the examples library." + (if (load (format nil "~aExamples/~a" *default-path* file)) + t + (load (format nil "~aData/~a" *default-path* file)))) +#+macintosh +(defun load-data (s) (require s (concatenate 'string ":Data:" s))) +#+macintosh +(defun load-example (s) (require s (concatenate 'string ":Examples:" s))) + +#+msdos +(defun load-data (file) +"Args: (file) +Read in data file from the data examples library." + (load (format nil "~aData\\~a" *default-path* file))) + +#+msdos +(defun load-example (file) +"Args: (file) +Read in lisp example file from the examples library." + (load (format nil "~aExamples\\~a" *default-path* file))) + +;;;; +;;;; Listing and Saving Variables and Functions +;;;; + +(defvar *variables* nil) +(defvar *ask-on-redefine* nil) + +(defmacro def (symbol value) +"Syntax: (def var form) +VAR is not evaluated and must be a symbol. Assigns the value of FORM to +VAR and adds VAR to the list *VARIABLES* of def'ed variables. Returns VAR. +If VAR is already bound and the global variable *ASK-ON-REDEFINE* +is not nil then you are asked if you want to redefine the variable." + `(unless (and *ask-on-redefine* + (boundp ',symbol) + (not (y-or-n-p "Variable has a value. Redefine?"))) + (pushnew ',symbol *variables*) + (setf ,symbol ,value) + ',symbol)) + +(defun variables-list () + (mapcar #'intern (sort-data (mapcar #'string *variables*)))) + +(defun variables () +"Args:() +Returns a list of the names of all def'ed variables to STREAM" + (if *variables* + (mapcar #'intern (sort-data (mapcar #'string *variables*))))) + +(defun savevar (vars file) +"Args: (vars file-name-root) +VARS is a symbol or a list of symbols. FILE-NAME-ROOT is a string (or a symbol +whose print name is used) not endinf in .lsp. The VARS and their current values +are written to the file FILE-NAME-ROOT.lsp in a form suitable for use with the +load command." + (with-open-file (f (strcat (string file) ".lsp") :direction :output) + (let ((vars (if (consp vars) vars (list vars)))) + (flet ((save-one (x) + (let ((v (symbol-value x))) + (if (objectp v) + (format f "(def ~s ~s)~%" x (send v :save)) + (format f "(def ~s '~s)~%" x v))))) + (mapcar #'save-one vars)) + vars))) + +(defun undef (v) +"Args: (v) +If V is the symbol of a defined variable the variable it is unbound and +removed from the list of defined variables. If V is a list of variable +names each is unbound and removed. Returns V." + (dolist (s (if (listp v) v (list v))) + (when (member s *variables*) + (setq *variables* (delete s *variables*)) + (makunbound s))) + v) + + +;;;; +;;;; Basic Summary Statistics +;;;; + +(defun standard-deviation (x) +"Args: (x) +Returns the standard deviation of the elements x. Vector reducing." + (let ((n (count-elements x)) + (r (- x (mean x)))) + (sqrt (* (mean (* r r)) (/ n (- n 1)))))) + +(defun quantile (x p) +"Args: (x p) +Returns the P-th quantile(s) of sequence X. P can be a number or a sequence." + (let* ((x (sort-data x)) + (n (length x)) + (np (* p (- n 1))) + (low (floor np)) + (high (ceiling np))) + (/ (+ (select x low) (select x high)) 2))) + +(defun median (x) +"Args: (x) +Returns the median of the elements of X." + (quantile x 0.5)) + +(defun interquartile-range (x) +"Args: (number-data) +Returns the interquartile range of the elements of X." + (apply #'- (quantile x '(0.75 0.25)))) + +(defun fivnum (x) +"Args: (number-data) +Returns the five number summary (min, 1st quartile, medinan, 3rd quartile, +max) of the elements X." + (quantile x '(0 .25 .5 .75 1))) + +(defun covariance-matrix (&rest args) +"Args: (&rest args) +Returns the sample covariance matrix of the data columns in ARGS. ARGS may +consist of lists, vectors or matrices." + (let ((columns (apply #'append + (mapcar #'(lambda (x) + (if (matrixp x) (column-list x) (list x))) + args)))) + (/ (cross-product (apply #'bind-columns + (- columns (mapcar #'mean columns)))) + (- (length (car columns)) 1)))) + +;;;; +;;;; Basic Sequence Operations +;;;; + +(defun difference (x) +"Args: (x) +Returns differences for a sequence X." + (let ((n (length x))) + (- (select x (iseq 1 (1- n))) (select x (iseq 0 (- n 2)))))) + +(defun rseq (a b num) +"Args: (a b num) +Returns a list of NUM equally spaced points starting at A and ending at B." + (+ a (* (iseq 0 (1- num)) (/ (float (- b a)) (1- num))))) + + +;;;; +;;;; Linear Algebra Functions +;;;; + +(defun matrix (dim data) +"Args: (dim data) +returns a matrix of dimensions DIM initialized using sequence DATA +in row major order." + (let ((dim (coerce dim 'list)) + (data (coerce data 'list))) + (make-array dim :initial-contents (split-list data (nth 1 dim))))) + +(defun print-matrix (a &optional (stream *standard-output*)) +"Args: (matrix &optional stream) +Prints MATRIX to STREAM in a nice form that is still machine readable" + (unless (matrixp a) (error "not a matrix - ~a" a)) + (let ((size (min 15 (max (map-elements #'flatsize a))))) + (format stream "#2a(~%") + (dolist (x (row-list a)) + (format stream " (") + (let ((n (length x))) + (dotimes (i n) + (let ((y (aref x i))) + (cond + ((integerp y) (format stream "~vd" size y)) + ((floatp y) (format stream "~vg" size y)) + (t (format stream "~va" size y)))) + (if (< i (- n 1)) (format stream " ")))) + (format stream ")~%")) + (format stream " )~%") + nil)) + +(defun solve (a b) +"Args: (a b) +Solves A x = B using LU decomposition and backsolving. B can be a sequence +or a matrix." + (let ((lu (lu-decomp a))) + (if (matrixp b) + (apply #'bind-columns + (mapcar #'(lambda (x) (lu-solve lu x)) (column-list b))) + (lu-solve lu b)))) + +(defun backsolve (a b) +"Args: (a b) +Solves A x = B by backsolving, assuming A is upper triangular. B must be a +sequence. For use with qr-decomp." + (let* ((n (length b)) + (sol (make-array n))) + (dotimes (i n) + (let* ((k (- n i 1)) + (val (elt b k))) + (dotimes (j i) + (let ((l (- n j 1))) + (setq val (- val (* (aref sol l) (aref a k l)))))) + (setf (aref sol k) (/ val (aref a k k))))) + (if (listp b) (coerce sol 'list) sol))) + +(defun eigenvalues (a) +"Args: (a) +Returns list of eigenvalues of square, symmetric matrix A" + (first (eigen a))) + +(defun eigenvectors (a) +"Args: (a) +Returns list of eigenvectors of square, symmetric matrix A" + (second (eigen a))) + +(defun accumulate (f s) +"Args: (f s) +Accumulates elements of sequence S using binary function F. +(accumulate #'+ x) returns the cumulative sum of x." + (let* ((result (list (elt s 0))) + (tail result)) + (flet ((acc (dummy x) + (rplacd tail (list (funcall f (first tail) x))) + (setf tail (cdr tail)))) + (reduce #'acc s)) + (if (vectorp s) (coerce result 'vector) result))) + +(defun cumsum (x) +"Args: (x) +Returns the cumulative sum of X." + (accumulate #'+ x)) + +(defun combine (&rest args) +"Args (&rest args) +Returns sequence of elements of all arguments." + (copy-seq (element-seq args))) + +(defun lowess (x y &key (f .25) (steps 2) (delta -1) sorted) +"Args: (x y &key (f .25) (steps 2) delta sorted) +Returns (list X YS) with YS the LOWESS fit. F is the fraction of data used for +each point, STEPS is the number of robust iterations. Fits for points within +DELTA of each other are interpolated linearly. If the X values setting SORTED +to T speeds up the computation." + (let ((x (if sorted x (sort-data x))) + (y (if sorted y (select y (order x)))) + (delta (if (> delta 0.0) delta (/ (- (max x) (min x)) 50)))) + (list x (|base-lowess| x y f steps delta)))) -- 2.11.4.GIT