lisp/calc/calc-funcs.el

   1 ;;; calc-funcs.el --- well-known functions for Calc
   2
   3 ;; Copyright (C) 1990, 1991, 1992, 1993, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: David Gillespie <daveg@synaptics.com>
   7 ;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com>
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 ;; This file is autoloaded from calc-ext.el.
  31
  32 (require 'calc-ext)
  33 (require 'calc-macs)
  34
  35 (defun calc-inc-gamma (arg)
  36   (interactive "P")
  37   (calc-slow-wrapper
  38    (if (calc-is-inverse)
  39        (if (calc-is-hyperbolic)
  40            (calc-binary-op "gamG" 'calcFunc-gammaG arg)
  41          (calc-binary-op "gamQ" 'calcFunc-gammaQ arg))
  42        (if (calc-is-hyperbolic)
  43            (calc-binary-op "gamg" 'calcFunc-gammag arg)
  44          (calc-binary-op "gamP" 'calcFunc-gammaP arg)))))
  45
  46 (defun calc-erf (arg)
  47   (interactive "P")
  48   (calc-slow-wrapper
  49    (if (calc-is-inverse)
  50        (calc-unary-op "erfc" 'calcFunc-erfc arg)
  51      (calc-unary-op "erf" 'calcFunc-erf arg))))
  52
  53 (defun calc-erfc (arg)
  54   (interactive "P")
  55   (calc-invert-func)
  56   (calc-erf arg))
  57
  58 (defun calc-beta (arg)
  59   (interactive "P")
  60   (calc-slow-wrapper
  61    (calc-binary-op "beta" 'calcFunc-beta arg)))
  62
  63 (defun calc-inc-beta ()
  64   (interactive)
  65   (calc-slow-wrapper
  66    (if (calc-is-hyperbolic)
  67        (calc-enter-result 3 "betB" (cons 'calcFunc-betaB (calc-top-list-n 3)))
  68      (calc-enter-result 3 "betI" (cons 'calcFunc-betaI (calc-top-list-n 3))))))
  69
  70 (defun calc-bessel-J (arg)
  71   (interactive "P")
  72   (calc-slow-wrapper
  73    (calc-binary-op "besJ" 'calcFunc-besJ arg)))
  74
  75 (defun calc-bessel-Y (arg)
  76   (interactive "P")
  77   (calc-slow-wrapper
  78    (calc-binary-op "besY" 'calcFunc-besY arg)))
  79
  80 (defun calc-bernoulli-number (arg)
  81   (interactive "P")
  82   (calc-slow-wrapper
  83    (if (calc-is-hyperbolic)
  84        (calc-binary-op "bern" 'calcFunc-bern arg)
  85      (calc-unary-op "bern" 'calcFunc-bern arg))))
  86
  87 (defun calc-euler-number (arg)
  88   (interactive "P")
  89   (calc-slow-wrapper
  90    (if (calc-is-hyperbolic)
  91        (calc-binary-op "eulr" 'calcFunc-euler arg)
  92      (calc-unary-op "eulr" 'calcFunc-euler arg))))
  93
  94 (defun calc-stirling-number (arg)
  95   (interactive "P")
  96   (calc-slow-wrapper
  97    (if (calc-is-hyperbolic)
  98        (calc-binary-op "str2" 'calcFunc-stir2 arg)
  99      (calc-binary-op "str1" 'calcFunc-stir1 arg))))
 100
 101 (defun calc-utpb ()
 102   (interactive)
 103   (calc-prob-dist "b" 3))
 104
 105 (defun calc-utpc ()
 106   (interactive)
 107   (calc-prob-dist "c" 2))
 108
 109 (defun calc-utpf ()
 110   (interactive)
 111   (calc-prob-dist "f" 3))
 112
 113 (defun calc-utpn ()
 114   (interactive)
 115   (calc-prob-dist "n" 3))
 116
 117 (defun calc-utpp ()
 118   (interactive)
 119   (calc-prob-dist "p" 2))
 120
 121 (defun calc-utpt ()
 122   (interactive)
 123   (calc-prob-dist "t" 2))
 124
 125 (defun calc-prob-dist (letter nargs)
 126   (calc-slow-wrapper
 127    (if (calc-is-inverse)
 128        (calc-enter-result nargs (concat "ltp" letter)
 129                           (append (list (intern (concat "calcFunc-ltp" letter))
 130                                         (calc-top-n 1))
 131                                   (calc-top-list-n (1- nargs) 2)))
 132      (calc-enter-result nargs (concat "utp" letter)
 133                         (append (list (intern (concat "calcFunc-utp" letter))
 134                                       (calc-top-n 1))
 135                                 (calc-top-list-n (1- nargs) 2))))))
 136
 137
 138
 139
 140 ;;; Sources:  Numerical Recipes, Press et al;
 141 ;;;           Handbook of Mathematical Functions, Abramowitz & Stegun.
 142
 143
 144 ;;; Gamma function.
 145
 146 (defun calcFunc-gamma (x)
 147   (or (math-numberp x) (math-reject-arg x 'numberp))
 148   (calcFunc-fact (math-add x -1)))
 149
 150 (defun math-gammap1-raw (x &optional fprec nfprec)
 151   "Compute gamma(1+X) to the appropriate precision."
 152   (or fprec
 153       (setq fprec (math-float calc-internal-prec)
 154             nfprec (math-float (- calc-internal-prec))))
 155   (cond ((math-lessp-float (calcFunc-re x) fprec)
 156          (if (math-lessp-float (calcFunc-re x) nfprec)
 157              (math-neg (math-div
 158                         (math-pi)
 159                         (math-mul (math-gammap1-raw
 160                                    (math-add (math-neg x)
 161                                              '(float -1 0))
 162                                    fprec nfprec)
 163                                   (math-sin-raw
 164                                    (math-mul (math-pi) x)))))
 165            (let ((xplus1 (math-add x '(float 1 0))))
 166              (math-div (math-gammap1-raw xplus1 fprec nfprec) xplus1))))
 167         ((and (math-realp x)
 168               (math-lessp-float '(float 736276 0) x))
 169          (math-overflow))
 170         (t   ; re(x) now >= 10.0
 171          (let ((xinv (math-div 1 x))
 172                (lnx (math-ln-raw x)))
 173            (math-mul (math-sqrt-two-pi)
 174                      (math-exp-raw
 175                       (math-gamma-series
 176                        (math-sub (math-mul (math-add x '(float 5 -1))
 177                                            lnx)
 178                                  x)
 179                        xinv
 180                        (math-sqr xinv)
 181                        '(float 0 0)
 182                        2)))))))
 183
 184 (defun math-gamma-series (sum x xinvsqr oterm n)
 185   (math-working "gamma" sum)
 186   (let* ((bn (math-bernoulli-number n))
 187          (term (math-mul (math-div-float (math-float (nth 1 bn))
 188                                          (math-float (* (nth 2 bn)
 189                                                         (* n (1- n)))))
 190                          x))
 191          (next (math-add sum term)))
 192     (if (math-nearly-equal sum next)
 193         next
 194       (if (> n (* 2 calc-internal-prec))
 195           (progn
 196             ;; Need this because series eventually diverges for large enough n.
 197             (calc-record-why
 198              "*Gamma computation stopped early, not all digits may be valid")
 199             next)
 200         (math-gamma-series next (math-mul x xinvsqr) xinvsqr term (+ n 2))))))
 201
 202
 203 ;;; Incomplete gamma function.
 204
 205 (defvar math-current-gamma-value nil)
 206 (defun calcFunc-gammaP (a x)
 207   (if (equal x '(var inf var-inf))
 208       '(float 1 0)
 209     (math-inexact-result)
 210     (or (Math-numberp a) (math-reject-arg a 'numberp))
 211     (or (math-numberp x) (math-reject-arg x 'numberp))
 212     (if (and (math-num-integerp a)
 213              (integerp (setq a (math-trunc a)))
 214              (> a 0) (< a 20))
 215         (math-sub 1 (calcFunc-gammaQ a x))
 216       (let ((math-current-gamma-value (calcFunc-gamma a)))
 217         (math-div (calcFunc-gammag a x) math-current-gamma-value)))))
 218
 219 (defun calcFunc-gammaQ (a x)
 220   (if (equal x '(var inf var-inf))
 221       '(float 0 0)
 222     (math-inexact-result)
 223     (or (Math-numberp a) (math-reject-arg a 'numberp))
 224     (or (math-numberp x) (math-reject-arg x 'numberp))
 225     (if (and (math-num-integerp a)
 226              (integerp (setq a (math-trunc a)))
 227              (> a 0) (< a 20))
 228         (let ((n 0)
 229               (sum '(float 1 0))
 230               (term '(float 1 0)))
 231           (math-with-extra-prec 1
 232             (while (< (setq n (1+ n)) a)
 233               (setq term (math-div (math-mul term x) n)
 234                     sum (math-add sum term))
 235               (math-working "gamma" sum))
 236             (math-mul sum (calcFunc-exp (math-neg x)))))
 237       (let ((math-current-gamma-value (calcFunc-gamma a)))
 238         (math-div (calcFunc-gammaG a x) math-current-gamma-value)))))
 239
 240 (defun calcFunc-gammag (a x)
 241   (if (equal x '(var inf var-inf))
 242       (calcFunc-gamma a)
 243     (math-inexact-result)
 244     (or (Math-numberp a) (math-reject-arg a 'numberp))
 245     (or (Math-numberp x) (math-reject-arg x 'numberp))
 246     (math-with-extra-prec 2
 247       (setq a (math-float a))
 248       (setq x (math-float x))
 249       (if (or (math-negp (calcFunc-re a))
 250               (math-lessp-float (calcFunc-re x)
 251                                 (math-add-float (calcFunc-re a)
 252                                                 '(float 1 0))))
 253           (math-inc-gamma-series a x)
 254         (math-sub (or math-current-gamma-value (calcFunc-gamma a))
 255                   (math-inc-gamma-cfrac a x))))))
 256
 257 (defun calcFunc-gammaG (a x)
 258   (if (equal x '(var inf var-inf))
 259       '(float 0 0)
 260     (math-inexact-result)
 261     (or (Math-numberp a) (math-reject-arg a 'numberp))
 262     (or (Math-numberp x) (math-reject-arg x 'numberp))
 263     (math-with-extra-prec 2
 264       (setq a (math-float a))
 265       (setq x (math-float x))
 266       (if (or (math-negp (calcFunc-re a))
 267               (math-lessp-float (calcFunc-re x)
 268                                 (math-add-float (math-abs-approx a)
 269                                                 '(float 1 0))))
 270           (math-sub (or math-current-gamma-value (calcFunc-gamma a))
 271                     (math-inc-gamma-series a x))
 272         (math-inc-gamma-cfrac a x)))))
 273
 274 (defun math-inc-gamma-series (a x)
 275   (if (Math-zerop x)
 276       '(float 0 0)
 277     (math-mul (math-exp-raw (math-sub (math-mul a (math-ln-raw x)) x))
 278               (math-with-extra-prec 2
 279                 (let ((start (math-div '(float 1 0) a)))
 280                   (math-inc-gamma-series-step start start a x))))))
 281
 282 (defun math-inc-gamma-series-step (sum term a x)
 283   (math-working "gamma" sum)
 284   (setq a (math-add a '(float 1 0))
 285         term (math-div (math-mul term x) a))
 286   (let ((next (math-add sum term)))
 287     (if (math-nearly-equal sum next)
 288         next
 289       (math-inc-gamma-series-step next term a x))))
 290
 291 (defun math-inc-gamma-cfrac (a x)
 292   (if (Math-zerop x)
 293       (or math-current-gamma-value (calcFunc-gamma a))
 294     (math-mul (math-exp-raw (math-sub (math-mul a (math-ln-raw x)) x))
 295               (math-inc-gamma-cfrac-step '(float 1 0) x
 296                                          '(float 0 0) '(float 1 0)
 297                                          '(float 1 0) '(float 1 0) '(float 0 0)
 298                                          a x))))
 299
 300 (defun math-inc-gamma-cfrac-step (a0 a1 b0 b1 n fac g a x)
 301   (let ((ana (math-sub n a))
 302         (anf (math-mul n fac)))
 303     (setq n (math-add n '(float 1 0))
 304           a0 (math-mul (math-add a1 (math-mul a0 ana)) fac)
 305           b0 (math-mul (math-add b1 (math-mul b0 ana)) fac)
 306           a1 (math-add (math-mul x a0) (math-mul anf a1))
 307           b1 (math-add (math-mul x b0) (math-mul anf b1)))
 308     (if (math-zerop a1)
 309         (math-inc-gamma-cfrac-step a0 a1 b0 b1 n fac g a x)
 310       (setq fac (math-div '(float 1 0) a1))
 311       (let ((next (math-mul b1 fac)))
 312         (math-working "gamma" next)
 313         (if (math-nearly-equal next g)
 314             next
 315           (math-inc-gamma-cfrac-step a0 a1 b0 b1 n fac next a x))))))
 316
 317
 318 ;;; Error function.
 319
 320 (defun calcFunc-erf (x)
 321   (if (equal x '(var inf var-inf))
 322       '(float 1 0)
 323     (if (equal x '(neg (var inf var-inf)))
 324         '(float -1 0)
 325       (if (Math-zerop x)
 326           x
 327         (let ((math-current-gamma-value (math-sqrt-pi)))
 328           (math-to-same-complex-quad
 329            (math-div (calcFunc-gammag '(float 5 -1)
 330                                       (math-sqr (math-to-complex-quad-one x)))
 331                      math-current-gamma-value)
 332            x))))))
 333
 334 (defun calcFunc-erfc (x)
 335   (if (equal x '(var inf var-inf))
 336       '(float 0 0)
 337     (if (math-posp x)
 338         (let ((math-current-gamma-value (math-sqrt-pi)))
 339           (math-div (calcFunc-gammaG '(float 5 -1) (math-sqr x))
 340                     math-current-gamma-value))
 341       (math-sub 1 (calcFunc-erf x)))))
 342
 343 (defun math-to-complex-quad-one (x)
 344   (if (eq (car-safe x) 'polar) (setq x (math-complex x)))
 345   (if (eq (car-safe x) 'cplx)
 346       (list 'cplx (math-abs (nth 1 x)) (math-abs (nth 2 x)))
 347     x))
 348
 349 (defun math-to-same-complex-quad (x y)
 350   (if (eq (car-safe y) 'cplx)
 351       (if (eq (car-safe x) 'cplx)
 352           (list 'cplx
 353                 (if (math-negp (nth 1 y)) (math-neg (nth 1 x)) (nth 1 x))
 354                 (if (math-negp (nth 2 y)) (math-neg (nth 2 x)) (nth 2 x)))
 355         (if (math-negp (nth 1 y)) (math-neg x) x))
 356     (if (math-negp y)
 357         (if (eq (car-safe x) 'cplx)
 358             (list 'cplx (math-neg (nth 1 x)) (nth 2 x))
 359           (math-neg x))
 360       x)))
 361
 362
 363 ;;; Beta function.
 364
 365 (defun calcFunc-beta (a b)
 366   (if (math-num-integerp a)
 367       (let ((am (math-add a -1)))
 368         (or (math-numberp b) (math-reject-arg b 'numberp))
 369         (math-div 1 (math-mul b (calcFunc-choose (math-add b am) am))))
 370     (if (math-num-integerp b)
 371         (calcFunc-beta b a)
 372       (math-div (math-mul (calcFunc-gamma a) (calcFunc-gamma b))
 373                 (calcFunc-gamma (math-add a b))))))
 374
 375
 376 ;;; Incomplete beta function.
 377
 378 (defvar math-current-beta-value nil)
 379 (defun calcFunc-betaI (x a b)
 380   (cond ((math-zerop x)
 381          '(float 0 0))
 382         ((math-equal-int x 1)
 383          '(float 1 0))
 384         ((or (math-zerop a)
 385              (and (math-num-integerp a)
 386                   (math-negp a)))
 387          (if (or (math-zerop b)
 388                  (and (math-num-integerp b)
 389                       (math-negp b)))
 390              (math-reject-arg b 'range)
 391            '(float 1 0)))
 392         ((or (math-zerop b)
 393              (and (math-num-integerp b)
 394                   (math-negp b)))
 395          '(float 0 0))
 396         ((not (math-numberp a)) (math-reject-arg a 'numberp))
 397         ((not (math-numberp b)) (math-reject-arg b 'numberp))
 398         ((math-inexact-result))
 399         (t (let ((math-current-beta-value (calcFunc-beta a b)))
 400              (math-div (calcFunc-betaB x a b) math-current-beta-value)))))
 401
 402 (defun calcFunc-betaB (x a b)
 403   (cond
 404    ((math-zerop x)
 405     '(float 0 0))
 406    ((math-equal-int x 1)
 407     (calcFunc-beta a b))
 408    ((not (math-numberp x)) (math-reject-arg x 'numberp))
 409    ((not (math-numberp a)) (math-reject-arg a 'numberp))
 410    ((not (math-numberp b)) (math-reject-arg b 'numberp))
 411    ((math-zerop a) (math-reject-arg a 'nonzerop))
 412    ((math-zerop b) (math-reject-arg b 'nonzerop))
 413    ((and (math-num-integerp b)
 414          (if (math-negp b)
 415              (math-reject-arg b 'range)
 416            (Math-natnum-lessp (setq b (math-trunc b)) 20)))
 417     (and calc-symbolic-mode (or (math-floatp a) (math-floatp b))
 418          (math-inexact-result))
 419     (math-mul
 420      (math-with-extra-prec 2
 421        (let* ((i 0)
 422               (term 1)
 423               (sum (math-div term a)))
 424          (while (< (setq i (1+ i)) b)
 425            (setq term (math-mul (math-div (math-mul term (- i b)) i) x)
 426                  sum (math-add sum (math-div term (math-add a i))))
 427            (math-working "beta" sum))
 428          sum))
 429      (math-pow x a)))
 430    ((and (math-num-integerp a)
 431          (if (math-negp a)
 432              (math-reject-arg a 'range)
 433            (Math-natnum-lessp (setq a (math-trunc a)) 20)))
 434     (math-sub (or math-current-beta-value (calcFunc-beta a b))
 435               (calcFunc-betaB (math-sub 1 x) b a)))
 436    (t
 437     (math-inexact-result)
 438     (math-with-extra-prec 2
 439       (setq x (math-float x))
 440       (setq a (math-float a))
 441       (setq b (math-float b))
 442       (let ((bt (math-exp-raw (math-add (math-mul a (math-ln-raw x))
 443                                         (math-mul b (math-ln-raw
 444                                                      (math-sub '(float 1 0)
 445                                                                x)))))))
 446         (if (Math-lessp x (math-div (math-add a '(float 1 0))
 447                                     (math-add (math-add a b) '(float 2 0))))
 448             (math-div (math-mul bt (math-beta-cfrac a b x)) a)
 449           (math-sub (or math-current-beta-value (calcFunc-beta a b))
 450                     (math-div (math-mul bt
 451                                         (math-beta-cfrac b a (math-sub 1 x)))
 452                               b))))))))
 453
 454 (defun math-beta-cfrac (a b x)
 455   (let ((qab (math-add a b))
 456         (qap (math-add a '(float 1 0)))
 457         (qam (math-add a '(float -1 0))))
 458     (math-beta-cfrac-step '(float 1 0)
 459                           (math-sub '(float 1 0)
 460                                     (math-div (math-mul qab x) qap))
 461                           '(float 1 0) '(float 1 0)
 462                           '(float 1 0)
 463                           qab qap qam a b x)))
 464
 465 (defun math-beta-cfrac-step (az bz am bm m qab qap qam a b x)
 466   (let* ((two-m (math-mul m '(float 2 0)))
 467          (d (math-div (math-mul (math-mul (math-sub b m) m) x)
 468                       (math-mul (math-add qam two-m) (math-add a two-m))))
 469          (ap (math-add az (math-mul d am)))
 470          (bp (math-add bz (math-mul d bm)))
 471          (d2 (math-neg
 472               (math-div (math-mul (math-mul (math-add a m) (math-add qab m)) x)
 473                         (math-mul (math-add qap two-m) (math-add a two-m)))))
 474          (app (math-add ap (math-mul d2 az)))
 475          (bpp (math-add bp (math-mul d2 bz)))
 476          (next (math-div app bpp)))
 477     (math-working "beta" next)
 478     (if (math-nearly-equal next az)
 479         next
 480       (math-beta-cfrac-step next '(float 1 0)
 481                             (math-div ap bpp) (math-div bp bpp)
 482                             (math-add m '(float 1 0))
 483                             qab qap qam a b x))))
 484
 485
 486 ;;; Bessel functions.
 487
 488 ;;; Should generalize this to handle arbitrary precision!
 489
 490 (defun calcFunc-besJ (v x)
 491   (or (math-numberp v) (math-reject-arg v 'numberp))
 492   (or (math-numberp x) (math-reject-arg x 'numberp))
 493   (let ((calc-internal-prec (min 8 calc-internal-prec)))
 494     (math-with-extra-prec 3
 495       (setq x (math-float (math-normalize x)))
 496       (setq v (math-float (math-normalize v)))
 497       (cond ((math-zerop x)
 498              (if (math-zerop v)
 499                  '(float 1 0)
 500                '(float 0 0)))
 501             ((math-inexact-result))
 502             ((not (math-num-integerp v))
 503              (let ((start (math-div 1 (calcFunc-fact v))))
 504                (math-mul (math-besJ-series start start
 505                                            0
 506                                            (math-mul '(float -25 -2)
 507                                                      (math-sqr x))
 508                                            v)
 509                          (math-pow (math-div x 2) v))))
 510             ((math-negp (setq v (math-trunc v)))
 511              (if (math-oddp v)
 512                  (math-neg (calcFunc-besJ (math-neg v) x))
 513                (calcFunc-besJ (math-neg v) x)))
 514             ((eq v 0)
 515              (math-besJ0 x))
 516             ((eq v 1)
 517              (math-besJ1 x))
 518             ((Math-lessp v (math-abs-approx x))
 519              (let ((j 0)
 520                    (bjm (math-besJ0 x))
 521                    (bj (math-besJ1 x))
 522                    (two-over-x (math-div 2 x))
 523                    bjp)
 524                (while (< (setq j (1+ j)) v)
 525                  (setq bjp (math-sub (math-mul (math-mul j two-over-x) bj)
 526                                      bjm)
 527                        bjm bj
 528                        bj bjp))
 529                bj))
 530             (t
 531              (if (Math-lessp 100 v) (math-reject-arg v 'range))
 532              (let* ((j (logior (+ v (math-isqrt-small (* 40 v))) 1))
 533                     (two-over-x (math-div 2 x))
 534                     (jsum nil)
 535                     (bjp '(float 0 0))
 536                     (sum '(float 0 0))
 537                     (bj '(float 1 0))
 538                     bjm ans)
 539                (while (> (setq j (1- j)) 0)
 540                  (setq bjm (math-sub (math-mul (math-mul j two-over-x) bj)
 541                                      bjp)
 542                        bjp bj
 543                        bj bjm)
 544                  (if (> (nth 2 (math-abs-approx bj)) 10)
 545                      (setq bj (math-mul bj '(float 1 -10))
 546                            bjp (math-mul bjp '(float 1 -10))
 547                            ans (and ans (math-mul ans '(float 1 -10)))
 548                            sum (math-mul sum '(float 1 -10))))
 549                  (or (setq jsum (not jsum))
 550                      (setq sum (math-add sum bj)))
 551                  (if (= j v)
 552                      (setq ans bjp)))
 553                (math-div ans (math-sub (math-mul 2 sum) bj))))))))
 554
 555 (defun math-besJ-series (sum term k zz vk)
 556   (math-working "besJ" sum)
 557   (setq k (1+ k)
 558         vk (math-add 1 vk)
 559         term (math-div (math-mul term zz) (math-mul k vk)))
 560   (let ((next (math-add sum term)))
 561     (if (math-nearly-equal next sum)
 562         next
 563       (math-besJ-series next term k zz vk))))
 564
 565 (defun math-besJ0 (x &optional yflag)
 566   (cond ((and (not yflag) (math-negp (calcFunc-re x)))
 567          (math-besJ0 (math-neg x)))
 568         ((Math-lessp '(float 8 0) (math-abs-approx x))
 569          (let* ((z (math-div '(float 8 0) x))
 570                 (y (math-sqr z))
 571                 (xx (math-add x
 572                               (math-read-number-simple "-0.785398164")))
 573                 (a1 (math-poly-eval y
 574                           (list
 575                            (math-read-number-simple "0.0000002093887211")
 576                            (math-read-number-simple "-0.000002073370639")
 577                            (math-read-number-simple "0.00002734510407")
 578                            (math-read-number-simple "-0.001098628627")
 579                            '(float 1 0))))
 580                 (a2 (math-poly-eval y
 581                           (list
 582                            (math-read-number-simple "-0.0000000934935152")
 583                            (math-read-number-simple "0.0000007621095161")
 584                            (math-read-number-simple "-0.000006911147651")
 585                            (math-read-number-simple "0.0001430488765")
 586                            (math-read-number-simple "-0.01562499995"))))
 587                 (sc (math-sin-cos-raw xx)))
 588                (if yflag
 589                    (setq sc (cons (math-neg (cdr sc)) (car sc))))
 590                (math-mul (math-sqrt
 591                           (math-div (math-read-number-simple "0.636619722")
 592                                     x))
 593                          (math-sub (math-mul (cdr sc) a1)
 594                                    (math-mul (car sc) (math-mul z a2))))))
 595          (t
 596           (let ((y (math-sqr x)))
 597             (math-div (math-poly-eval y
 598                             (list
 599                              (math-read-number-simple "-184.9052456")
 600                              (math-read-number-simple "77392.33017")
 601                              (math-read-number-simple "-11214424.18")
 602                              (math-read-number-simple "651619640.7")
 603                              (math-read-number-simple "-13362590354.0")
 604                              (math-read-number-simple "57568490574.0")))
 605                       (math-poly-eval y
 606                             (list
 607                              '(float 1 0)
 608                              (math-read-number-simple "267.8532712")
 609                              (math-read-number-simple "59272.64853")
 610                              (math-read-number-simple "9494680.718")
 611                              (math-read-number-simple "1029532985.0")
 612                              (math-read-number-simple "57568490411.0"))))))))
 613
 614 (defun math-besJ1 (x &optional yflag)
 615   (cond ((and (math-negp (calcFunc-re x)) (not yflag))
 616          (math-neg (math-besJ1 (math-neg x))))
 617         ((Math-lessp '(float 8 0) (math-abs-approx x))
 618          (let* ((z (math-div '(float 8 0) x))
 619                 (y (math-sqr z))
 620                 (xx (math-add x (math-read-number-simple "-2.356194491")))
 621                 (a1 (math-poly-eval y
 622                           (list
 623                            (math-read-number-simple "-0.000000240337019")
 624                            (math-read-number-simple "0.000002457520174")
 625                            (math-read-number-simple "-0.00003516396496")
 626                            '(float 183105 -8)
 627                            '(float 1 0))))
 628                 (a2 (math-poly-eval y
 629                           (list
 630                            (math-read-number-simple "0.000000105787412")
 631                            (math-read-number-simple "-0.00000088228987")
 632                            (math-read-number-simple "0.000008449199096")
 633                            (math-read-number-simple "-0.0002002690873")
 634                            (math-read-number-simple "0.04687499995"))))
 635                 (sc (math-sin-cos-raw xx)))
 636            (if yflag
 637                (setq sc (cons (math-neg (cdr sc)) (car sc)))
 638              (if (math-negp x)
 639                  (setq sc (cons (math-neg (car sc)) (math-neg (cdr sc))))))
 640            (math-mul (math-sqrt (math-div
 641                                  (math-read-number-simple "0.636619722")
 642                                  x))
 643                      (math-sub (math-mul (cdr sc) a1)
 644                                (math-mul (car sc) (math-mul z a2))))))
 645         (t
 646          (let ((y (math-sqr x)))
 647            (math-mul
 648             x
 649             (math-div (math-poly-eval y
 650                             (list
 651                              (math-read-number-simple "-30.16036606")
 652                              (math-read-number-simple "15704.4826")
 653                              (math-read-number-simple "-2972611.439")
 654                              (math-read-number-simple "242396853.1")
 655                              (math-read-number-simple "-7895059235.0")
 656                              (math-read-number-simple "72362614232.0")))
 657                       (math-poly-eval y
 658                             (list
 659                              '(float 1 0)
 660                              (math-read-number-simple "376.9991397")
 661                              (math-read-number-simple "99447.43394")
 662                              (math-read-number-simple "18583304.74")
 663                              (math-read-number-simple "2300535178.0")
 664                              (math-read-number-simple "144725228442.0")))))))))
 665
 666 (defun calcFunc-besY (v x)
 667   (math-inexact-result)
 668   (or (math-numberp v) (math-reject-arg v 'numberp))
 669   (or (math-numberp x) (math-reject-arg x 'numberp))
 670   (let ((calc-internal-prec (min 8 calc-internal-prec)))
 671     (math-with-extra-prec 3
 672       (setq x (math-float (math-normalize x)))
 673       (setq v (math-float (math-normalize v)))
 674       (cond ((not (math-num-integerp v))
 675              (let ((sc (math-sin-cos-raw (math-mul v (math-pi)))))
 676                (math-div (math-sub (math-mul (calcFunc-besJ v x) (cdr sc))
 677                                    (calcFunc-besJ (math-neg v) x))
 678                          (car sc))))
 679             ((math-negp (setq v (math-trunc v)))
 680              (if (math-oddp v)
 681                  (math-neg (calcFunc-besY (math-neg v) x))
 682                (calcFunc-besY (math-neg v) x)))
 683             ((eq v 0)
 684              (math-besY0 x))
 685             ((eq v 1)
 686              (math-besY1 x))
 687             (t
 688              (let ((j 0)
 689                    (bym (math-besY0 x))
 690                    (by (math-besY1 x))
 691                    (two-over-x (math-div 2 x))
 692                    byp)
 693                (while (< (setq j (1+ j)) v)
 694                  (setq byp (math-sub (math-mul (math-mul j two-over-x) by)
 695                                      bym)
 696                        bym by
 697                        by byp))
 698                by))))))
 699
 700 (defun math-besY0 (x)
 701   (cond ((Math-lessp (math-abs-approx x) '(float 8 0))
 702          (let ((y (math-sqr x)))
 703            (math-add
 704             (math-div (math-poly-eval y
 705                             (list
 706                              (math-read-number-simple "228.4622733")
 707                              (math-read-number-simple "-86327.92757")
 708                              (math-read-number-simple "10879881.29")
 709                              (math-read-number-simple "-512359803.6")
 710                              (math-read-number-simple "7062834065.0")
 711                              (math-read-number-simple "-2957821389.0")))
 712                       (math-poly-eval y
 713                             (list
 714                              '(float 1 0)
 715                              (math-read-number-simple "226.1030244")
 716                              (math-read-number-simple "47447.2647")
 717                              (math-read-number-simple "7189466.438")
 718                              (math-read-number-simple "745249964.8")
 719                              (math-read-number-simple "40076544269.0"))))
 720             (math-mul (math-read-number-simple "0.636619772")
 721                       (math-mul (math-besJ0 x) (math-ln-raw x))))))
 722         ((math-negp (calcFunc-re x))
 723          (math-add (math-besJ0 (math-neg x) t)
 724                    (math-mul '(cplx 0 2)
 725                              (math-besJ0 (math-neg x)))))
 726         (t
 727          (math-besJ0 x t))))
 728
 729 (defun math-besY1 (x)
 730   (cond ((Math-lessp (math-abs-approx x) '(float 8 0))
 731          (let ((y (math-sqr x)))
 732            (math-add
 733             (math-mul
 734              x
 735              (math-div (math-poly-eval y
 736                              (list
 737                               (math-read-number-simple "8511.937935")
 738                               (math-read-number-simple "-4237922.726")
 739                               (math-read-number-simple "734926455.1")
 740                               (math-read-number-simple "-51534381390.0")
 741                               (math-read-number-simple "1275274390000.0")
 742                               (math-read-number-simple "-4900604943000.0")))
 743                        (math-poly-eval y
 744                              (list
 745                               '(float 1 0)
 746                               (math-read-number-simple "354.9632885")
 747                               (math-read-number-simple "102042.605")
 748                               (math-read-number-simple "22459040.02")
 749                               (math-read-number-simple "3733650367.0")
 750                               (math-read-number-simple "424441966400.0")
 751                               (math-read-number-simple "24995805700000.0")))))
 752             (math-mul (math-read-number-simple "0.636619772")
 753                       (math-sub (math-mul (math-besJ1 x) (math-ln-raw x))
 754                                 (math-div 1 x))))))
 755         ((math-negp (calcFunc-re x))
 756          (math-neg
 757           (math-add (math-besJ1 (math-neg x) t)
 758                     (math-mul '(cplx 0 2)
 759                               (math-besJ1 (math-neg x))))))
 760         (t
 761          (math-besJ1 x t))))
 762
 763 (defun math-poly-eval (x coefs)
 764   (let ((accum (car coefs)))
 765     (while (setq coefs (cdr coefs))
 766       (setq accum (math-add (car coefs) (math-mul accum x))))
 767     accum))
 768
 769
 770 ;;;; Bernoulli and Euler polynomials and numbers.
 771
 772 (defun calcFunc-bern (n &optional x)
 773   (if (and x (not (math-zerop x)))
 774       (if (and calc-symbolic-mode (math-floatp x))
 775           (math-inexact-result)
 776         (math-build-polynomial-expr (math-bernoulli-coefs n) x))
 777     (or (math-num-natnump n) (math-reject-arg n 'natnump))
 778     (if (consp n)
 779         (progn
 780           (math-inexact-result)
 781           (math-float (math-bernoulli-number (math-trunc n))))
 782       (math-bernoulli-number n))))
 783
 784 (defun calcFunc-euler (n &optional x)
 785   (or (math-num-natnump n) (math-reject-arg n 'natnump))
 786   (if x
 787       (let* ((n1 (math-add n 1))
 788              (coefs (math-bernoulli-coefs n1))
 789              (fac (math-div (math-pow 2 n1) n1))
 790              (k -1)
 791              (x1 (math-div (math-add x 1) 2))
 792              (x2 (math-div x 2)))
 793         (if (math-numberp x)
 794             (if (and calc-symbolic-mode (math-floatp x))
 795                 (math-inexact-result)
 796               (math-mul fac
 797                         (math-sub (math-build-polynomial-expr coefs x1)
 798                                   (math-build-polynomial-expr coefs x2))))
 799           (calcFunc-collect
 800            (math-reduce-vec
 801             'math-add
 802             (cons 'vec
 803                   (mapcar (function
 804                            (lambda (c)
 805                              (setq k (1+ k))
 806                              (math-mul (math-mul fac c)
 807                                        (math-sub (math-pow x1 k)
 808                                                  (math-pow x2 k)))))
 809                           coefs)))
 810            x)))
 811     (math-mul (math-pow 2 n)
 812               (if (consp n)
 813                   (progn
 814                     (math-inexact-result)
 815                     (calcFunc-euler n '(float 5 -1)))
 816                 (calcFunc-euler n '(frac 1 2))))))
 817
 818 (defvar math-bernoulli-b-cache
 819   (list
 820    (list 'frac
 821          -174611
 822          (math-read-number-simple "802857662698291200000"))
 823    (list 'frac
 824          43867
 825          (math-read-number-simple "5109094217170944000"))
 826    (list 'frac
 827          -3617
 828          (math-read-number-simple "10670622842880000"))
 829    (list 'frac
 830          1
 831          (math-read-number-simple "74724249600"))
 832    (list 'frac
 833          -691
 834          (math-read-number-simple "1307674368000"))
 835    (list 'frac
 836          1
 837          (math-read-number-simple "47900160"))
 838    (list 'frac
 839          -1
 840          (math-read-number-simple "1209600"))
 841    (list 'frac
 842          1
 843          30240)
 844    (list 'frac
 845          -1
 846          720)
 847    (list 'frac
 848          1
 849          12)
 850    1 ))
 851
 852 (defvar math-bernoulli-B-cache
 853   '((frac -174611 330) (frac 43867 798)
 854     (frac -3617 510) (frac 7 6) (frac -691 2730)
 855     (frac 5 66) (frac -1 30) (frac 1 42)
 856     (frac -1 30) (frac 1 6) 1 ))
 857
 858 (defvar math-bernoulli-cache-size 11)
 859 (defun math-bernoulli-coefs (n)
 860   (let* ((coefs (list (calcFunc-bern n)))
 861          (nn (math-trunc n))
 862          (k nn)
 863          (term nn)
 864          coef
 865          (calc-prefer-frac (or (integerp n) calc-prefer-frac)))
 866     (while (>= (setq k (1- k)) 0)
 867       (setq term (math-div term (- nn k))
 868             coef (math-mul term (math-bernoulli-number k))
 869             coefs (cons (if (consp n) (math-float coef) coef) coefs)
 870             term (math-mul term k)))
 871     (nreverse coefs)))
 872
 873 (defun math-bernoulli-number (n)
 874   (if (= (% n 2) 1)
 875       (if (= n 1)
 876           '(frac -1 2)
 877         0)
 878     (setq n (/ n 2))
 879     (while (>= n math-bernoulli-cache-size)
 880       (let* ((sum 0)
 881              (nk 1)     ; nk = n-k+1
 882              (fact 1)   ; fact = (n-k+1)!
 883              ofact
 884              (p math-bernoulli-b-cache)
 885              (calc-prefer-frac t))
 886         (math-working "bernoulli B" (* 2 math-bernoulli-cache-size))
 887         (while p
 888           (setq nk (+ nk 2)
 889                 ofact fact
 890                 fact (math-mul fact (* nk (1- nk)))
 891                 sum (math-add sum (math-div (car p) fact))
 892                 p (cdr p)))
 893         (setq ofact (math-mul ofact (1- nk))
 894               sum (math-sub (math-div '(frac 1 2) ofact) sum)
 895               math-bernoulli-b-cache (cons sum math-bernoulli-b-cache)
 896               math-bernoulli-B-cache (cons (math-mul sum ofact)
 897                                            math-bernoulli-B-cache)
 898               math-bernoulli-cache-size (1+ math-bernoulli-cache-size))))
 899     (nth (- math-bernoulli-cache-size n 1) math-bernoulli-B-cache)))
 900
 901 ;;;   Bn = n! bn
 902 ;;;   bn = - sum_k=0^n-1 bk / (n-k+1)!
 903
 904 ;;; A faster method would be to use "tangent numbers", c.f., Concrete
 905 ;;; Mathematics pg. 273.
 906
 907
 908 ;;; Probability distributions.
 909
 910 ;;; Binomial.
 911 (defun calcFunc-utpb (x n p)
 912   (if math-expand-formulas
 913       (math-normalize (list 'calcFunc-betaI p x (list '+ (list '- n x) 1)))
 914     (calcFunc-betaI p x (math-add (math-sub n x) 1))))
 915 (put 'calcFunc-utpb 'math-expandable t)
 916
 917 (defun calcFunc-ltpb (x n p)
 918   (math-sub 1 (calcFunc-utpb x n p)))
 919 (put 'calcFunc-ltpb 'math-expandable t)
 920
 921 ;;; Chi-square.
 922 (defun calcFunc-utpc (chisq v)
 923   (if math-expand-formulas
 924       (math-normalize (list 'calcFunc-gammaQ (list '/ v 2) (list '/ chisq 2)))
 925     (calcFunc-gammaQ (math-div v 2) (math-div chisq 2))))
 926 (put 'calcFunc-utpc 'math-expandable t)
 927
 928 (defun calcFunc-ltpc (chisq v)
 929   (if math-expand-formulas
 930       (math-normalize (list 'calcFunc-gammaP (list '/ v 2) (list '/ chisq 2)))
 931     (calcFunc-gammaP (math-div v 2) (math-div chisq 2))))
 932 (put 'calcFunc-ltpc 'math-expandable t)
 933
 934 ;;; F-distribution.
 935 (defun calcFunc-utpf (f v1 v2)
 936   (if math-expand-formulas
 937       (math-normalize (list 'calcFunc-betaI
 938                             (list '/ v2 (list '+ v2 (list '* v1 f)))
 939                             (list '/ v2 2)
 940                             (list '/ v1 2)))
 941     (calcFunc-betaI (math-div v2 (math-add v2 (math-mul v1 f)))
 942                     (math-div v2 2)
 943                     (math-div v1 2))))
 944 (put 'calcFunc-utpf 'math-expandable t)
 945
 946 (defun calcFunc-ltpf (f v1 v2)
 947   (math-sub 1 (calcFunc-utpf f v1 v2)))
 948 (put 'calcFunc-ltpf 'math-expandable t)
 949
 950 ;;; Normal.
 951 (defun calcFunc-utpn (x mean sdev)
 952   (if math-expand-formulas
 953       (math-normalize
 954        (list '/
 955              (list '+ 1
 956                    (list 'calcFunc-erf
 957                          (list '/ (list '- mean x)
 958                                (list '* sdev (list 'calcFunc-sqrt 2)))))
 959              2))
 960     (math-mul (math-add '(float 1 0)
 961                         (calcFunc-erf
 962                          (math-div (math-sub mean x)
 963                                    (math-mul sdev (math-sqrt-2)))))
 964               '(float 5 -1))))
 965 (put 'calcFunc-utpn 'math-expandable t)
 966
 967 (defun calcFunc-ltpn (x mean sdev)
 968   (if math-expand-formulas
 969       (math-normalize
 970        (list '/
 971              (list '+ 1
 972                    (list 'calcFunc-erf
 973                          (list '/ (list '- x mean)
 974                                (list '* sdev (list 'calcFunc-sqrt 2)))))
 975              2))
 976     (math-mul (math-add '(float 1 0)
 977                         (calcFunc-erf
 978                          (math-div (math-sub x mean)
 979                                    (math-mul sdev (math-sqrt-2)))))
 980               '(float 5 -1))))
 981 (put 'calcFunc-ltpn 'math-expandable t)
 982
 983 ;;; Poisson.
 984 (defun calcFunc-utpp (n x)
 985   (if math-expand-formulas
 986       (math-normalize (list 'calcFunc-gammaP x n))
 987     (calcFunc-gammaP x n)))
 988 (put 'calcFunc-utpp 'math-expandable t)
 989
 990 (defun calcFunc-ltpp (n x)
 991   (if math-expand-formulas
 992       (math-normalize (list 'calcFunc-gammaQ x n))
 993     (calcFunc-gammaQ x n)))
 994 (put 'calcFunc-ltpp 'math-expandable t)
 995
 996 ;;; Student's t.  (As defined in Abramowitz & Stegun and Numerical Recipes.)
 997 (defun calcFunc-utpt (tt v)
 998   (if math-expand-formulas
 999       (math-normalize (list 'calcFunc-betaI
1000                             (list '/ v (list '+ v (list '^ tt 2)))
1001                             (list '/ v 2)
1002                             '(float 5 -1)))
1003     (calcFunc-betaI (math-div v (math-add v (math-sqr tt)))
1004                     (math-div v 2)
1005                     '(float 5 -1))))
1006 (put 'calcFunc-utpt 'math-expandable t)
1007
1008 (defun calcFunc-ltpt (tt v)
1009   (math-sub 1 (calcFunc-utpt tt v)))
1010 (put 'calcFunc-ltpt 'math-expandable t)
1011
1012 (provide 'calc-funcs)
1013
1014 ;; arch-tag: 421ddb7a-550f-4dda-a31c-06638ebfc43a
1015 ;;; calc-funcs.el ends here