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