Adjust thresholds for bigfloat so as to pass with cmucl.
[maxima.git] / src / gamma.lisp
blob01b7449b6d2370fd1cbb5141fd764429af5f6313
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;;;
3 ;;; Double Factorial, Incomplete Gamma function, ...
4 ;;;
5 ;;; This file will be extended with further functions related to the
6 ;;; Factorial and Gamma functions.
7 ;;;
8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9 ;;;
10 ;;; This file contains the following Maxima User functions:
11 ;;;
12 ;;; double_factorial(z)
13 ;;;
14 ;;; gamma_incomplete(a,z)
15 ;;; gamma_incomplete_generalized(a,z1,z2)
16 ;;; gamma_incomplete_regularized(a,z)
17 ;;;
18 ;;; log_gamma(z)
19 ;;;
20 ;;; erf(z)
21 ;;; erfc(z)
22 ;;; erfi(z)
23 ;;; erf_generalized(z1,z2)
24 ;;;
25 ;;; inverse_erf(z)
26 ;;; inverse_erfc(z)
27 ;;;
28 ;;; fresnel_s(z)
29 ;;; fresnel_c(z)
30 ;;;
31 ;;; beta_incomplete(a,b,z)
32 ;;; beta_incomplete_generalized(a,b,z1,z2)
33 ;;; beta_incomplete_regularized(a,b,z)
34 ;;;
35 ;;; Maxima User variable:
36 ;;;
37 ;;; $factorial_expand - Allows argument simplificaton for expressions like
38 ;;; double_factorial(n-1) and double_factorial(2*k+n)
39 ;;; $beta_expand - Switch on further expansions for the Beta functions
40 ;;;
41 ;;; $erf_representation - When T erfc, erfi, erf_generalized, fresnel_s
42 ;;; and fresnel_c are transformed to erf.
43 ;;; $erf_%iargs - Enable simplification of Erf and Erfi for
44 ;;; imaginary arguments
45 ;;; $hypergeometric_representation
46 ;;; - Enables transformation to a Hypergeometric
47 ;;; representation for fresnel_s and fresnel_c
48 ;;;
49 ;;; Maxima User variable (not definied in this file):
50 ;;;
51 ;;; $factlim - biggest integer for numerically evaluation
52 ;;; of the Double factorial
53 ;;; $gamma_expand - Expansion of the Gamma und Incomplete Gamma
54 ;;; function for some special cases
55 ;;;
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57 ;;; This library is free software; you can redistribute it and/or modify it
58 ;;; under the terms of the GNU General Public License as published by the
59 ;;; Free Software Foundation; either version 2 of the License, or (at
60 ;;; your option) any later version.
61 ;;;
62 ;;; This library is distributed in the hope that it will be useful, but
63 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
64 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
65 ;;; Library General Public License for more details.
66 ;;;
67 ;;; You should have received a copy of the GNU General Public License along
68 ;;; with this library; if not, write to the Free Software
69 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
70 ;;;
71 ;;; Copyright (C) 2008 Dieter Kaiser
72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
74 (in-package :maxima)
76 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
78 (defmvar $erf_representation nil
79 "When not false, error functions are transformed to erf, erfc, or erfi
80 depending on the value of $erf_representation."
81 ;; Need to use the noun form of these.
82 :setting-list (nil t %erf %erfc %erfi))
84 (defmvar $erf_%iargs nil
85 "When T erf and erfi simplifies for an imaginary argument.")
87 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
88 ;;; The following functions test if numerical evaluation has to be done.
89 ;;; The functions should help to test for numerical evaluation more consistent
90 ;;; and without complicated conditional tests including more than one or two
91 ;;; arguments.
92 ;;;
93 ;;; The functions take a list of arguments. All arguments have to be a CL or
94 ;;; Maxima number. If all arguments are numbers we have two cases:
95 ;;; 1. $numer is T we return T. The function has to be evaluated numerically.
96 ;;; 2. One of the args is a float or a bigfloat. Evaluate numerically.
97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99 ;;; Test for numerically evaluation in float precision
101 (defun float-numerical-eval-p (&rest args)
102 (let ((flag nil))
103 (dolist (ll args)
104 (when (not (float-or-rational-p ll))
105 (return-from float-numerical-eval-p nil))
106 (when (floatp ll) (setq flag t)))
107 (if (or $numer flag) t nil)))
109 ;;; Test for numerically evaluation in complex float precision
111 (defun complex-float-numerical-eval-p (&rest args)
112 "Determine if ARGS consists of numerical values by determining if
113 the real and imaginary parts of each arg are nuemrical (but not
114 bigfloats). A non-NIL result is returned if at least one of args is
115 a floating-point value or if numer is true. If the result is
116 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P"
117 (let (flag values)
118 (dolist (ll args)
119 (multiple-value-bind (bool rll ill)
120 (complex-number-p ll 'float-or-rational-p)
121 (unless bool
122 (return-from complex-float-numerical-eval-p nil))
123 ;; Always save the result from complex-number-p. But for backward
124 ;; compatibility, only set the flag if any item is a float.
125 (push (add rll (mul ill '$%i)) values)
126 (setf flag (or flag (or (floatp rll) (floatp ill))))))
127 (when (or $numer flag)
128 ;; Return the values in the same order as the args!
129 (nreverse values))))
131 ;;; Test for numerically evaluation in bigfloat precision
133 (defun bigfloat-numerical-eval-p (&rest args)
134 (let ((flag nil))
135 (dolist (ll args)
136 (when (not (bigfloat-or-number-p ll))
137 (return-from bigfloat-numerical-eval-p nil))
138 (when ($bfloatp ll)
139 (setq flag t)))
140 (if (or $numer flag) t nil)))
142 ;;; Test for numerically evaluation in complex bigfloat precision
144 (defun complex-bigfloat-numerical-eval-p (&rest args)
145 "Determine if ARGS consists of numerical values by determining if
146 the real and imaginary parts of each arg are nuemrical (including
147 bigfloats). A non-NIL result is returned if at least one of args is
148 a floating-point value or if numer is true. If the result is
149 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P."
151 (let (flag values)
152 (dolist (ll args)
153 (multiple-value-bind (bool rll ill)
154 (complex-number-p ll 'bigfloat-or-number-p)
155 (unless bool
156 (return-from complex-bigfloat-numerical-eval-p nil))
157 ;; Always save the result from complex-number-p. But for backward
158 ;; compatibility, only set the flag if any item is a bfloat.
159 (push (add rll (mul ill '$%i)) values)
160 (when (or ($bfloatp rll) ($bfloatp ill))
161 (setf flag t))))
162 (when (or $numer flag)
163 ;; Return the values in the same order as the args!
164 (nreverse values))))
166 ;;; Test for numerical evaluation in any precision, real or complex.
167 (defun numerical-eval-p (&rest args)
168 (or (apply 'float-numerical-eval-p args)
169 (apply 'complex-float-numerical-eval-p args)
170 (apply 'bigfloat-numerical-eval-p args)
171 (apply 'complex-bigfloat-numerical-eval-p args)))
173 ;;; Check for an integer or a float or bigfloat representation. When we
174 ;;; have a float or bigfloat representation return the integer value.
176 (defun integer-representation-p (x)
177 (let ((val nil))
178 (cond ((integerp x) x)
179 ((and (floatp x) (= 0 (nth-value 1 (truncate x))))
180 (nth-value 0 (truncate x)))
181 ((and ($bfloatp x)
182 (eq ($sign (sub (setq val ($truncate x)) x)) '$zero))
183 val)
184 (t nil))))
186 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
188 ;;; The changes to the parser to connect the operator !! to double_factorial(z)
190 ;(def-mheader |$!!| (%double_factorial))
192 ;(def-led (|$!!| 160.) (op left)
193 ; (list '$expr
194 ; (mheader '$!!)
195 ; (convert left '$expr)))
197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
199 ;;; The implementation of the function Double factorial
201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
203 ;;; Double factorial distributes over bags
205 (defprop %double_factorial (mlist $matrix mequal) distribute_over)
207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209 ;;; Double factorial has mirror symmetry
211 (defprop %double_factorial t commutes-with-conjugate)
213 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
215 ;;; Differentiation of Double factorial
217 (defprop %double_factorial
218 ((z)
219 ((mtimes)
220 ((rat) 1 2)
221 ((%double_factorial) z)
222 ((mplus)
223 ((%log) 2)
224 ((mqapply)
225 (($psi array) 0)
226 ((mplus) 1 ((mtimes) ((rat) 1 2) z)))
227 ((mtimes)
228 ((rat) 1 2) $%pi
229 ((%log) ((mtimes) 2 ((mexpt) $%pi -1)))
230 ((%sin) ((mtimes) $%pi z))))))
231 grad)
233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
235 ;;; Double factorial is a simplifying function
237 (def-simplifier double_factorial (z)
238 (cond
239 ((and (fixnump z) (> z -1) (or (minusp $factlim) (< z $factlim)))
240 ;; Positive Integer less then $factlim or $factlim is -1. Call gfact.
241 (gfact z (floor (/ z 2)) 2))
243 ((and (mnump z)
244 (eq ($sign z) '$neg)
245 (zerop1 (sub (simplify (list '(%truncate) (div z 2))) (div z 2))))
246 ;; Even negative integer or real representation. Not defined.
247 (simp-domain-error
248 (intl:gettext
249 "double_factorial: double_factorial(~:M) is undefined.") z))
251 ((or (integerp z) ; at this point odd negative integer. Evaluate.
252 (complex-float-numerical-eval-p z))
253 (cond
254 ((and (integerp z) (= z -1)) 1) ; Special cases -1 and -3
255 ((and (integerp z) (= z -3)) -1)
257 ;; Odd negative integer, float or complex float.
258 (complexify
259 (double-factorial
260 (complex ($float ($realpart z)) ($float ($imagpart z))))))))
262 ((and (not (ratnump z))
263 (complex-bigfloat-numerical-eval-p z))
264 ;; bigfloat or complex bigfloat.
265 (bfloat-double-factorial
266 (add ($bfloat ($realpart z)) (mul '$%i ($bfloat ($imagpart z))))))
268 ;; double_factorial(inf) -> inf
269 ((eq z '$inf) '$inf)
271 ((and $factorial_expand
272 (mplusp z)
273 (integerp (cadr z)))
274 (let ((k (cadr z))
275 (n (simplify (cons '(mplus) (cddr z)))))
276 (cond
277 ((= k -1)
278 ;; Special case double_factorial(n-1)
279 ;; Not sure if this simplification is useful.
280 (div (simplify (list '(mfactorial) n))
281 (simplify (list '(%double_factorial) n))))
282 ((= k (* 2 (truncate (/ k 2))))
283 ;; Special case double_factorial(2*k+n), k integer
284 (setq k (/ k 2))
285 ($factor ; we get more simple expression when factoring
286 (mul
287 (power 2 k)
288 (simplify (list '($pochhammer) (add (div n 2) 1) k))
289 (simplify (list '(%double_factorial) n)))))
291 (give-up)))))
294 (give-up))))
296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
297 ;;; Double factorial for a complex float argument. The result is a CL complex.
298 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
300 (defun double-factorial (z)
301 (let ((pival (float pi)))
303 (expt
304 (/ 2 pival)
305 (/ (- 1 (cos (* pival z))) 4))
306 (expt 2e0 (/ z 2))
307 (gamma-lanczos (+ 1 (/ z 2))))))
309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
310 ;;; Double factorial for a bigfloat or complex bigfloat argument
311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
313 (defun bfloat-double-factorial (z)
314 (let* ((pival ($bfloat '$%pi))
315 (bigfloat1 ($bfloat bigfloatone))
316 (bigfloat2 (add bigfloat1 bigfloat1))
317 (bigfloat4 (add bigfloat2 bigfloat2))
318 ($ratprint nil))
319 (cmul
320 (cpower
321 (cdiv bigfloat2 pival)
322 (cdiv (sub bigfloat1
323 (simplify (list '(%cos) (cmul pival z)))) bigfloat4))
324 (cmul
325 (cpower bigfloat2 (cdiv z bigfloat2))
326 (simplify (list '(%gamma) (add bigfloat1 (cdiv z bigfloat2))))))))
328 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
330 ;;; The implementation of the Incomplete Gamma function
332 ;;; A&S 6.5.3:
334 ;;; inf
335 ;;; /
336 ;;; [ a - 1 - t
337 ;;; gamma_incomplete(a, z) = I t %e dt
338 ;;; ]
339 ;;; /
340 ;;; z
342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
344 (defvar *debug-gamma* nil)
346 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
349 ;;; Incomplete Gamma distributes over bags
351 (defprop %gamma_incomplete (mlist $matrix mequal) distribute_over)
353 ;;; Incomplete Gamma function has not mirror symmetry for z on the negative
354 ;;; real axis. We support a conjugate-function which test this case.
356 (defprop %gamma_incomplete conjugate-gamma-incomplete conjugate-function)
358 (defun conjugate-gamma-incomplete (args)
359 (let ((a (first args)) (z (second args)))
360 (cond ((off-negative-real-axisp z)
361 ;; Definitely not on the negative real axis for z. Mirror symmetry.
362 (simplify
363 (list
364 '(%gamma_incomplete)
365 (simplify (list '($conjugate) a))
366 (simplify (list '($conjugate) z)))))
368 ;; On the negative real axis or no information. Unsimplified.
369 (list
370 '($conjugate simp)
371 (simplify (list '(%gamma_incomplete) a z)))))))
373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
375 ;;; Derivative of the Incomplete Gamma function
377 (putprop '%gamma_incomplete
378 `((a z)
379 ,(lambda (a z)
380 (cond ((member ($sign a) '($pos $pz))
381 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2
382 ;; function and the Generalized Incomplete Gamma function
383 ;; (functions.wolfram.com), only for a>0.
384 `((mplus)
385 ((mtimes)
386 ((mexpt) ((%gamma) ,a) 2)
387 ((mexpt) ,z ,a)
388 (($hypergeometric_regularized)
389 ((mlist) ,a ,a)
390 ((mlist) ((mplus) 1 ,a) ((mplus) 1 ,a))
391 ((mtimes) -1 ,z)))
392 ((mtimes) -1
393 ((%gamma_incomplete_generalized) ,a 0 ,z)
394 ((%log) ,z))
395 ((mtimes)
396 ((%gamma) ,a)
397 ((mqapply) (($psi array) 0) ,a))))
399 ;; No derivative. Maxima generates a noun form.
400 nil)))
401 ;; The derivative wrt z
402 ((mtimes) -1
403 ((mexpt) $%e ((mtimes) -1 z))
404 ((mexpt) z ((mplus) -1 a))))
405 'grad)
407 ;;; Integral of the Incomplete Gamma function
409 (defprop %gamma_incomplete
410 ((a z)
412 ((mplus)
413 ((mtimes) -1 ((%gamma_incomplete) ((mplus) 1 a) z))
414 ((mtimes) ((%gamma_incomplete) a z) z)))
415 integral)
417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
419 ;;; We support a simplim%function. The function is looked up in simplimit and
420 ;;; handles specific values of the function.
422 (defprop %gamma_incomplete simplim%gamma_incomplete simplim%function)
424 (defun simplim%gamma_incomplete (expr var val)
425 ;; Set preserve-direction to true and find the limit of each argument.
426 (let* ((preserve-direction t)
427 (a (limit (cadr expr) var val 'think))
428 (z (limit (caddr expr) var val 'think)))
429 (cond
430 ;; z in {minf, inf, infinity}, use http://dlmf.nist.gov/8.11#i
431 ((or (eq z '$infinity)
432 (eq z '$inf)
433 (eq z '$minf))
434 ;; Revert a & z to the arguments of gamma_incomplete.
435 (setq a (cadr expr))
436 (setq z (caddr expr))
437 ;; Use gamma_incomplete(a,z) = z^(a-1)/exp(z) + ... for
438 ;; fixed a and |z| --> inf. Unfortunately, limit(x*exp(%i*x),x,inf) = und.
439 ;; And that makes limit(gamma_incomplete(2, -%i*x), x, inf) = und, not
440 ;; infinity (this is a test in rtest_limit) But this bug needs to be fixed
441 ;; elsewhere. When a isn't fixed, give up.
442 (if (freeof var a)
443 (limit (div (ftake 'mexpt z (sub a 1)) (ftake 'mexpt '$%e z)) var val 'think)
444 (throw 'limit t)))
446 ((and (eql a 0) (eq t (mgrp 0 z)))
447 (let ((im (behavior (cdr (risplit (caddr expr))) var val)))
448 (cond ((eql im -1)
449 (sub (mul '$%i '$%pi) (ftake '%expintegral_ei (mul -1 z))))
450 ((eql im 1)
451 (sub (mul -1 '$%i '$%pi) (ftake '%expintegral_ei (mul -1 z))))
452 (t (throw 'limit nil)))))
454 ;; z in {zerob, 0, zeroa}.
455 ((and (freeof var a) (or (eql z 0) (eq z '$zeroa) (eq z '$zerob)))
456 ;; Two cases: (i) a <= 0 & integer (ii) a not a negative integer.
457 ;; Revert a & z to the arguments of gamma_incomplete.
458 (setq a (cadr expr))
459 (setq z (caddr expr))
460 (cond ((and ($featurep a '$integer) (eq t (mgqp 0 a)))
461 ;; gamma_incomplete(a,n) = - (-1)^(-a) log(z)/(-a)! + ...
462 (setq a (sub 0 a))
463 (limit (div (mul -1 (ftake 'mexpt -1 a) (ftake '%log z))
464 (ftake 'mfactorial a)) var val 'think))
466 (limit (sub (ftake '%gamma a) (div (ftake 'mexpt z a) a)) var val 'think))))
467 ;; z is on the branch cut. We need to know if the imaginary part of
468 ;; (caddr exp) approaches zero from above or below. The incomplete
469 ;; gamma function is continuous from above its branch cut.
471 ((eq t (mgrp 0 z))
472 (let ((im (behavior (cdr (risplit (caddr expr))) var val)))
473 (cond ((eql im 1) ; use direct substitution
474 (ftake '%gamma_incomplete a z))
475 ((eql im -1)
476 (sub
477 (ftake '%gamma a)
478 (mul (ftake 'mexpt '$%e (mul -2 '$%i '$%pi a))
479 (sub (ftake '%gamma a) (ftake '%gamma_incomplete a z)))))
480 ((eql im 0)
481 (throw 'limit nil)))))
483 ((or (eq a '$ind) (eq z '$ind))
484 ;; Revert a & z to the arguments of gamma_incomplete. When z is
485 ;; off the negative real axis or a is not a negative integer,
486 ;; return ind.
487 (setq a (cadr expr))
488 (setq z (caddr expr))
489 (if (or (off-negative-real-axisp z)
490 (not (and ($featurep a '$integer) (eq t (mgqp 0 a))))) '$ind
491 (throw 'limit nil)))
492 ((or (eq a '$und) (eq z '$und)) '$und)
493 ((or (null a)
494 (null z)
495 (extended-real-p a)
496 (extended-real-p z))
497 (throw 'limit nil))
499 ;; All other cases are handled by the simplifier of the function.
500 (ftake '%gamma_incomplete a z)))))
502 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
506 ;;; Implementation of the Lower Incomplete gamma function:
508 ;;; A&S 6.5.2
510 ;;; z
511 ;;; /
512 ;;; [ a - 1 - t
513 ;;; gamma_incomplete_lower(a, z) = I t %e dt
514 ;;; ]
515 ;;; /
516 ;;; 0
517 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
518 ;;; distribute over bags (aggregates)
520 (defprop %gamma_incomplete_lower (mlist $matrix mequal) distribute_over)
522 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
524 ;; (defprop %gamma_incomplete_lower ??? grad) WHAT TO PUT HERE ??
527 ;; Handles some special cases for the order a and simplifies it to an
528 ;; equivalent form, possibly involving erf and gamma_incomplete_lower
529 ;; to a lower order.
530 (def-simplifier gamma_incomplete_lower (a z)
531 (cond
532 ((or
533 (float-numerical-eval-p a z)
534 (complex-float-numerical-eval-p a z)
535 (bigfloat-numerical-eval-p a z)
536 (complex-bigfloat-numerical-eval-p a z))
537 (ftake '%gamma_incomplete_generalized a 0 z))
538 ((gamma-incomplete-lower-expand a z))
539 ($hypergeometric_representation
540 ;; We make use of the fact that gamma_incomplete_lower(a,z) +
541 ;; gamma_incomplete(a,z) = gamma(a). Thus,
542 ;; gamma_incomplete_lower(a,z) = gamma(a)-gamma_incomplete(a,z).
543 ;; And we know the hypergeometric form for gamma_incomplete.
544 (sub (ftake '%gamma a)
545 (ftake '%gamma_incomplete a z)))
547 (give-up))))
549 ;; Try to express gamma_incomplete_lower(a,z) in simpler terms for
550 ;; special values of the order a. If we can't, return NIL to say so.
551 (defun gamma-incomplete-lower-expand (a z)
552 (cond ((and $gamma_expand (integerp a) (eql a 1))
553 ;; gamma_incomplete_lower(0, x) = 1-exp(x)
554 (sub 1 (m^t '$%e (neg z))))
555 ((and $gamma_expand (integerp a) (plusp a))
556 ;; gamma_incomplete_lower(a,z) can be simplified if a is a
557 ;; positive integer. Since gamma_incomplete_lower(a,z) =
558 ;; gamma(a) - gamma_incomplete(a,z), use gamma_incomplete to
559 ;; get the result.
560 (sub (ftake* '%gamma a)
561 (take '(%gamma_incomplete) a z)))
562 ((and $gamma_expand (alike1 a 1//2))
563 ;; A&S 6.5.12:
565 ;; gamma_incomplete_lower(1/2,x^2) = sqrt(%pi)*erf(x)
567 ;; gamma_incomplete_lower(1/2,z) = sqrt(%pi)*erf(sqrt(x))
569 (mul (power '$%pi '((rat simp) 1 2))
570 (take '(%erf) (power z '((rat simp) 1 2)))))
571 ((and $gamma_expand (mplusp a) (integerp (cadr a)))
572 ;; gamma_incomplete_lower(a+n,z), where n is an integer
573 (let ((n (cadr a))
574 (a (simplify (cons '(mplus) (cddr a)))))
575 (cond
576 ((> n 0)
577 ;; gamma_incomplete_lower(a+n,z). See DLMF 8.8.7:
579 ;; gamma_incomplete_lower(a+n,z)
580 ;; = pochhammer(a,n)*gamma_incomplete_lower(a,z)
581 ;; -z^a*exp(-z)*sum(gamma(a+n)gamma(a+k+1)*z^k,k,0,n-1)
582 (sub
583 (mul
584 (simplify (list '($pochhammer) a n))
585 (simplify (list '(%gamma_incomplete_lower) a z)))
586 (mul
587 (power z a)
588 (power '$%e (mul -1 z))
589 (let ((gamma-a+n (ftake* '%gamma (add a n)))
590 (index (gensumindex))
591 ($simpsum t))
592 (simpsum1
593 (mul
594 (div gamma-a+n
595 (ftake* '%gamma (add a index 1)))
596 (power z index))
597 index 0 (add n -1))))))
598 ((< n 0)
599 (setq n (- n))
600 ;; See DLMF 8.8.8. For simplicity let g(a,z) = gamma_incomplete_lower(a,z).
602 ;; g(a,z) = gamma(a)/gamma(a-n)*g(a-n,z)
603 ;; - z^(a-1)*exp(z)*sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
605 ;; Rewrite:
606 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
607 ;; + gamma(a-n)/gamma(a)*z^(a-1)*exp(-z)
608 ;; * sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
609 ;; Or
610 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
611 ;; + z^(a-1)*exp(-z)
612 ;; * sum(gamma(a-n)/gamma(a-k)*z^(-k),k,0,n-1)
613 (let ((gamma-a-n (ftake* '%gamma (sub a n)))
614 (index (gensumindex))
615 ($simpsum t))
616 (add
617 (mul
618 (div gamma-a-n
619 (list '(%gamma) a))
620 (simplify (list '(%gamma_incomplete_lower) a z)))
621 (mul
622 (power z (sub a 1))
623 (power '$%e (mul -1 z))
624 (simpsum1
625 (mul
626 (div gamma-a-n
627 (ftake* '%gamma (sub a index)))
628 (power z (mul -1 index)))
629 index 0 (add n -1)))))))))
630 ((and $gamma_expand (consp a) (eq 'rat (caar a))
631 (integerp (second a))
632 (integerp (third a)))
633 ;; gamma_incomplete_lower of (numeric) rational order.
634 ;; Expand it out so that the resulting order is between 0 and
635 ;; 1.
636 (multiple-value-bind (n order)
637 (floor (/ (second a) (third a)))
638 ;; a = n + order where 0 <= order < 1.
639 (let ((rat-order (rat (numerator order) (denominator order))))
640 (cond
641 ((zerop n)
642 ;; Nothing to do if the order is already between 0 and 1
643 (list '(%gamma_incomplete_lower simp) a z))
645 ;; Use gamma_incomplete(a+n,z) above. and then substitute
646 ;; a=order. This works for n positive or negative.
647 (let* ((ord (gensym))
648 (g (simplify (list '(%gamma_incomplete_lower) (add ord n) z))))
649 ($substitute rat-order ord g)))))))
651 ;; No expansion so return nil to indicate that
652 nil)))
654 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
656 ;;; Incomplete Gamma function is a simplifying function
658 (def-simplifier gamma_incomplete (a z)
659 (let (($simpsum t)
660 (ratorder))
661 (cond
663 ;; Check for specific values
665 ((zerop1 z)
666 ;; gamma_incomplete(v,0) is gamma(v) only if the realpart(v) >
667 ;; 0. If realpart(v) <= 0, gamma_incomplete is undefined. For
668 ;; all other cases, return the noun form.
669 (let ((sgn ($sign ($realpart a))))
670 (cond ((member sgn '($neg $zero))
671 (simp-domain-error
672 (intl:gettext
673 "gamma_incomplete: gamma_incomplete(~:M,~:M) is undefined.")
674 a z))
675 ((member sgn '($pos $pz)) ($gamma a))
676 (t (give-up)))))
678 ((eq z '$inf) 0)
679 ((and (eq z '$minf)
680 (eql a 0))
681 '$infinity)
683 ;; Check for numerical evaluation in Float or Bigfloat precision
685 ((float-numerical-eval-p a z)
686 (when *debug-gamma*
687 (format t "~&SIMP-GAMMA-INCOMPLETE in float-numerical-eval-p~%"))
688 ;; a and z are Maxima numbers, at least one has a float value
689 (let ((a ($float a))
690 (z ($float z)))
691 (cond
692 ((or (= a 0.0)
693 (and (= 0 (- a (truncate a)))
694 (< a 0.0)))
695 ;; a is zero or a negative float representing an integer.
696 ;; For these cases the numerical routines of gamma-incomplete
697 ;; do not work. Call the numerical routine for the Exponential
698 ;; Integral E(n,z). The routine is called with a positive integer!.
699 (setq a (truncate a))
700 (complexify (* (expt z a) (expintegral-e (- 1 a) z))))
702 (complexify (gamma-incomplete a z))))))
704 ((complex-float-numerical-eval-p a z)
705 (when *debug-gamma*
706 (format t
707 "~&SIMP-GAMMA-INCOMPLETE in complex-float-numerical-eval-p~%"))
708 ;; a and z are Maxima numbers, at least one is a complex value and
709 ;; we have at least one float part
710 (let ((ca (complex ($float ($realpart a)) ($float ($imagpart a))))
711 (cz (complex ($float ($realpart z)) ($float ($imagpart z)))))
712 (cond
713 ((and (= (imagpart ca) 0.0)
714 (or (= (realpart ca) 0.0)
715 (and (= 0 (- (realpart ca) (truncate (realpart ca))))
716 (< (realpart ca) 0.0))))
717 ;; Call expintegral-e. See comment above.
718 (setq ca (truncate (realpart ca)))
719 (complexify (* (expt cz ca) (expintegral-e (- 1 ca) cz))))
721 (complexify (gamma-incomplete ca cz))))))
723 ((bigfloat-numerical-eval-p a z)
724 (when *debug-gamma*
725 (format t "~&SIMP-GAMMA-INCOMPLETE in bigfloat-numerical-eval-p~%"))
726 (let ((a ($bfloat a))
727 (z ($bfloat z)))
728 (cond
729 ((or (eq ($sign a) '$zero)
730 (and (eq ($sign (sub a ($truncate a))) '$zero)
731 (eq ($sign a) '$neg)))
732 ;; Call bfloat-expintegral-e. See comment above.
733 (setq a ($truncate a))
734 ($rectform (mul (power z a) (bfloat-expintegral-e (- 1 a) z))))
736 (bfloat-gamma-incomplete a z)))))
738 ((complex-bigfloat-numerical-eval-p a z)
739 (when *debug-gamma*
740 (format t
741 "~&SIMP-GAMMA-INCOMPLETE in complex-bigfloat-numerical-eval-p~%"))
742 (let ((ca (add ($bfloat ($realpart a))
743 (mul '$%i ($bfloat ($imagpart a)))))
744 (cz (add ($bfloat ($realpart z))
745 (mul '$%i ($bfloat ($imagpart z))))))
746 (cond
747 ((and (eq ($sign ($imagpart ca)) '$zero)
748 (or (eq ($sign ($realpart ca)) '$zero)
749 (and (eq ($sign (sub ($realpart ca)
750 ($truncate ($realpart ca))))
751 '$zero)
752 (eq ($sign ($realpart ca)) '$neg))))
753 ;; Call bfloat-expintegral-e. See comment above.
754 (when *debug-gamma*
755 (format t
756 "~& bigfloat-numerical-eval-p calls bfloat-expintegral-e~%"))
757 (setq a ($truncate ($realpart a)))
758 ($rectform (mul (power cz a)
759 (bfloat-expintegral-e (- 1 a) cz))))
761 (complex-bfloat-gamma-incomplete ca cz)))))
763 ;; Check for transformations and argument simplification
765 ((and $gamma_expand (integerp a))
766 ;; Integer or a symbol declared to be an integer. Expand in a series.
767 (let ((sgn ($sign a)))
768 (cond
769 ((eq sgn '$zero)
770 (add
771 (mul -1
772 (simplify (list '(%expintegral_ei) (mul -1 z))))
773 (mul
774 '((rat simp) 1 2)
775 (sub
776 (simplify (list '(%log) (mul -1 z)))
777 (simplify (list '(%log) (div -1 z)))))
778 (mul -1 (simplify (list '(%log) z)))))
779 ((member sgn '($pos $pz))
780 (mul
781 (simplify (list '(%gamma) a))
782 (power '$%e (mul -1 z))
783 (let ((index (gensumindex)))
784 (simpsum1
785 (div
786 (power z index)
787 (let (($gamma_expand nil))
788 ;; Simplify gamma, but do not expand to avoid division
789 ;; by zero.
790 (simplify (list '(%gamma) (add index 1)))))
791 index 0 (sub a 1)))))
792 ((member sgn '($neg $nz))
793 (sub
794 (mul
795 (div
796 (power -1 (add (mul -1 a) -1))
797 (simplify (list '(%gamma) (add (mul -1 a) 1))))
798 (add
799 (simplify (list '(%expintegral_ei) (mul -1 z)))
800 (mul
801 '((rat simp) -1 2)
802 (sub
803 (simplify (list '(%log) (mul -1 z)))
804 (simplify (list '(%log) (div -1 z)))))
805 (simplify (list '(%log) z))))
806 (mul
807 (power '$%e (mul -1 z))
808 (let ((index (gensumindex)))
809 (simpsum1
810 (div
811 (power z (add index a -1))
812 (simplify (list '($pochhammer) a index)))
813 index 1 (mul -1 a))))))
814 (t (give-up)))))
816 ((and $gamma_expand (setq ratorder (max-numeric-ratio-p a 2)))
817 ;; We have a half integral order and $gamma_expand is not NIL.
818 ;; We expand in a series with the Erfc function
819 (setq ratorder (- ratorder (/ 1 2)))
820 (cond
821 ((equal ratorder 0)
822 (mul
823 (power '$%pi '((rat simp) 1 2))
824 (simplify (list '(%erfc) (power z '((rat simp) 1 2))))))
825 ((> ratorder 0)
826 (sub
827 (mul
828 (simplify (list '(%gamma) a))
829 (simplify (list '(%erfc) (power z '((rat simp) 1 2)))))
830 (mul
831 (power -1 (sub ratorder 1))
832 (power '$%e (mul -1 z))
833 (power z '((rat simp) 1 2))
834 (let ((index (gensumindex)))
835 (simpsum1
836 (mul -1 ; we get more simple results
837 (simplify ; when multiplying with -1
838 (list
839 '($pochhammer)
840 (sub '((rat simp) 1 2) ratorder)
841 (sub ratorder (add index 1))))
842 (power (mul -1 z) index))
843 index 0 (sub ratorder 1))))))
844 ((< ratorder 0)
845 (setq ratorder (- ratorder))
846 (sub
847 (div
848 (mul
849 (power -1 ratorder)
850 (power '$%pi '((rat simp) 1 2))
851 (simplify (list '(%erfc) (power z '((rat simp) 1 2)))))
852 (simplify (list '($pochhammer) '((rat simp) 1 2) ratorder)))
853 (mul
854 (power z (sub '((rat simp) 1 2) ratorder))
855 (power '$%e (mul -1 z))
856 (let ((index (gensumindex)))
857 (simpsum1
858 (div
859 (power z index)
860 (simplify
861 (list
862 '($pochhammer)
863 (sub '((rat simp) 1 2) ratorder)
864 (add index 1))))
865 index 0 (sub ratorder 1))))))))
867 ((and $gamma_expand (mplusp a) (integerp (cadr a)))
868 ;; Handle gamma_incomplete(a+n, z), where n is a numerical integer
869 (let ((n (cadr a))
870 (a (simplify (cons '(mplus) (cddr a)))))
871 (cond
872 ((> n 0)
873 ;; See DLMF 8.8.9: https://dlmf.nist.gov/8.8.E9
875 ;; gamma_incomplete(a+n,z) = pochhammer(a,n)*gamma_incomplete(a,z)
876 ;; + z^a*exp(-z)*sum(gamma(a+n)/gamma(a+k+1)*z^k,k,0,n-1)
877 (add
878 (mul
879 (simplify (list '($pochhammer) a n))
880 (simplify (list '(%gamma_incomplete) a z)))
881 (mul
882 (power '$%e (mul -1 z))
883 (power z a)
884 (let ((gamma-a+n (ftake* '%gamma (add a n)))
885 (index (gensumindex)))
886 (simpsum1
887 (mul
888 (div gamma-a+n
889 (ftake* '%gamma (add a index 1)))
890 (power z index))
891 index 0 (add n -1))))))
892 ((< n 0)
893 (setq n (- n))
894 ;; See http://functions.wolfram.com/06.06.17.0004.01
896 ;; gamma_incomplate(a,z) =
897 ;; (-1)^n*pochhammer(1-a,n)
898 ;; *[gamma_incomplete(a-n,z)
899 ;; + z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)]
901 ;; Rerarrange this in terms of gamma_incomplete(a-n,z):
903 ;; gamma_incomplete(a-n,z) =
904 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
905 ;; -z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)
907 ;; Change the summation index to go from k = 0 to n-1:
909 ;; z^(a-n-1)*sum(z^k/pochhammer(a-n,k),k,1,n)
910 ;; = z^(a-n-1)*sum(z^(k+1)/pochhammer(a-n,k+1),k,0,n-1)
911 ;; = z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
913 ;; Thuus:
914 ;; gamma_incomplete(a-n,z) =
915 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
916 ;; -z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
917 (sub
918 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
919 (div
920 (mul
921 (power -1 n)
922 (simplify (list '(%gamma_incomplete) a z)))
923 (simplify (list '($pochhammer) (sub 1 a) n)))
924 (mul
925 (power '$%e (mul -1 z))
926 (power z (sub a n))
927 ;; sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
928 (let ((index (gensumindex)))
929 (simpsum1
930 (div
931 (power z index)
932 (simplify (list '($pochhammer) (sub a n) (add index 1))))
933 index 0 (sub n 1)))))))))
934 ((and $gamma_expand (consp a) (eq 'rat (caar a))
935 (integerp (second a))
936 (integerp (third a)))
937 ;; gamma_incomplete of (numeric) rational order. Expand it out
938 ;; so that the resulting order is between 0 and 1.
939 (multiple-value-bind (n order)
940 (floor (/ (second a) (third a)))
941 ;; a = n + order where 0 <= order < 1.
942 (let ((rat-order (rat (numerator order) (denominator order))))
943 (cond
944 ((zerop n)
945 ;; Nothing to do if the order is already between 0 and 1
946 (give-up))
948 ;; Use gamma_incomplete(a+n,z) above. and then substitute
949 ;; a=order. This works for n positive or negative.
950 (let* ((ord (gensym))
951 (g (simplify (list '(%gamma_incomplete) (add ord n) z))))
952 ($substitute rat-order ord g)))))))
954 ($hypergeometric_representation
955 ;; See http://functions.wolfram.com/06.06.26.0002.01
957 ;; gamma_incomplete(a,z) = gamma(z) - z^a/a*%f[1,1]([a],[a+1},-z)
959 ;; However, hypergeomtric simplifies
960 ;; hypergeometric([a],[a+1],-z) to
961 ;; hypergeometric([1],[a+1],z)*exp(-z).
962 (sub (ftake '%gamma a)
963 (mul (power z a)
964 (div 1 a)
965 (ftake '%hypergeometric
966 (make-mlist a)
967 (make-mlist (add 1 a))
968 (neg z)))))
969 (t (give-up)))))
971 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
972 ;;; Numerical evaluation of the Incomplete Gamma function
974 ;;; gamma-incomplete (a,z) - real and complex double float
975 ;;; bfloat-gamma-incomplete (a z) - bigfloat
976 ;;; complex-bfloat-gamma-incomplete (a z) - complex bigfloat
978 ;;; Expansion in a power series for abs(x) < R, where R is
979 ;;; *gamma-radius* + real(a) if real(a) > 0 or *gamma-radius*
980 ;;; otherwise.
982 ;;; (A&S 6.5.29):
984 ;;; inf
985 ;;; ===
986 ;;; \ gamma(a)
987 ;;; gamma(a,z) = exp(-x)*z^a * > ------------ * z^n
988 ;;; / gamma(a+1+n)
989 ;;; ===
990 ;;; n=0
992 ;;; This expansion does not work for an integer a<=0, because the Gamma function
993 ;;; in the denominator is not defined for a=0 and negative integers. For this
994 ;;; case we use the Exponential Integral E for numerically evaluation. The
995 ;;; Incomplete Gamma function and the Exponential integral are connected by
997 ;;; gamma(a,z) = z^a * expintegral_e(1-a,z)
999 ;;; When the series is not used, two forms of the continued fraction
1000 ;;; are used. When z is not near the negative real axis use the
1001 ;;; continued fractions (A&S 6.5.31):
1003 ;;; 1 1-a 1 2-a 2
1004 ;;; gamma(a,z) = exp(-z) z^a *( -- --- --- --- --- ... )
1005 ;;; z+ 1+ z+ 1+ z+
1007 ;;; The accuracy is controlled by *gamma-incomplete-eps* for double float
1008 ;;; precision. For bigfloat precision epsilon is 10^(-$fpprec). The expansions
1009 ;;; in a power series or continued fractions stops if *gamma-incomplete-maxit*
1010 ;;; is exceeded and an Maxima error is thrown.
1012 ;;; The above fraction does not converge on the negative real axis and
1013 ;;; converges very slowly near the axis. In this case, use the
1014 ;;; relationship
1016 ;;; gamma(a,z) = gamma(a) - gamma_lower(a,z)
1018 ;;; The continued fraction for gamma_incomplete_lower(a,z) is
1019 ;;; (http://functions.wolfram.com/06.06.10.0009.01):
1021 ;;; gamma_lower(a,z) = exp(-z) * z^a / cf(a,z)
1023 ;;; where
1025 ;;; -a*z z (a+1)*z 2*z (a+2)*z
1026 ;;; cf(a,z) = a + ---- ---- ------- ---- -------
1027 ;;; a+1+ a+2- a+3+ a+4- a+5+
1029 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1031 (defvar *gamma-incomplete-maxit* 10000)
1032 (defvar *gamma-incomplete-eps* (* 2 +flonum-epsilon+))
1033 (defvar *gamma-incomplete-min* 1.0e-32)
1035 (defvar *gamma-radius* 1.0
1036 "Controls the radius within a series expansion is done.")
1037 (defvar *gamma-imag* 1.0)
1039 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1041 ;;; The numerical evaluation for CL float or complex values a and x
1042 ;;; When the flag regularized is T, the result is divided by gamma(a) and
1043 ;;; Maxima returns the numercial result for gamma_incomplete_regularized
1045 (defun gamma-incomplete (a x &optional (regularized nil))
1046 (setq x (+ x (cond ((complexp x) #C(0.0 0.0)) ((realp x) 0.0))))
1048 (let ((factor
1049 ;; Compute the factor needed to scale the series or continued
1050 ;; fraction. This is x^a*exp(-x) or x^a*exp(-x)/gamma(a)
1051 ;; depending on whether we want a non-regularized or
1052 ;; regularized form. We want to compute the factor carefully
1053 ;; to avoid unnecessary overflow if possible.
1054 (cond (regularized
1055 (or (try-float-computation
1056 #'(lambda ()
1057 ;; gammafloat is more accurate for real
1058 ;; values of a.
1059 (cond ((complexp a)
1060 (/ (* (expt x a) (exp (- x)))
1061 (gamma-lanczos a)))
1063 (/ (* (expt x a) (exp (- x)))
1064 (gammafloat a))))))
1065 ;; Easy way failed. Use logs to compute the
1066 ;; result. This loses some precision, especially
1067 ;; for large values of a and/or x because we use
1068 ;; many bits to hold the exponent part.
1069 (exp (- (* a (log x))
1071 (log-gamma-lanczos (if (complexp a)
1073 (complex a)))))))
1075 (or (try-float-computation
1076 #'(lambda ()
1077 (* (expt x a) (exp (- x)))))
1078 ;; Easy way failed, so use the log form.
1079 (exp (- (* a (log x))
1080 x)))))))
1081 (multiple-value-bind (result lower-incomplete-tail-p)
1082 (%gamma-incomplete a x)
1083 (cond (lower-incomplete-tail-p
1084 ;; %gamma-incomplete compute the lower incomplete gamma
1085 ;; function, so we need to subtract that from gamma(a),
1086 ;; more or less.
1087 (cond (regularized
1088 (- 1 (* result factor)))
1089 ((complexp a)
1090 (- (gamma-lanczos a) (* result factor)))
1092 (- (gammafloat a) (* result factor)))))
1094 ;; Continued fraction used. Just multiply by the factor
1095 ;; to get the final result.
1096 (* factor result))))))
1098 ;; Compute the key part of the gamma incomplete function using either
1099 ;; a series expression or a continued fraction expression. Two values
1100 ;; are returned: the value itself and a boolean, indicating what the
1101 ;; computed value is. If the boolean non-NIL, then the computed value
1102 ;; is the lower incomplete gamma function.
1103 (defun %gamma-incomplete (a x)
1104 (let ((gm-maxit *gamma-incomplete-maxit*)
1105 (gm-eps *gamma-incomplete-eps*)
1106 (gm-min *gamma-incomplete-min*))
1107 (when *debug-gamma*
1108 (format t "~&GAMMA-INCOMPLETE with ~A and ~A~%" a x))
1109 (cond
1110 ;; The series expansion is done for x within a circle of radius
1111 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1112 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1113 ;; continued fraction is used.
1114 ((and (> (abs x) (+ *gamma-radius*
1115 (if (> (realpart a) 0.0) (realpart a) 0.0))))
1116 (cond ((and (< (realpart x) 0)
1117 (< (abs (imagpart x))
1118 (* *gamma-imag* (abs (realpart x)))))
1119 ;; For x near the negative real axis, use the
1120 ;; relationship gamma_incomplete(a,z) = gamma(a) -
1121 ;; gamma_incomplete_lower(a,z), where
1122 ;; gamma_incomplete_lower(a,z) is the lower poart of the
1123 ;; incomplete gamma function. We can evaluate that
1124 ;; using a continued fraction from
1125 ;; http://functions.wolfram.com/06.06.10.0009.01. (Note
1126 ;; that the alternative fraction,
1127 ;; http://functions.wolfram.com/06.06.10.0007.01,
1128 ;; appears to be less accurate.)
1130 ;; Also note that this appears to be valid for all
1131 ;; values of x (real or complex), but we don't want to
1132 ;; use this everywhere for gamma_incomplete. Consider
1133 ;; what happens for large real x. gamma_incomplete(a,x)
1134 ;; is small, but gamma_incomplete(a,x) = gamma(x) - cf
1135 ;; will have large roundoff errors.
1136 (when *debug-gamma*
1137 (format t "~&GAMMA-INCOMPLETE in continued fractions for lower integral~%"))
1138 (let ((a (bigfloat:to a))
1139 (x (bigfloat:to x))
1140 (bigfloat::*debug-cf-eval* *debug-gamma*)
1141 (bigfloat::*max-cf-iterations* *gamma-incomplete-maxit*))
1142 (values (/ (bigfloat::lentz #'(lambda (n)
1143 (+ n a))
1144 #'(lambda (n)
1145 (if (evenp n)
1146 (* (ash n -1) x)
1147 (- (* (+ a (ash n -1)) x))))))
1148 t)))
1150 ;; Expansion in continued fractions for gamma_incomplete.
1151 (when *debug-gamma*
1152 (format t "~&GAMMA-INCOMPLETE in continued fractions~%"))
1153 (do* ((i 1 (+ i 1))
1154 (an (- a 1.0) (* i (- a i)))
1155 (b (+ 3.0 x (- a)) (+ b 2.0))
1156 (c (/ 1.0 gm-min))
1157 (d (/ 1.0 (- b 2.0)))
1158 (h d)
1159 (del 0.0))
1160 ((> i gm-maxit)
1161 (merror (intl:gettext "gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x))
1162 (setq d (+ (* an d) b))
1163 (when (< (abs d) gm-min) (setq d gm-min))
1164 (setq c (+ b (/ an c)))
1165 (when (< (abs c) gm-min) (setq c gm-min))
1166 (setq d (/ 1.0 d))
1167 (setq del (* d c))
1168 (setq h (* h del))
1169 (when (< (abs (- del 1.0)) gm-eps)
1170 ;; Return nil to indicate we used the continued fraction.
1171 (return (values h nil)))))))
1173 ;; Expansion in a series
1174 (when *debug-gamma*
1175 (format t "~&GAMMA-INCOMPLETE in series~%"))
1176 (do* ((i 1 (+ i 1))
1177 (ap a (+ ap 1.0))
1178 (del (/ 1.0 a) (* del (/ x ap)))
1179 (sum del (+ sum del)))
1180 ((> i gm-maxit)
1181 (merror (intl:gettext "gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x))
1182 (when (< (abs del) (* (abs sum) gm-eps))
1183 (when *debug-gamma* (format t "~&Series converged.~%"))
1184 ;; Return T to indicate we used the series and the series
1185 ;; is for the integral from 0 to x, not x to inf.
1186 (return (values sum t))))))))
1188 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1190 ;;; This function is called for a and x real
1192 (defun bfloat-gamma-incomplete (a x)
1193 (let* ((gm-maxit *gamma-incomplete-maxit*)
1194 (gm-eps (power ($bfloat 10.0) (- $fpprec)))
1195 (gm-min (mul gm-eps gm-eps))
1196 ($ratprint nil))
1197 (cond
1198 ;; The series expansion is done for x within a circle of radius
1199 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1200 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1201 ;; continued fraction is used.
1202 ((eq ($sign (sub (simplify (list '(mabs) x))
1203 (add *gamma-radius*
1204 (if (eq ($sign a) '$pos) a 0.0))))
1205 '$pos)
1206 (cond
1207 ((and (eq ($sign x) '$pos))
1208 ;; Expansion in continued fractions of the Incomplete Gamma function
1209 (do* ((i 1 (+ i 1))
1210 (an (sub a 1.0) (mul i (sub a i)))
1211 (b (add 3.0 x (mul -1 a)) (add b 2.0))
1212 (c (div 1.0 gm-min))
1213 (d (div 1.0 (sub b 2.0)))
1214 (h d)
1215 (del 0.0))
1216 ((> i gm-maxit)
1217 (merror (intl:gettext "gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x))
1218 (when *debug-gamma*
1219 (format t "~&in continued fractions:~%")
1220 (mformat t "~& : i = ~M~%" i)
1221 (mformat t "~& : h = ~M~%" h))
1222 (setq d (add (mul an d) b))
1223 (when (eq ($sign (sub (simplify (list '(mabs) d)) gm-min)) '$neg)
1224 (setq d gm-min))
1225 (setq c (add b (div an c)))
1226 (when (eq ($sign (sub (simplify (list '(mabs) c)) gm-min)) '$neg)
1227 (setq c gm-min))
1228 (setq d (div 1.0 d))
1229 (setq del (mul d c))
1230 (setq h (mul h del))
1231 (when (eq ($sign (sub (simplify (list '(mabs) (sub del 1.0))) gm-eps))
1232 '$neg)
1233 (return
1234 (mul h
1235 (power x a)
1236 (power ($bfloat '$%e) (mul -1 x)))))))
1238 ;; Expand to multiply everything out.
1239 ($expand
1240 ;; Expansion in continued fraction for the lower incomplete gamma.
1241 (sub (simplify (list '(%gamma) a))
1242 ;; NOTE: We want (power x a) instead of bigfloat:expt
1243 ;; because this preserves how maxima computes x^a when
1244 ;; x is negative and a is rational. For, example
1245 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1246 ;; principal value.
1247 (mul (power x a)
1248 (power ($bfloat '$%e) (mul -1 x))
1249 (let ((a (bigfloat:to a))
1250 (x (bigfloat:to x)))
1251 (to (bigfloat:/
1252 (bigfloat:lentz
1253 #'(lambda (n)
1254 (bigfloat:+ n a))
1255 #'(lambda (n)
1256 (if (evenp n)
1257 (bigfloat:* (ash n -1) x)
1258 (bigfloat:- (bigfloat:* (bigfloat:+ a (ash n -1))
1259 x))))))))))))))
1262 ;; Series expansion of the Incomplete Gamma function
1263 (do* ((i 1 (+ i 1))
1264 (ap a (add ap 1.0))
1265 (del (div 1.0 a) (mul del (div x ap)))
1266 (sum del (add sum del)))
1267 ((> i gm-maxit)
1268 (merror (intl:gettext "gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x))
1269 (when *debug-gamma*
1270 (format t "~&GAMMA-INCOMPLETE in series:~%")
1271 (mformat t "~& : i = ~M~%" i)
1272 (mformat t "~& : ap = ~M~%" ap)
1273 (mformat t "~& : x/ap = ~M~%" (div x ap))
1274 (mformat t "~& : del = ~M~%" del)
1275 (mformat t "~& : sum = ~M~%" sum))
1276 (when (eq ($sign (sub (simplify (list '(mabs) del))
1277 (mul (simplify (list '(mabs) sum)) gm-eps)))
1278 '$neg)
1279 (when *debug-gamma* (mformat t "~&Series converged to ~M.~%" sum))
1280 (return
1281 (sub (simplify (list '(%gamma) a))
1282 ($rectform
1283 (mul sum
1284 (power x a)
1285 (power ($bfloat '$%e) (mul -1 x))))))))))))
1287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1289 (defun complex-bfloat-gamma-incomplete (a x)
1290 (let* ((gm-maxit *gamma-incomplete-maxit*)
1291 (gm-eps (power ($bfloat 10.0) (- $fpprec)))
1292 (gm-min (mul gm-eps gm-eps))
1293 ($ratprint nil))
1294 (when *debug-gamma*
1295 (format t "~&COMPLEX-BFLOAT-GAMMA-INCOMPLETE~%")
1296 (format t " : a = ~A~%" a)
1297 (format t " : x = ~A~%" x))
1298 (cond
1299 ;; The series expansion is done for x within a circle of radius
1300 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1301 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1302 ;; continued fraction is used.
1303 ((and (eq ($sign (sub (simplify (list '(mabs) x))
1304 (add *gamma-radius*
1305 (if (eq ($sign ($realpart a)) '$pos)
1306 ($realpart a)
1307 0.0))))
1308 '$pos))
1309 (cond
1310 ((not (and (eq ($sign ($realpart x)) '$neg)
1311 (eq ($sign (sub (simplify (list '(mabs) ($imagpart x)))
1312 (simplify (list '(mabs) ($realpart x)))))
1313 '$neg)))
1314 ;; Expansion in continued fractions of the Incomplete Gamma function
1315 (when *debug-gamma*
1316 (format t "~&in continued fractions:~%"))
1317 (do* ((i 1 (+ i 1))
1318 (an (sub a 1.0) (mul i (sub a i)))
1319 (b (add 3.0 x (mul -1 a)) (add b 2.0))
1320 (c (cdiv 1.0 gm-min))
1321 (d (cdiv 1.0 (sub b 2.0)))
1322 (h d)
1323 (del 0.0))
1324 ((> i gm-maxit)
1325 (merror (intl:gettext "gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x))
1326 (setq d (add (cmul an d) b))
1327 (when (eq ($sign (sub (simplify (list '(mabs) d)) gm-min)) '$neg)
1328 (setq d gm-min))
1329 (setq c (add b (cdiv an c)))
1330 (when (eq ($sign (sub (simplify (list '(mabs) c)) gm-min)) '$neg)
1331 (setq c gm-min))
1332 (setq d (cdiv 1.0 d))
1333 (setq del (cmul d c))
1334 (setq h (cmul h del))
1335 (when (eq ($sign (sub (simplify (list '(mabs) (sub del 1.0)))
1336 gm-eps))
1337 '$neg)
1338 (return
1339 ($bfloat ; force evaluation of expressions with sin or cos
1340 (cmul h
1341 (cmul
1342 (cpower x a)
1343 (cpower ($bfloat '$%e) ($bfloat (mul -1 x))))))))))
1345 ;; Expand to multiply everything out.
1346 ($expand
1347 ;; Expansion in continued fraction for the lower incomplete gamma.
1348 (sub ($rectform (simplify (list '(%gamma) a)))
1349 ;; NOTE: We want (power x a) instead of bigfloat:expt
1350 ;; because this preserves how maxima computes x^a when
1351 ;; x is negative and a is rational. For, example
1352 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1353 ;; principal value.
1354 (mul ($rectform (power x a))
1355 ($rectform (power ($bfloat '$%e) (mul -1 x)))
1356 (let ((a (bigfloat:to a))
1357 (x (bigfloat:to x)))
1358 (to (bigfloat:/
1359 (bigfloat:lentz
1360 #'(lambda (n)
1361 (bigfloat:+ n a))
1362 #'(lambda (n)
1363 (if (evenp n)
1364 (bigfloat:* (ash n -1) x)
1365 (bigfloat:- (bigfloat:* (bigfloat:+ a (ash n -1))
1366 x))))))))))))))
1368 ;; Series expansion of the Incomplete Gamma function
1369 (when *debug-gamma*
1370 (format t "~&GAMMA-INCOMPLETE in series:~%"))
1371 (do* ((i 1 (+ i 1))
1372 (ap a (add ap 1.0))
1373 (del (cdiv 1.0 a) (cmul del (cdiv x ap)))
1374 (sum del (add sum del)))
1375 ((> i gm-maxit)
1376 (merror (intl:gettext "gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x))
1377 (when (eq ($sign (sub (simplify (list '(mabs) del))
1378 (mul (simplify (list '(mabs) sum)) gm-eps)))
1379 '$neg)
1380 (when *debug-gamma* (format t "~&Series converged.~%"))
1381 (return
1382 ($bfloat ; force evaluation of expressions with sin or cos
1383 (sub (simplify (list '(%gamma) a))
1384 (cmul sum
1385 (cmul
1386 (cpower x a)
1387 (cpower ($bfloat '$%e) (mul -1 x)))))))))))))
1389 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1391 ;;; Implementation of the Generalized Incomplete Gamma function
1393 ;;; z2
1394 ;;; /
1395 ;;; [ a - 1 - t
1396 ;;; gamma_incomplete_generalized(a, z1, z2) = I t %e dt
1397 ;;; ]
1398 ;;; /
1399 ;;; z1
1401 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1403 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1404 ;;; on the negative real axis.
1405 ;;; We support a conjugate-function which test this case.
1407 (defprop %gamma_incomplete_generalized
1408 conjugate-gamma-incomplete-generalized conjugate-function)
1410 (defun conjugate-gamma-incomplete-generalized (args)
1411 (let ((a (first args)) (z1 (second args)) (z2 (third args)))
1412 (cond ((and (off-negative-real-axisp z1) (off-negative-real-axisp z2))
1413 ;; z1 and z2 definitely not on the negative real axis.
1414 ;; Mirror symmetry.
1415 (simplify
1416 (list
1417 '(%gamma_incomplete_generalized)
1418 (simplify (list '($conjugate) a))
1419 (simplify (list '($conjugate) z1))
1420 (simplify (list '($conjugate) z2)))))
1422 ;; On the negative real axis or no information. Unsimplified.
1423 (list
1424 '($conjugate simp)
1425 (simplify (list '(%gamma_incomplete_generalized) a z1 z2)))))))
1427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1429 ;;; Generalized Incomplete Gamma distributes over bags
1431 (defprop %gamma_incomplete_generalized (mlist $matrix mequal) distribute_over)
1433 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1435 ;;; Differentiation of Generalized Incomplete Gamma function
1437 (defprop %gamma_incomplete_generalized
1438 ((a z1 z2)
1439 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1440 ;; and the Generalized Incomplete Gamma function (functions.wolfram.com)
1441 ((mplus)
1442 ((mtimes)
1443 ((mexpt) ((%gamma) a) 2)
1444 ((mexpt) z1 a)
1445 (($hypergeometric_regularized)
1446 ((mlist) a a)
1447 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
1448 ((mtimes) -1 z1)))
1449 ((mtimes) -1
1450 ((mexpt) ((%gamma) a) 2)
1451 ((mexpt) z2 a)
1452 (($hypergeometric_regularized)
1453 ((mlist) a a)
1454 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
1455 ((mtimes) -1 z2)))
1456 ((mtimes) -1
1457 ((%gamma_incomplete_generalized) a 0 z1)
1458 ((%log) z1))
1459 ((mtimes)
1460 ((%gamma_incomplete_generalized) a 0 z2)
1461 ((%log) z2)))
1462 ;; The derivative wrt z1
1463 ((mtimes) -1
1464 ((mexpt) $%e ((mtimes) -1 z1))
1465 ((mexpt) z1 ((mplus) -1 a)))
1466 ;; The derivative wrt z2
1467 ((mtimes)
1468 ((mexpt) $%e ((mtimes) -1 z2))
1469 ((mexpt) z2 ((mplus) -1 a))))
1470 grad)
1472 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1474 ;;; Generalized Incomplete Gamma function is a simplifying function
1476 (def-simplifier gamma_incomplete_generalized (a z1 z2)
1477 (let (($simpsum t))
1478 (cond
1480 ;; Check for specific values
1482 ((zerop1 z2)
1483 (let ((sgn ($sign ($realpart a))))
1484 (cond
1485 ((member sgn '($pos $pz))
1486 (sub
1487 (simplify (list '(%gamma_incomplete) a z1))
1488 (simplify (list '(%gamma) a))))
1490 (give-up)))))
1492 ((zerop1 z1)
1493 (let ((sgn ($sign ($realpart a))))
1494 (cond
1495 ((member sgn '($pos $pz))
1496 (sub
1497 (simplify (list '(%gamma) a))
1498 (simplify (list '(%gamma_incomplete) a z2))))
1500 (give-up)))))
1502 ((zerop1 (sub z1 z2)) 0)
1504 ((eq z2 '$inf) (simplify (list '(%gamma_incomplete) a z1)))
1505 ((eq z1 '$inf) (mul -1 (simplify (list '(%gamma_incomplete) a z2))))
1507 ;; Check for numerical evaluation in Float or Bigfloat precision
1508 ;; Use the numerical routines of the Incomplete Gamma function
1510 ((float-numerical-eval-p a z1 z2)
1511 (complexify
1512 (- (gamma-incomplete ($float a) ($float z1))
1513 (gamma-incomplete ($float a) ($float z2)))))
1515 ((complex-float-numerical-eval-p a z1 z2)
1516 (let ((ca (complex ($float ($realpart a)) ($float ($imagpart a))))
1517 (cz1 (complex ($float ($realpart z1)) ($float ($imagpart z1))))
1518 (cz2 (complex ($float ($realpart z2)) ($float ($imagpart z2)))))
1519 (complexify (- (gamma-incomplete ca cz1) (gamma-incomplete ca cz2)))))
1521 ((bigfloat-numerical-eval-p a z1 z2)
1522 (sub (bfloat-gamma-incomplete ($bfloat a) ($bfloat z1))
1523 (bfloat-gamma-incomplete ($bfloat a) ($bfloat z2))))
1525 ((complex-bigfloat-numerical-eval-p a z1 z2)
1526 (let ((ca (add ($bfloat ($realpart a))
1527 (mul '$%i ($bfloat ($imagpart a)))))
1528 (cz1 (add ($bfloat ($realpart z1))
1529 (mul '$%i ($bfloat ($imagpart z1)))))
1530 (cz2 (add ($bfloat ($realpart z2))
1531 (mul '$%i ($bfloat ($imagpart z2))))))
1532 (sub (complex-bfloat-gamma-incomplete ca cz1)
1533 (complex-bfloat-gamma-incomplete ca cz2))))
1535 ;; Check for transformations and argument simplification
1537 ((and $gamma_expand (mplusp a) (integerp (cadr a)))
1538 ;; Expand gamma_incomplete_generalized(a+n,z1,z2) with n an integer
1539 (let ((n (cadr a))
1540 (a (simplify (cons '(mplus) (cddr a)))))
1541 (cond
1542 ((> n 0)
1543 (mul
1544 (simplify (list '($pochhammer) a n))
1545 (add
1546 (simplify (list '(%gamma_incomplete_generalized) a z1 z2))
1547 (mul
1548 (power '$%e (mul -1 z1))
1549 (let ((index (gensumindex)))
1550 (simpsum1
1551 (div
1552 (power z1 (add a index -1))
1553 (simplify (list '($pochhammer) a index)))
1554 index 1 n)))
1555 (mul -1
1556 (power '$%e (mul -1 z2))
1557 (let ((index (gensumindex)))
1558 (simpsum1
1559 (div
1560 (power z2 (add a index -1))
1561 (simplify (list '($pochhammer) a index)))
1562 index 1 n))))))
1564 ((< n 0)
1565 (setq n (- n))
1566 (add
1567 (mul
1568 (div
1569 (power -1 n)
1570 ($factor (simplify (list '($pochhammer) (sub 1 a) n))))
1571 (simplify (list '(%gamma_incomplete_generalized) a z1 z2)))
1572 (mul -1
1573 (power '$%e (mul -1 z2))
1574 (let ((index (gensumindex)))
1575 (simpsum1
1576 (div
1577 (power z1 (add a index (- n) -1))
1578 (simplify (list '($pochhammer) (sub a n) index)))
1579 index 1 n)))
1580 (mul
1581 (power '$%e (mul -1 z2))
1582 (let ((index (gensumindex)))
1583 (simpsum1
1584 (div
1585 (power z2 (add a index (- n) -1))
1586 (simplify (list '($pochhammer) (sub a n) index)))
1587 index 1 n))))))))
1588 ($hypergeometric_representation
1589 ;; Use the fact that gamma_incomplete_generalized(a,z1,z2) =
1590 ;; gamma_incomplete(a,z1) - gamma_incomplete(a,z2).
1591 (sub (ftake '%gamma_incomplete a z1)
1592 (ftake '%gamma_incomplete a z2)))
1593 (t (give-up)))))
1595 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1597 ;;; Implementation of the Regularized Incomplete Gamma function
1599 ;;; A&S 6.5.1
1601 ;;; gamma_incomplete(a, z)
1602 ;;; gamma_incomplete_regularized(a, z) = ----------------------
1603 ;;; gamma(a)
1604 ;;;
1605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1607 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1609 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1610 ;;; on the negative real axis.
1611 ;;; We support a conjugate-function which test this case.
1613 (defprop %gamma_incomplete_regularized
1614 conjugate-gamma-incomplete-regularized conjugate-function)
1616 (defun conjugate-gamma-incomplete-regularized (args)
1617 (let ((a (first args)) (z (second args)))
1618 (cond ((off-negative-real-axisp z)
1619 ;; z definitely not on the negative real axis. Mirror symmetry.
1620 (simplify
1621 (list
1622 '(%gamma_incomplete_regularized)
1623 (simplify (list '($conjugate) a))
1624 (simplify (list '($conjugate) z)))))
1626 ;; On the negative real axis or no information. Unsimplified.
1627 (list
1628 '($conjugate simp)
1629 (simplify (list '(%gamma_incomplete_regularized) a z)))))))
1631 ;;; Regularized Incomplete Gamma distributes over bags
1633 (defprop %gamma_incomplete_regularized (mlist $matrix mequal) distribute_over)
1635 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1637 ;;; Differentiation of Regularized Incomplete Gamma function
1639 (defprop %gamma_incomplete_regularized
1640 ((a z)
1641 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1642 ;; and the Regularized Generalized Incomplete Gamma function
1643 ;; (functions.wolfram.com)
1644 ((mplus)
1645 ((mtimes)
1646 ((%gamma) a)
1647 ((mexpt) z a)
1648 (($hypergeometric_regularized)
1649 ((mlist) a a)
1650 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
1651 ((mtimes) -1 z)))
1652 ((mtimes)
1653 ((%gamma_incomplete_generalized_regularized) a z 0)
1654 ((mplus)
1655 ((%log) z)
1656 ((mtimes) -1 ((mqapply) (($psi array) 0) a)))))
1657 ;; The derivative wrt z
1658 ((mtimes)
1660 ((mexpt) $%e ((mtimes) -1 z))
1661 ((mexpt) z ((mplus) -1 a))
1662 ((mexpt) ((%gamma) a) -1)))
1663 grad)
1665 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1667 ;;; Regularized Incomplete Gamma function is a simplifying function
1669 (def-simplifier gamma_incomplete_regularized (a z)
1670 (let (($simpsum t)
1671 (ratorder 0))
1673 (cond
1675 ;; Check for specific values
1677 ((zerop1 z)
1678 (let ((sgn ($sign ($realpart a))))
1679 (cond ((member sgn '($neg $zero))
1680 (simp-domain-error
1681 (intl:gettext
1682 "gamma_incomplete_regularized: gamma_incomplete_regularized(~:M,~:M) is undefined.")
1683 a z))
1684 ((member sgn '($pos $pz)) 1)
1685 (t (give-up)))))
1687 ((zerop1 a) 0)
1688 ((eq z '$inf) 0)
1690 ;; Check for numerical evaluation in Float or Bigfloat precision
1692 ((float-numerical-eval-p a z)
1693 (complexify
1694 ;; gamma_incomplete returns a regularized result
1695 (gamma-incomplete ($float a) ($float z) t)))
1697 ((complex-float-numerical-eval-p a z)
1698 (let ((ca (complex ($float ($realpart a)) ($float ($imagpart a))))
1699 (cz (complex ($float ($realpart z)) ($float ($imagpart z)))))
1700 ;; gamma_incomplete returns a regularized result
1701 (complexify (gamma-incomplete ca cz t))))
1703 ((bigfloat-numerical-eval-p a z)
1704 (div (bfloat-gamma-incomplete ($bfloat a) ($bfloat z))
1705 (simplify (list '(%gamma) ($bfloat a)))))
1707 ((complex-bigfloat-numerical-eval-p a z)
1708 (let ((ca (add ($bfloat ($realpart a))
1709 (mul '$%i ($bfloat ($imagpart a)))))
1710 (cz (add ($bfloat ($realpart z))
1711 (mul '$%i ($bfloat ($imagpart z))))))
1712 ($rectform
1713 (div
1714 (complex-bfloat-gamma-incomplete ca cz)
1715 (simplify (list '(%gamma) ca))))))
1717 ;; Check for transformations and argument simplification
1719 ((and $gamma_expand (integerp a))
1720 ;; An integer. Expand the expression.
1721 (let ((sgn ($sign a)))
1722 (cond
1723 ((member sgn '($pos $pz))
1724 (mul
1725 (power '$%e (mul -1 z))
1726 (let ((index (gensumindex)))
1727 (simpsum1
1728 (div
1729 (power z index)
1730 (let (($gamma_expand nil))
1731 (simplify (list '(%gamma) (add index 1)))))
1732 index 0 (sub a 1)))))
1733 ((member sgn '($neg $nz)) 0)
1734 (t (give-up)))))
1736 ((and $gamma_expand (setq ratorder (max-numeric-ratio-p a 2)))
1737 ;; We have a half integral order and $gamma_expand is not NIL.
1738 ;; We expand in a series with the Erfc function
1739 (setq ratorder (- ratorder (/ 1 2)))
1740 (when *debug-gamma*
1741 (format t "~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in RATORDER~%")
1742 (format t "~& : a = ~A~%" a)
1743 (format t "~& : ratorder = ~A~%" ratorder))
1744 (cond
1745 ((equal ratorder 0)
1746 (simplify (list '(%erfc) (power z '((rat simp) 1 2)))))
1748 ((> ratorder 0)
1749 (add
1750 (simplify (list '(%erfc) (power z '((rat simp) 1 2))))
1751 (mul
1752 (power -1 (sub ratorder 1))
1753 (power '$%e (mul -1 z))
1754 (power z '((rat simp) 1 2))
1755 (div 1 (simplify (list '(%gamma) a)))
1756 (let ((index (gensumindex)))
1757 (simpsum1
1758 (mul
1759 (power (mul -1 z) index)
1760 (simplify (list '($pochhammer)
1761 (sub '((rat simp) 1 2) ratorder)
1762 (sub ratorder (add index 1)))))
1763 index 0 (sub ratorder 1))))))
1765 ((< ratorder 0)
1766 (setq ratorder (- ratorder))
1767 (add
1768 (simplify (list '(%erfc) (power z '((rat simp) 1 2))))
1769 (mul -1
1770 (power '$%e (mul -1 z))
1771 (power z (sub '((rat simp) 1 2) ratorder))
1772 (inv (simplify (list '(%gamma) (sub '((rat simp) 1 2) ratorder))))
1773 (let ((index (gensumindex)))
1774 (simpsum1
1775 (div
1776 (power z index)
1777 (simplify (list '($pochhammer)
1778 (sub '((rat simp) 1 2) ratorder)
1779 (add index 1))))
1780 index 0 (sub ratorder 1))))))))
1782 ((and $gamma_expand (mplusp a) (integerp (cadr a)))
1783 (when *debug-gamma*
1784 (format t "~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in COND (mplusp)~%"))
1785 (let ((n (cadr a))
1786 (a (simplify (cons '(mplus) (cddr a)))))
1787 (cond
1788 ((> n 0)
1789 (add
1790 (simplify (list '(%gamma_incomplete_regularized) a z))
1791 ;; We factor the second summand.
1792 ;; Some factors vanish and the result is more readable.
1793 ($factor
1794 (mul
1795 (power '$%e (mul -1 z))
1796 (power z (add a -1))
1797 (div 1 (simplify (list '(%gamma) a)))
1798 (let ((index (gensumindex)))
1799 (simpsum1
1800 (div
1801 (power z index)
1802 (simplify (list '($pochhammer) a index)))
1803 index 1 n))))))
1804 ((< n 0)
1805 (setq n (- n))
1806 (add
1807 (simplify (list '(%gamma_incomplete_regularized) a z))
1808 ;; We factor the second summand.
1809 ($factor
1810 (mul -1
1811 (power '$%e (mul -1 z))
1812 (power z (sub a (add n 1)))
1813 (div 1 (simplify (list '(%gamma) (add a (- n)))))
1814 (let ((index (gensumindex)))
1815 (simpsum1
1816 (div
1817 (power z index)
1818 (simplify (list '($pochhammer) (add a (- n)) index)))
1819 index 1 n)))))))))
1820 ((and $gamma_expand (consp a) (eq 'rat (caar a))
1821 (integerp (second a))
1822 (integerp (third a)))
1823 ;; gamma_incomplete_regularized of numeric rational order.
1824 ;; Expand it out so that the resulting order is between 0 and
1825 ;; 1. Use gamma_incomplete_regularized(a+n,z) to do the dirty
1826 ;; work.
1827 (multiple-value-bind (n order)
1828 (floor (/ (second a) (third a)))
1829 ;; a = n + order where 0 <= order < 1.
1830 (let ((rat-order (rat (numerator order) (denominator order))))
1831 (cond
1832 ((zerop n)
1833 ;; Nothing to do if the order is already between 0 and 1
1834 (give-up))
1836 ;; Use gamma_incomplete_regularized(a+n,z) above. and
1837 ;; then substitute a=order. This works for n positive or
1838 ;; negative.
1839 (let* ((ord (gensym))
1840 (g (simplify (list '(%gamma_incomplete_regularized) (add ord n) z))))
1841 ($substitute rat-order ord g)))))))
1843 ($hypergeometric_representation
1844 ;; gamma_incomplete_regularized(a,z)
1845 ;; = gamma_incomplete(a,z)/gamma(a)
1846 ;; = (gamma(a) - gamma_incomplete_lower(a,z))/gamma(a)
1847 ;; = 1 - gamma_incomplete_lower(a,z)/gamma(a)
1848 (sub 1
1849 (div (ftake '%gamma_incomplete_lower a z)
1850 (ftake '%gamma a))))
1851 (t (give-up)))))
1853 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1855 ;;; Implementation of the Logarithm of the Gamma function
1857 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1859 (defmfun $log_gamma (z)
1860 (simplify (list '(%log_gamma) z)))
1862 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1864 (defprop $log_gamma %log_gamma alias)
1865 (defprop $log_gamma %log_gamma verb)
1867 (defprop %log_gamma $log_gamma reversealias)
1868 (defprop %log_gamma $log_gamma noun)
1870 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1872 (defprop %log_gamma simp-log-gamma operators)
1874 ;;; Logarithm of the Gamma function distributes over bags
1876 (defprop %log_gamma (mlist $matrix mequal) distribute_over)
1878 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1880 (defprop %log_gamma
1881 ((z)
1882 ((mqapply) (($psi array) 0) z))
1883 grad)
1885 ;; integrate(log_gamma(x),x) = psi[-2](x)
1886 (defun log-gamma-integral (x)
1887 (take '(mqapply) (take '($psi) -2) x))
1889 (putprop '%log_gamma (list (list 'x) 'log-gamma-integral) 'integral)
1891 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1893 (defun simp-log-gamma (expr z simpflag)
1894 (oneargcheck expr)
1895 (setq z (simpcheck (cadr expr) simpflag))
1896 (cond
1898 ;; Check for specific values
1900 ((and (mnump z)
1901 (or (zerop1 z)
1902 (and (eq ($sign z) '$neg)
1903 (zerop1 (sub z ($truncate z))))))
1904 ;; We have zero, a negative integer or a float or bigfloat representation.
1905 (simp-domain-error
1906 (intl:gettext "log_gamma: log_gamma(~:M) is undefined.") z))
1908 ((eq z '$inf) '$inf)
1910 ;; Check for numerical evaluation
1912 ((float-numerical-eval-p z)
1913 (complexify (log-gamma-lanczos (complex ($float z) 0))))
1915 ((complex-float-numerical-eval-p z)
1916 (complexify
1917 (log-gamma-lanczos
1918 (complex ($float ($realpart z)) ($float ($imagpart z))))))
1920 ((bigfloat-numerical-eval-p z)
1921 (bfloat-log-gamma ($bfloat z)))
1923 ((complex-bigfloat-numerical-eval-p z)
1924 (complex-bfloat-log-gamma
1925 (add ($bfloat ($realpart z)) (mul '$%i ($bfloat ($imagpart z))))))
1927 ;; Transform to Logarithm of Factorial for integer values
1928 ;; At this point the integer value is positive and not zero.
1930 ((integerp z)
1931 (simplify (list '(%log) (simplify (list '(mfactorial) (- z 1))))))
1933 (t (eqtest (list '(%log_gamma) z) expr))))
1935 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1936 ;;; The functions log-gamma-lanczos, bfloat-log-gamma and
1937 ;;; complex-bfloat-log-gamma are modified versions of the related functions
1938 ;;; gamma-lanczos, bffac and cbffac. The functions return the Logarithm of
1939 ;;; the Gamma function. If we have to calculate the quotient of Gamma functions,
1940 ;;; e. g. for the Beta function, it is much more appropriate to use the
1941 ;;; logarithmic versions to avoid overflow.
1943 ;;; Be careful log(gamma(z)) is only for realpart(z) positive equal to
1944 ;;; log_gamma(z). For a negative realpart(z) log_gamma differ by multiple of
1945 ;;; %pi from log(gamma(z)). But we always have exp(log_gamma(z))= gamma(z).
1946 ;;; The terms to get the transformation for log_gamma(-z) are taken from
1947 ;;; functions.wolfram.com.
1948 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1950 (defun log-gamma-lanczos (z)
1951 (declare (type (complex flonum) z)
1952 (optimize (safety 3)))
1953 (let ((c (make-array 15 :element-type 'flonum
1954 :initial-contents
1955 '(0.99999999999999709182
1956 57.156235665862923517
1957 -59.597960355475491248
1958 14.136097974741747174
1959 -0.49191381609762019978
1960 .33994649984811888699e-4
1961 .46523628927048575665e-4
1962 -.98374475304879564677e-4
1963 .15808870322491248884e-3
1964 -.21026444172410488319e-3
1965 .21743961811521264320e-3
1966 -.16431810653676389022e-3
1967 .84418223983852743293e-4
1968 -.26190838401581408670e-4
1969 .36899182659531622704e-5))))
1970 (declare (type (simple-array flonum (15)) c))
1971 (if (minusp (realpart z))
1972 (let ((z (- z)))
1976 (- (float pi))
1977 (complex 0 1)
1978 (abs (floor (realpart z)))
1979 (- 1 (abs (signum (imagpart z)))))
1980 (log (float pi))
1981 (- (log (- z)))
1982 (- (log (sin (* (float pi) (- z (floor (realpart z)))))))
1984 (float pi)
1985 (complex 0 1)
1986 (floor (realpart z))
1987 (signum (imagpart z))))
1988 (log-gamma-lanczos z)))
1989 (let* ((z (- z 1))
1990 (zh (+ z 1/2))
1991 (zgh (+ zh 607/128))
1992 (lnzp (* (/ zh 2) (log zgh)))
1993 (ss
1994 (do ((sum 0.0)
1995 (pp (1- (length c)) (1- pp)))
1996 ((< pp 1)
1997 sum)
1998 (incf sum (/ (aref c pp) (+ z pp))))))
1999 (+ (log (sqrt (float (* 2 pi))))
2000 (log (+ ss (aref c 0)))
2001 (+ (- zgh) (* 2 lnzp)))))))
2003 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2005 (defun bfloat-log-gamma (z)
2006 (let (($ratprint nil)
2007 (bigfloat%pi ($bfloat '$%pi)))
2008 (cond
2009 ((eq ($sign z) '$neg)
2010 (let ((z (mul -1 z)))
2011 (sub
2012 (add
2013 (mul -1 bigfloat%pi '$%i
2014 (simplify (list '(mabs) (simplify (list '($floor) ($realpart z)))))
2015 (sub 1
2016 (simplify
2017 (list '(mabs) (simplify (list '(%signum) ($imagpart z)))))))
2018 (simplify (list '(%log) bigfloat%pi))
2019 (mul -1 (simplify (list '(%log) (mul -1 z))))
2020 (mul -1
2021 (simplify (list '(%log)
2022 (simplify (list '(%sin)
2023 (mul
2024 bigfloat%pi
2025 (sub z (simplify (list '($floor) ($realpart z))))))))))
2026 (mul
2027 bigfloat%pi '$%i
2028 (simplify (list '($floor) ($realpart z)))
2029 (simplify (list '(%signum) ($imagpart z)))))
2030 (bfloat-log-gamma z))))
2032 (let* ((k (* 2 (+ 1 ($entier (* 0.41 $fpprec)))))
2033 (m ($bfloat bigfloatone))
2034 (z+k (add z k -1))
2035 (y (power z+k 2))
2036 (x ($bfloat bigfloatzero))
2037 (ii))
2038 (dotimes (i (/ k 2))
2039 (setq ii (* 2 (+ i 1)))
2040 (setq m (mul m (add z ii -2) (add z ii -1)))
2041 (setq x (div
2042 (add x
2043 (div (ftake '%bern (+ k (- ii) 2))
2044 (* (+ k (- ii) 1) (+ k (- ii) 2))))
2045 y)))
2046 (add
2047 (div (simplify (list '(%log) (mul 2 bigfloat%pi z+k))) 2)
2048 (mul z+k (add (simplify (list '(%log) z+k)) x -1))
2049 (mul -1 (simplify (list '(%log) m)))))))))
2051 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2053 (defun complex-bfloat-log-gamma (z)
2054 (let (($ratprint nil)
2055 (bigfloat%pi ($bfloat '$%pi)))
2056 (cond
2057 ((eq ($sign ($realpart z)) '$neg)
2058 (let ((z (mul -1 z)))
2059 (sub
2060 (add
2061 (mul -1 bigfloat%pi '$%i
2062 (simplify (list '(mabs) (simplify (list '($floor) ($realpart z)))))
2063 (sub 1
2064 (simplify
2065 (list '(mabs) (simplify (list '(%signum) ($imagpart z)))))))
2066 (simplify (list '(%log) bigfloat%pi))
2067 (mul -1 (simplify (list '(%log) (mul -1 z))))
2068 (mul -1
2069 (simplify (list '(%log)
2070 (simplify (list '(%sin)
2071 (mul
2072 bigfloat%pi
2073 (sub z (simplify (list '($floor) ($realpart z))))))))))
2074 (mul
2075 bigfloat%pi '$%i
2076 (simplify (list '($floor) ($realpart z)))
2077 (simplify (list '(%signum) ($imagpart z)))))
2078 (complex-bfloat-log-gamma z))))
2080 (let* ((k (* 2 (+ 1 ($entier (* 0.41 $fpprec)))))
2081 (m ($bfloat bigfloatone))
2082 (z+k (add z k -1))
2083 (y ($rectform (power z+k 2)))
2084 (x ($bfloat bigfloatzero))
2085 (ii))
2086 (dotimes (i (/ k 2))
2087 (setq ii (* 2 (+ i 1)))
2088 (setq m ($rectform (mul m (add z ii -2) (add z ii -1))))
2089 (setq x ($rectform
2090 (div
2091 (add x
2092 (div (ftake '%bern (+ k (- ii) 2))
2093 (* (+ k (- ii) 1) (+ k (- ii) 2))))
2094 y))))
2095 ($rectform
2096 (add
2097 (div (simplify (list '(%log) (mul 2 bigfloat%pi z+k))) 2)
2098 (mul z+k (add (simplify (list '(%log) z+k)) x -1))
2099 (mul -1 (simplify (list '(%log) m))))))))))
2101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2103 ;;; Implementation of the Error function Erf(z)
2105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2107 ;;; erf has mirror symmetry
2109 (defprop %erf t commutes-with-conjugate)
2111 ;;; erf is an odd function
2113 (defprop %erf odd-function-reflect reflection-rule)
2115 ;;; erf distributes over bags
2117 (defprop %erf (mlist $matrix mequal) distribute_over)
2119 ;;; Derivative of the Error function erf
2121 (defprop %erf
2122 ((z)
2123 ((mtimes) 2
2124 ((mexpt) $%pi ((rat) -1 2))
2125 ((mexpt) $%e ((mtimes) -1 ((mexpt) z 2)))))
2126 grad)
2128 ;;; Integral of the Error function erf
2130 (defprop %erf
2131 ((z)
2132 ((mplus)
2133 ((mtimes)
2134 ((mexpt) $%pi ((rat) -1 2))
2135 ((mexpt) $%e ((mtimes) -1 ((mexpt) z 2))))
2136 ((mtimes) z ((%erf) z))))
2137 integral)
2139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2141 (defun erf-hypergeometric (z)
2142 ; See A&S 7.1.21 or http://functions.wolfram.com/06.25.26.0001.01
2143 (mul 2
2145 (power '$%pi '((rat simp) -1 2))
2146 (ftake '%hypergeometric
2147 (make-mlist 1//2)
2148 (make-mlist 3//2)
2149 (mul -1 (power z 2)))))
2151 ;;; erf is a simplifying function
2153 (def-simplifier erf (z)
2154 (cond
2156 ;; Check for specific values
2158 ((zerop1 z) z)
2159 ((eq z '$inf) 1)
2160 ((eq z '$minf) -1)
2162 ;; Check for numerical evaluation
2164 ((float-numerical-eval-p z)
2165 (bigfloat::bf-erf ($float z)))
2166 ((complex-float-numerical-eval-p z)
2167 (complexify
2168 (bigfloat::bf-erf (complex ($float ($realpart z)) ($float ($imagpart z))))))
2169 ((bigfloat-numerical-eval-p z)
2170 (to (bigfloat::bf-erf (bigfloat:to ($bfloat z)))))
2171 ((complex-bigfloat-numerical-eval-p z)
2172 (to (bigfloat::bf-erf
2173 (bigfloat:to (add ($bfloat ($realpart z)) (mul '$%i ($bfloat ($imagpart z))))))))
2175 ;; Argument simplification
2177 ((taylorize (mop form) (second form)))
2178 ((and $erf_%iargs
2179 (not $erf_representation)
2180 (multiplep z '$%i))
2181 (mul '$%i (simplify (list '(%erfi) (coeff z '$%i 1)))))
2182 ((apply-reflection-simp (mop form) z $trigsign))
2184 ;; Representation through more general functions
2186 ($hypergeometric_representation
2187 (erf-hypergeometric z))
2189 ;; Transformation to Erfc or Erfi
2191 ((and $erf_representation
2192 (not (eq $erf_representation '$erf)))
2193 (case $erf_representation
2194 (%erfc
2195 (sub 1 (take '(%erfc) z)))
2196 (%erfi
2197 (mul -1 '$%i (take '(%erfi) (mul '$%i z))))
2199 (give-up))))
2202 (give-up))))
2204 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2206 (defun erf (z)
2207 ;; We use the slatec routine for float values.
2208 (slatec:derf (float z)))
2210 ;; Compute erf(z) using the relationship
2212 ;; erf(z) = sqrt(z^2)/z*(1 - gamma_incomplete(1/2,z^2)/sqrt(%pi))
2214 ;; When z is real sqrt(z^2)/z is signum(z). For complex z,
2215 ;; sqrt(z^2)/z = 1 if -%pi/2 < arg(z) <= %pi/2 and -1 otherwise.
2217 ;; This relationship has serious round-off issues when z is small
2218 ;; because gamma_incomplete(1/2,z^2)/sqrt(%pi) is near 1.
2220 ;; complex-erf is for (lisp) complex numbers; bfloat-erf is for real
2221 ;; bfloats, and complex-bfloat-erf is for complex bfloats. Care is
2222 ;; taken to return real results for real arguments and imaginary
2223 ;; results for imaginary arguments
2224 (defun complex-erf (z)
2225 (let ((result
2227 (if (or (< (realpart z) 0.0) (and (= (realpart z) 0.0) (< (imagpart z) 0.0)))
2230 (- 1.0
2231 (* (/ (sqrt (float pi))) (gamma-incomplete 0.5 (* z z)))))))
2232 (cond
2233 ((= (imagpart z) 0.0)
2234 ;; Pure real argument, the result is real
2235 (complex (realpart result) 0.0))
2236 ((= (realpart z) 0.0)
2237 ;; Pure imaginary argument, the result is pure imaginary
2238 (complex 0.0 (imagpart result)))
2240 result))))
2242 (defun bfloat-erf (z)
2243 ;; Warning! This has round-off problems when abs(z) is very small.
2244 (let ((1//2 ($bfloat '((rat simp) 1 2))))
2245 ;; The argument is real, the result is real too
2246 ($realpart
2247 (mul
2248 (simplify (list '(%signum) z))
2249 (sub 1
2250 (mul
2251 (div 1 (power ($bfloat '$%pi) 1//2))
2252 (bfloat-gamma-incomplete 1//2 ($bfloat (power z 2)))))))))
2254 (defun complex-bfloat-erf (z)
2255 ;; Warning! This has round-off problems when abs(z) is very small.
2256 (let* (($ratprint nil)
2257 (1//2 ($bfloat '((rat simp) 1 2)))
2258 (result
2259 (cmul
2260 (cdiv (cpower (cpower z 2) 1//2) z)
2261 (sub 1
2262 (cmul
2263 (div 1 (power ($bfloat '$%pi) 1//2))
2264 (complex-bfloat-gamma-incomplete
2265 1//2
2266 ($bfloat (cpower z 2))))))))
2267 (cond
2268 ((zerop1 ($imagpart z))
2269 ;; Pure real argument, the result is real
2270 ($realpart result))
2271 ((zerop1 ($realpart z))
2272 ;; Pure imaginary argument, the result is pure imaginary
2273 (mul '$%i ($imagpart result)))
2275 ;; A general complex result
2276 result))))
2278 (in-package :bigfloat)
2280 ;; Erf(z) for all z. Z must be a CL real or complex number or a
2281 ;; BIGFLOAT or COMPLEX-BIGFLOAT object. The result will be of the
2282 ;; same type as Z.
2283 (defun bf-erf (z)
2284 (cond ((typep z 'cl:real)
2285 ;; Use Slatec derf, which should be faster than the series.
2286 (maxima::erf z))
2287 ((<= (abs z) 0.476936)
2288 ;; Use the series A&S 7.1.5 for small x:
2290 ;; erf(z) = 2*z/sqrt(%pi) * sum((-1)^n*z^(2*n)/n!/(2*n+1), n, 0, inf)
2292 ;; The threshold is approximately erf(x) = 0.5. (Doesn't
2293 ;; have to be super accurate.) This gives max accuracy when
2294 ;; using the identity erf(x) = 1 - erfc(x).
2295 (let ((z^2 (* z z)))
2296 (/ (* 2 z (sum-power-series z^2
2297 #'(lambda (k)
2298 (let ((2k (+ k k)))
2299 (- (/ (- 2k 1)
2301 (+ 2k 1)))))))
2302 (sqrt (%pi z)))))
2304 ;; The general case.
2305 (etypecase z
2306 (cl:real (maxima::erf z))
2307 (cl:complex (maxima::complex-erf z))
2308 (bigfloat
2309 (bigfloat (maxima::$bfloat (maxima::$expand (maxima::bfloat-erf (maxima::to z))))))
2310 (complex-bigfloat
2311 (bigfloat (maxima::$bfloat (maxima::$expand (maxima::complex-bfloat-erf (maxima::to z))))))))))
2313 (defun bf-erfc (z)
2314 ;; Compute erfc(z) via 1 - erf(z) is not very accurate if erf(z) is
2315 ;; near 1. Wolfram says
2317 ;; erfc(z) = 1 - sqrt(z^2)/z * (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2, z^2))
2319 ;; For real(z) > 0, sqrt(z^2)/z is 1 so
2321 ;; erfc(z) = 1 - (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2322 ;; = 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2)
2324 ;; For real(z) < 0, sqrt(z^2)/z is -1 so
2326 ;; erfc(z) = 1 + (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2327 ;; = 2 - 1/sqrt(pi)*gamma_incomplete(1/2,z^2)
2328 (flet ((gamma-inc (z)
2329 (etypecase z
2330 (cl:number
2331 (maxima::gamma-incomplete 0.5 z))
2332 (bigfloat
2333 (bigfloat:to (maxima::$bfloat
2334 (maxima::bfloat-gamma-incomplete (maxima::$bfloat maxima::1//2)
2335 (maxima::to z)))))
2336 (complex-bigfloat
2337 (bigfloat:to (maxima::$bfloat
2338 (maxima::complex-bfloat-gamma-incomplete (maxima::$bfloat maxima::1//2)
2339 (maxima::to z))))))))
2340 (if (>= (realpart z) 0)
2341 (/ (gamma-inc (* z z))
2342 (sqrt (%pi z)))
2343 (- 2
2344 (/ (gamma-inc (* z z))
2345 (sqrt (%pi z)))))))
2347 (in-package :maxima)
2349 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2351 ;;; Implementation of the Generalized Error function Erf(z1,z2)
2353 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2355 ;;; Generalized Erf has mirror symmetry
2357 (defprop %erf_generalized t commutes-with-conjugate)
2359 ;;; Generalized Erf distributes over bags
2361 (defprop %erf_generalized (mlist $matrix mequal) distribute_over)
2363 ;;; Generalized Erf is antisymmetric Erf(z1,z2) = - Erf(z2,z1)
2365 (eval-when
2366 (:load-toplevel :execute)
2367 (let (($context '$global) (context '$global))
2368 (meval '(($declare) %erf_generalized $antisymmetric))
2369 ;; Let's remove built-in symbols from list for user-defined properties.
2370 (setq $props (remove '%erf_generalized $props))))
2372 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2374 (defprop %erf_generalized
2375 ((z1 z2)
2376 ;; derivative wrt z1
2377 ((mtimes) -2
2378 ((mexpt) $%pi ((rat) -1 2))
2379 ((mexpt) $%e ((mtimes) -1 ((mexpt) z1 2))))
2380 ;; derviative wrt z2
2381 ((mtimes) 2
2382 ((mexpt) $%pi ((rat) -1 2))
2383 ((mexpt) $%e ((mtimes) -1 ((mexpt) z2 2)))))
2384 grad)
2386 ;;; ----------------------------------------------------------------------------
2388 (defprop %erf_generalized simplim%erf_generalized simplim%function)
2390 (defun simplim%erf_generalized (expr var val)
2391 ;; Look for the limit of the arguments.
2392 (let ((z1 (limit (cadr expr) var val 'think))
2393 (z2 (limit (caddr expr) var val 'think)))
2394 (cond
2395 ;; Handle infinities at this place.
2396 ((or (eq z2 '$inf)
2397 (alike1 z2 '((mtimes) -1 $minf)))
2398 (sub 1 (take '(%erf) z1)))
2399 ((or (eq z2 '$minf)
2400 (alike1 z2 '((mtimes) -1 $inf)))
2401 (sub (mul -1 (take '(%erf) z1)) 1))
2402 ((or (eq z1 '$inf)
2403 (alike1 z1 '((mtimes) -1 $minf)))
2404 (sub (take '(%erf) z2) 1))
2405 ((or (eq z1 '$minf)
2406 (alike1 z1 '((mtimes) -1 $inf)))
2407 (add (take '(%erf) z2) 1))
2409 ;; All other cases are handled by the simplifier of the function.
2410 (simplify (list '(%erf_generalized) z1 z2))))))
2412 ;;; ----------------------------------------------------------------------------
2414 (def-simplifier erf_generalized (z1 z2)
2415 (cond
2417 ;; Check for specific values
2419 ((and (zerop1 z1) (zerop1 z2)) 0)
2420 ((zerop1 z1) (take '(%erf) z2))
2421 ((zerop1 z2) (mul -1 (take '(%erf) z1)))
2422 ((or (eq z2 '$inf)
2423 (alike1 z2 '((mtimes) -1 $minf)))
2424 (sub 1 (take '(%erf) z1)))
2425 ((or (eq z2 '$minf)
2426 (alike1 z2 '((mtimes) -1 $inf)))
2427 (sub (mul -1 (take '(%erf) z1)) 1))
2428 ((or (eq z1 '$inf)
2429 (alike1 z1 '((mtimes) -1 $minf)))
2430 (sub (take '(%erf) z2) 1))
2431 ((or (eq z1 '$minf)
2432 (alike1 z1 '((mtimes) -1 $inf)))
2433 (add (take '(%erf) z2) 1))
2435 ;; Check for numerical evaluation. Use erf(z1,z2) = erf(z2)-erf(z1)
2437 ((float-numerical-eval-p z1 z2)
2438 (- (bigfloat::bf-erf ($float z2))
2439 (bigfloat::bf-erf ($float z1))))
2440 ((complex-float-numerical-eval-p z1 z2)
2441 (complexify
2443 (bigfloat::bf-erf
2444 (complex ($float ($realpart z2)) ($float ($imagpart z2))))
2445 (bigfloat::bf-erf
2446 (complex ($float ($realpart z1)) ($float ($imagpart z1)))))))
2447 ((bigfloat-numerical-eval-p z1 z2)
2448 (to (bigfloat:-
2449 (bigfloat::bf-erf (bigfloat:to ($bfloat z2)))
2450 (bigfloat::bf-erf (bigfloat:to ($bfloat z1))))))
2451 ((complex-bigfloat-numerical-eval-p z1 z2)
2452 (to (bigfloat:-
2453 (bigfloat::bf-erf
2454 (bigfloat:to (add ($bfloat ($realpart z2)) (mul '$%i ($bfloat ($imagpart z2))))))
2455 (bigfloat::bf-erf
2456 (bigfloat:to (add ($bfloat ($realpart z1)) (mul '$%i ($bfloat ($imagpart z1)))))))))
2458 ;; Argument simplification
2460 ((and $trigsign (great (mul -1 z1) z1) (great (mul -1 z2) z2))
2461 (mul -1 (simplify (list '(%erf_generalized) (mul -1 z1) (mul -1 z2)))))
2463 ;; Representation through more general functions
2465 ($hypergeometric_representation
2466 (sub (erf-hypergeometric z2) (erf-hypergeometric z1)))
2468 ;; Transformation to Erf
2470 ($erf_representation
2471 (sub (simplify (list '(%erf) z2)) (simplify (list '(%erf) z1))))
2474 (give-up))))
2476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2478 ;;; Implementation of the Complementary Error function Erfc(z)
2480 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2482 (defprop %erfc t commutes-with-conjugate)
2484 ;;; Complementary Error function distributes over bags
2486 (defprop %erfc (mlist $matrix mequal) distribute_over)
2488 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2490 (defprop %erfc
2491 ((z)
2492 ((mtimes) -2
2493 ((mexpt) $%pi ((rat) -1 2))
2494 ((mexpt) $%e ((mtimes) -1 ((mexpt) z 2)))))
2495 grad)
2497 ;;; Integral of the Error function erfc
2499 (defprop %erfc
2500 ((z)
2501 ((mplus)
2502 ((mtimes) -1
2503 ((mexpt) $%pi ((rat) -1 2))
2504 ((mexpt) $%e ((mtimes) -1 ((mexpt) z 2))))
2505 ((mtimes) z ((%erfc) z))))
2506 integral)
2508 ;;; ----------------------------------------------------------------------------
2510 (defprop %erfc simplim%erfc simplim%function)
2512 (defun simplim%erfc (expr var val)
2513 ;; Look for the limit of the arguments.
2514 (let ((z (limit (cadr expr) var val 'think)))
2515 (cond
2516 ;; Handle infinities at this place.
2517 ((eq z '$inf) 0)
2518 ((eq z '$minf) 2)
2519 ((eq z '$infinity) ;; parallel to code in simplim%erf-%tanh
2520 (destructuring-let (((rpart . ipart) (trisplit (cadr expr)))
2521 (ans ()) (rlim ()))
2522 (setq rlim (limit rpart var val 'think))
2523 (setq ans
2524 (limit (m* rpart (m^t ipart -1)) var val 'think))
2525 (setq ans ($asksign (m+ `((mabs) ,ans) -1)))
2526 (cond ((or (eq ans '$pos) (eq ans '$zero))
2527 (cond ((eq rlim '$inf) 0)
2528 ((eq rlim '$minf) 2)
2529 (t '$und)))
2530 (t '$und))))
2531 ((eq z '$ind) '$ind)
2533 ;; All other cases are handled by the simplifier of the function.
2534 (simplify (list '(%erfc) z))))))
2536 ;;; ----------------------------------------------------------------------------
2538 (def-simplifier erfc (z)
2539 (cond
2541 ;; Check for specific values
2543 ((zerop1 z) 1)
2544 ((eq z '$inf) 0)
2545 ((eq z '$minf) 2)
2547 ;; Check for numerical evaluation.
2549 ((numerical-eval-p z)
2550 (to (bigfloat::bf-erfc (bigfloat:to z))))
2552 ;; Argument simplification
2554 ((taylorize (mop form) (second form)))
2555 ((and $trigsign (great (mul -1 z) z))
2556 (sub 2 (simplify (list '(%erfc) (mul -1 z)))))
2558 ;; Representation through more general functions
2560 ($hypergeometric_representation
2561 (sub 1 (erf-hypergeometric z)))
2563 ;; Transformation to Erf or Erfi
2565 ((and $erf_representation
2566 (not (eq $erf_representation '$erfc)))
2567 (case $erf_representation
2568 (%erf
2569 (sub 1 (take '(%erf) z)))
2570 (%erfi
2571 (add 1 (mul '$%i (take '(%erfi) (mul '$%i z)))))
2573 (give-up))))
2576 (give-up))))
2578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2580 ;;; Implementation of the Imaginary Error function Erfi(z)
2582 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2584 ;;; erfi has mirror symmetry
2586 (defprop %erfi t commutes-with-conjugate)
2588 ;;; erfi is an odd function
2590 (defprop %erfi odd-function-reflect reflection-rule)
2592 ;;; erfi distributes over bags
2594 (defprop %erfi (mlist $matrix mequal) distribute_over)
2596 ;;; Derivative of the Error function erfi
2598 (defprop %erfi
2599 ((z)
2600 ((mtimes) 2
2601 ((mexpt) $%pi ((rat) -1 2))
2602 ((mexpt) $%e ((mexpt) z 2))))
2603 grad)
2605 ;;; Integral of the Error function erfi
2607 (defprop %erfi
2608 ((z)
2609 ((mplus)
2610 ((mtimes) -1
2611 ((mexpt) $%pi ((rat) -1 2))
2612 ((mexpt) $%e ((mexpt) z 2)))
2613 ((mtimes) z ((%erfi) z))))
2614 integral)
2616 ;;; ----------------------------------------------------------------------------
2618 (defprop %erfi simplim%erfi simplim%function)
2620 (defun simplim%erfi (expr var val)
2621 ;; Look for the limit of the arguments.
2622 (let ((z (limit (cadr expr) var val 'think)))
2623 (cond
2624 ;; Handle infinities at this place.
2625 ((eq z '$inf) '$inf)
2626 ((eq z '$minf) '$minf)
2628 ;; All other cases are handled by the simplifier of the function.
2629 (simplify (list '(%erfi) z))))))
2631 ;;; ----------------------------------------------------------------------------
2633 (in-package :bigfloat)
2634 (defun bf-erfi (z)
2635 (flet ((erfi (z)
2636 ;; Use the relationship erfi(z) = -%i*erf(%i*z)
2637 (let* ((iz (complex (- (imagpart z)) (realpart z))) ; %i*z
2638 (result (bf-erf iz)))
2639 (complex (imagpart result) (- (realpart result))))))
2640 ;; Take care to return real results when the argument is real.
2641 (if (realp z)
2642 (if (minusp z)
2643 (- (bf-erfi (- z)))
2644 (realpart (erfi z)))
2645 (erfi z))))
2647 (in-package :maxima)
2649 ;;; erfi is an simplifying function
2651 (def-simplifier erfi (z)
2652 (cond
2654 ;; Check for specific values
2656 ((zerop1 z) z)
2657 ((eq z '$inf) '$inf)
2658 ((eq z '$minf) '$minf)
2660 ;; Check for numerical evaluation. Use erfi(z) = -%i*erf(%i*z).
2662 ((numerical-eval-p z)
2663 (to (bigfloat::bf-erfi (bigfloat:to z))))
2665 ;; Argument simplification
2667 ((taylorize (mop form) (second form)))
2668 ((and $erf_%iargs
2669 (multiplep z '$%i))
2670 (mul '$%i (simplify (list '(%erf) (coeff z '$%i 1)))))
2671 ((apply-reflection-simp (mop form) z $trigsign))
2673 ;; Representation through more general functions
2675 ($hypergeometric_representation
2676 (mul -1 '$%i (erf-hypergeometric (mul '$%i z))))
2678 ;; Transformation to Erf or Erfc
2680 ((and $erf_representation
2681 (not (eq $erf_representation '$erfi)))
2682 (case $erf_representation
2683 (%erf
2684 (mul -1 '$%i (take '(%erf) (mul '$%i z))))
2685 (%erfc
2686 (sub (mul '$%i (take '(%erfc) (mul '$%i z))) '$%i))
2688 (give-up))))
2691 (give-up))))
2693 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2695 ;;; The implementation of the Inverse Error function
2697 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2699 ;;; The Inverse Error function distributes over bags
2701 (defprop %inverse_erf (mlist $matrix mequal) distribute_over)
2703 ;;; inverse_erf is the inverse of the erf function
2705 (defprop %inverse_erf %erf $inverse)
2706 (defprop %erf %inverse_erf $inverse)
2708 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2710 ;;; Differentiation of the Inverse Error function
2712 (defprop %inverse_erf
2713 ((z)
2714 ((mtimes)
2715 ((rat) 1 2)
2716 ((mexpt) $%pi ((rat) 1 2))
2717 ((mexpt) $%e ((mexpt) ((%inverse_erf) z) 2))))
2718 grad)
2720 ;;; Integral of the Inverse Error function
2722 (defprop %inverse_erf
2723 ((z)
2724 ((mtimes) -1
2725 ((mexpt) $%pi ((rat) -1 2))
2726 ((mexpt) $%e ((mtimes) -1 ((mexpt) ((%inverse_erf) z) 2)))))
2727 integral)
2729 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2731 ;;; We support a simplim%function. The function is looked up in simplimit and
2732 ;;; handles specific values of the function.
2734 (defprop %inverse_erf simplim%inverse_erf simplim%function)
2736 (defun simplim%inverse_erf (expr var val)
2737 ;; Look for the limit of the argument.
2738 (let ((z (limit (cadr expr) var val 'think)))
2739 (cond
2740 ;; Handle an argument 1 at this place
2741 ((onep1 z) '$inf)
2742 ((onep1 (mul -1 z)) '$minf)
2744 ;; All other cases are handled by the simplifier of the function.
2745 (simplify (list '(%inverse_erf) z))))))
2747 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2749 ;;; The Inverse Error function is a simplifying function
2751 (def-simplifier inverse_erf (z)
2752 (cond
2753 ((or (onep1 z)
2754 (onep1 (mul -1 z)))
2755 (simp-domain-error
2756 (intl:gettext "inverse_erf: inverse_erf(~:M) is undefined.") z))
2757 ((zerop1 z) z)
2758 ((numerical-eval-p z)
2759 (to (bigfloat::bf-inverse-erf (bigfloat:to z))))
2760 ((taylorize (mop form) (cadr form)))
2762 (give-up))))
2764 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2766 ;;; The implementation of the Inverse Complementary Error function
2768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2770 ;;; Inverse Complementary Error function distributes over bags
2772 (defprop %inverse_erfc (mlist $matrix mequal) distribute_over)
2774 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2776 ;;; inverse_erfc is the inverse of the erfc function
2778 (defprop %inverse_erfc %erfc $inverse)
2779 (defprop %erfc %inverse_erfc $inverse)
2782 ;;; Differentiation of the Inverse Complementary Error function
2784 (defprop %inverse_erfc
2785 ((z)
2786 ((mtimes)
2787 ((rat) -1 2)
2788 ((mexpt) $%pi ((rat) 1 2))
2789 ((mexpt) $%e ((mexpt) ((%inverse_erfc) z) 2))))
2790 grad)
2792 ;;; Integral of the Inverse Complementary Error function
2794 (defprop %inverse_erfc
2795 ((z)
2796 ((mtimes)
2797 ((mexpt) $%pi ((rat) -1 2))
2798 ((mexpt) $%e
2799 ((mtimes) -1 ((mexpt) ((%inverse_erfc) z) 2)))))
2800 integral)
2802 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2804 ;;; We support a simplim%function. The function is looked up in simplimit and
2805 ;;; handles specific values of the function.
2807 (defprop %inverse_erfc simplim%inverse_erfc simplim%function)
2809 (defun simplim%inverse_erfc (expr var val)
2810 ;; Look for the limit of the argument.
2811 (let ((z (limit (cadr expr) var val 'think)))
2812 (cond
2813 ;; Handle an argument 0 at this place
2814 ((or (zerop1 z)
2815 (eq z '$zeroa)
2816 (eq z '$zerob))
2817 '$inf)
2818 ((zerop1 (add z -2)) '$minf)
2820 ;; All other cases are handled by the simplifier of the function.
2821 (simplify (list '(%inverse_erfc) z))))))
2823 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2825 ;;; Inverse Complementary Error function is a simplifying function
2826 (def-simplifier inverse_erfc (z)
2827 (cond
2828 ((or (zerop1 z)
2829 (zerop1 (add z -2)))
2830 (simp-domain-error
2831 (intl:gettext "inverse_erfc: inverse_erfc(~:M) is undefined.") z))
2832 ((onep1 z) 0)
2833 ((numerical-eval-p z)
2834 (to (bigfloat::bf-inverse-erfc (bigfloat:to z))))
2835 ((taylorize (mop form) (cadr form)))
2837 (give-up))))
2839 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2841 ;;; Implementation of the Newton algorithm to calculate numerical values
2842 ;;; of the Inverse Error functions in float or bigfloat precision.
2843 ;;; The algorithm is a modified version of the routine in newton1.mac.
2845 (defvar *debug-newton* nil)
2846 (defvar *newton-maxcount* 1000)
2847 (defvar *newton-epsilon-factor* 50)
2848 (defvar *newton-epsilon-factor-float* 10)
2850 (defun float-newton (expr var x0 eps)
2851 (do ((s (sdiff expr var))
2852 (xn x0)
2853 (sn)
2854 (count 0 (+ count 1)))
2855 ((> count *newton-maxcount*)
2856 (merror
2857 (intl:gettext "float-newton: Newton does not converge for ~:M") expr))
2858 (setq sn ($float (maxima-substitute xn var expr)))
2859 (when (< (abs sn) eps) (return xn))
2860 (when *debug-newton* (format t "~&xn = ~A~%" xn))
2861 (setq xn ($float (sub xn (div sn (maxima-substitute xn var s)))))))
2863 (defun bfloat-newton (expr var x0 eps)
2864 (do ((s (sdiff expr var))
2865 (xn x0)
2866 (sn)
2867 (count 0 (+ count 1)))
2868 ((> count *newton-maxcount*)
2869 (merror
2870 (intl:gettext "bfloat-newton: Newton does not converge for ~:M") expr))
2871 (setq sn ($bfloat (maxima-substitute xn var expr)))
2872 (when (eq ($sign (sub (simplify (list '(mabs) sn)) eps)) '$neg)
2873 (return xn))
2874 (when *debug-newton* (format t "~&xn = ~A~%" xn))
2875 (setq xn ($bfloat (sub xn (div sn (maxima-substitute xn var s)))))))
2878 (in-package :bigfloat)
2880 ;; Compute inverse_erf(z) for z a real or complex number, including
2881 ;; bigfloat objects. The value is computing using a Newton iteration
2882 ;; to solve erf(x) = z.
2883 (defun bf-inverse-erf (z)
2884 (cond ((zerop z)
2886 ((= (abs z) 1)
2887 (maxima::merror
2888 (intl:gettext "bf-inverse-erf: inverse_erf(~M) is undefined")
2890 ((minusp (realpart z))
2891 ;; inverse_erf is odd because erf is.
2892 (- (bf-inverse-erf (- z))))
2894 (labels
2895 ((approx (z)
2896 ;; Find an approximate solution for x = inverse_erf(z).
2897 (let ((result
2898 (cond ((<= (abs z) 1)
2899 ;; For small z, inverse_erf(z) = z*sqrt(%pi)/2
2900 ;; + O(z^3). Thus, x = z*sqrt(%pi)/2 is our
2901 ;; initial starting point.
2902 (* z (sqrt (%pi z)) 1/2))
2904 ;; For |z| > 1 and realpart(z) >= 0, we have
2905 ;; the asymptotic series z = erf(x) = 1 -
2906 ;; exp(-x^2)/x/sqrt(%pi).
2908 ;; Then
2909 ;; x = sqrt(-log(x*sqrt(%pi)*(1-z))
2911 ;; We can use this as a fixed-point iteration
2912 ;; to find x, and we can start the iteration at
2913 ;; x = 1. Just do one more iteration. I (RLT)
2914 ;; think that's close enough to get the Newton
2915 ;; algorithm to converge.
2916 (let* ((sp (sqrt (%pi z)))
2917 (a (sqrt (- (log (* sp (- 1 z)))))))
2918 (setf a (sqrt (- (log (* a sp (- 1 z))))))
2919 (setf a (sqrt (- (log (* a sp (- 1 z)))))))))))
2920 (when maxima::*debug-newton*
2921 (format t "approx = ~S~%" result))
2922 result)))
2923 (let ((two/sqrt-pi (/ 2 (sqrt (%pi z))))
2924 (eps
2925 ;; Try to pick a reasonable epsilon value for the
2926 ;; Newton iteration.
2927 (cond ((<= (abs z) 1)
2928 (typecase z
2929 (cl:real (* maxima::*newton-epsilon-factor-float*
2930 maxima::+flonum-epsilon+))
2931 (t (* maxima::*newton-epsilon-factor* (epsilon z)))))
2933 (* maxima::*newton-epsilon-factor* (epsilon z))))))
2934 (when maxima::*debug-newton*
2935 (format t "eps = ~S~%" eps))
2936 (flet ((diff (x)
2937 ;; Derivative of erf(x)
2938 (* two/sqrt-pi (exp (- (* x x))))))
2939 (bf-newton #'bf-erf
2940 #'diff
2942 (approx z)
2943 eps)))))))
2945 (defun bf-inverse-erfc (z)
2946 (cond ((zerop z)
2947 (maxima::merror
2948 (intl:gettext "bf-inverse-erfc: inverse_erfc(~M) is undefined")
2950 ((= z 1)
2951 (float 0 z))
2953 (flet
2954 ((approx (z)
2955 ;; Find an approximate solution for x =
2956 ;; inverse_erfc(z). We have inverse_erfc(z) =
2957 ;; inverse_erf(1-z), so that's a good starting point.
2958 ;; We don't need full precision, so a float value is
2959 ;; good enough. But if 1-z is 1, inverse_erf is
2960 ;; undefined, so we need to do something else.
2961 (let ((result
2962 (let ((1-z (float (- 1 z) 0.0)))
2963 (cond ((= 1 1-z)
2964 (if (minusp (realpart z))
2965 (bf-inverse-erf (+ 1 (* 5 maxima::+flonum-epsilon+)))
2966 (bf-inverse-erf (- 1 (* 5 maxima::+flonum-epsilon+)))))
2968 (bf-inverse-erf 1-z))))))
2969 (when maxima::*debug-newton*
2970 (format t "approx = ~S~%" result))
2971 result)))
2972 (let ((-two/sqrt-pi (/ -2 (sqrt (%pi z))))
2973 (eps (* maxima::*newton-epsilon-factor* (epsilon z))))
2974 (when maxima::*debug-newton*
2975 (format t "eps = ~S~%" eps))
2976 (flet ((diff (x)
2977 ;; Derivative of erfc(x)
2978 (* -two/sqrt-pi (exp (- (* x x))))))
2979 (bf-newton #'bf-erfc
2980 #'diff
2982 (approx z)
2983 eps)))))))
2985 ;; Newton iteration for solving f(x) = z, given f and the derivative
2986 ;; of f.
2987 (defun bf-newton (f df z start eps)
2988 (do ((x start)
2989 (delta (/ (- (funcall f start) z)
2990 (funcall df start))
2991 (/ (- (funcall f x) z)
2992 (funcall df x)))
2993 (count 0 (1+ count)))
2994 ((or (< (abs delta) (* (abs x) eps))
2995 (> count maxima::*newton-maxcount*))
2996 (if (> count maxima::*newton-maxcount*)
2997 (maxima::merror
2998 (intl:gettext "bf-newton: failed to converge after ~M iterations: delta = ~S, x = ~S eps = ~S")
2999 count delta x eps)
3001 (when maxima::*debug-newton*
3002 (format t "x = ~S, abs(delta) = ~S relerr = ~S~%"
3003 x (abs delta) (/ (abs delta) (abs x))))
3004 (setf x (- x delta))))
3006 (in-package :maxima)
3008 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3010 ;;; Implementation of the Fresnel Integral S(z)
3012 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3014 ;;; fresnel_s distributes over bags
3016 (defprop %fresnel_s (mlist $matrix mequal) distribute_over)
3018 ;;; fresnel_s has mirror symmetry
3020 (defprop %fresnel_s t commutes-with-conjugate)
3022 ;;; fresnel_s is an odd function
3024 ;;; Maxima has two mechanism to define a reflection property
3025 ;;; 1. Declare the feature oddfun or evenfun
3026 ;;; 2. Put a reflection rule on the property list
3028 ;;; The second way is used for the trig functions. We use it here too.
3030 ;;; This would be the first way to give the property of an odd function.
3031 ;(eval-when
3032 ; (:load-toplevel :execute)
3033 ; (let (($context '$global) (context '$global))
3034 ; (meval '(($declare) %fresnel_s $oddfun))
3035 ; ;; Let's remove built-in symbols from list for user-defined properties.
3036 ; (setq $props (remove '%fresnel_s $props))))
3038 (defprop %fresnel_s odd-function-reflect reflection-rule)
3040 ;;; Differentiation of the Fresnel Integral S
3042 (defprop %fresnel_s
3043 ((z)
3044 ((%sin) ((mtimes) ((rat) 1 2) $%pi ((mexpt) z 2))))
3045 grad)
3047 ;;; Integration of the Fresnel Integral S
3049 (defprop %fresnel_s
3050 ((z)
3051 ((mplus)
3052 ((mtimes) z ((%fresnel_s) z))
3053 ((mtimes)
3054 ((mexpt) $%pi -1)
3055 ((%cos) ((mtimes) ((rat) 1 2) $%pi ((mexpt) z 2))))))
3056 integral)
3058 ;;; Limits of the Fresnel Integral S
3060 (defprop %fresnel_s simplim%fresnel_s simplim%function)
3061 (defun simplim%fresnel_s (exp var val)
3062 (let ((arg (limit (cadr exp) var val 'think)))
3063 (cond ((eq arg '$inf)
3064 '((rat simp) 1 2))
3065 ((eq arg '$minf)
3066 '((rat simp) -1 2))
3068 `((%fresnel_s) ,arg)))))
3070 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3072 (defvar *fresnel-maxit* 1000)
3073 (defvar *fresnel-eps* (* 2 +flonum-epsilon+))
3074 (defvar *fresnel-min* 1e-32)
3076 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3077 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3079 (in-package :bigfloat)
3081 (defun bf-fresnel (z)
3082 (let* ((eps (epsilon z))
3083 (maxit maxima::*fresnel-maxit*)
3084 (xmin 1.5)
3085 (bf-pi (%pi z))
3086 ;; For very small x, we have
3087 ;; fresnel_s(x) = %pi/6*z^3
3088 ;; fresnel_c(x) = x
3089 (s (* (/ bf-pi 6) z z z))
3090 (c z))
3091 (when (> (abs z) eps)
3092 (cond
3093 ((< (abs z) xmin)
3094 (when maxima::*debug-gamma*
3095 (format t "~& in FRESNEL series expansion.~%"))
3096 (let ((sums 0) (sumc z))
3097 (do ((sum 0)
3098 (sign 1)
3099 (fact (* (/ bf-pi 2) (* z z)))
3100 (term z)
3101 (odd t (not odd))
3102 (test 0)
3103 (n 3 (+ n 2))
3104 (k 1 (+ k 1)))
3105 ((> k maxit)
3106 (maxima::merror (intl:gettext "fresnel: series expansion failed for (COMPLEX-BFLOAT-FRESNEL ~:M).") z))
3107 (setq term (* term (/ fact k)))
3108 (setq sum (+ sum (/ (* sign term) n)))
3109 (setq test (* (abs sum) eps))
3110 (if odd
3111 (progn
3112 (setq sign (- sign))
3113 (setq sums sum)
3114 (setq sum sumc))
3115 (progn
3116 (setq sumc sum)
3117 (setq sum sums)))
3118 (if (< (abs term) test)
3119 (return)))
3120 (setq s sums)
3121 (setq c sumc)))
3123 (let* ((sqrt-pi (sqrt bf-pi))
3124 (z+ (* (complex 1/2 1/2)
3125 (* sqrt-pi
3126 z)))
3127 (z- (* (complex 1/2 -1/2)
3128 (* sqrt-pi
3129 z)))
3130 (erf+ (bf-erf z+))
3131 (erf- (bf-erf z-)))
3132 (setq s (* (complex 1/4 1/4)
3133 (+ erf+ (* (complex 0 -1) erf-))))
3134 (setq c (* (complex 1/4 -1/4)
3135 (+ erf+ (* (complex 0 1) erf-))))))))
3136 (values s c)))
3138 (defun bf-fresnel-s (z)
3139 (if (and (complexp z) (zerop (realpart z)))
3140 ;; A pure imaginary argument. Use fresnel_s(%i*x)=-%i*fresnel_s(x).
3141 (complex 0
3142 (- (bf-fresnel-s (imagpart z))))
3143 (let ((fs (bf-fresnel z)))
3144 (if (realp z)
3145 (realpart fs)
3146 fs))))
3148 (defun bf-fresnel-c (z)
3149 (if (and (complexp z) (zerop (realpart z)))
3150 ;; A pure imaginary argument. Use fresnel_c(%i*x)=%i*fresnel_c(x).
3151 (complex 0
3152 (bf-fresnel-c (imagpart z)))
3153 (let ((fc (nth-value 1 (bf-fresnel z))))
3154 (if (realp z)
3155 (realpart fc)
3156 fc))))
3158 (in-package :maxima)
3160 ;;; fresnel_s is a simplifying function
3161 (def-simplifier fresnel_s (z)
3162 (cond
3164 ;; Check for specific values
3166 ((zerop1 z) z)
3167 ((eq z '$inf) '((rat simp) 1 2))
3168 ((eq z '$minf) '((rat simp) -1 2))
3170 ;; Check for numerical evaluation
3171 ((numerical-eval-p z)
3172 (to (bigfloat::bf-fresnel-s (bigfloat::to z))))
3174 ;; Check for argument simplification
3176 ((taylorize (mop form) (second form)))
3177 ((and $%iargs (multiplep z '$%i))
3178 (mul -1 '$%i (simplify (list '(%fresnel_s) (coeff z '$%i 1)))))
3179 ((apply-reflection-simp (mop form) z $trigsign))
3181 ;; Representation through equivalent functions
3183 ($erf_representation
3184 (mul
3185 (div (add 1 '$%i) 4)
3186 (add
3187 (simplify
3188 (list
3189 '(%erf)
3190 (mul (div (add 1 '$%i) 2) (power '$%pi '((rat simp) 1 2)) z)))
3191 (mul -1 '$%i
3192 (simplify
3193 (list
3194 '(%erf)
3195 (mul (div (sub 1 '$%i) 2)
3196 (power '$%pi '((rat simp) 1 2)) z)))))))
3198 ($hypergeometric_representation
3199 (mul (div (mul '$%pi (power z 3)) 6)
3200 (ftake '%hypergeometric
3201 (list '(mlist) (div 3 4))
3202 (list '(mlist) (div 3 2) (div 7 4))
3203 (mul -1 (div (mul (power '$%pi 2) (power z 4)) 16)))))
3206 (give-up))))
3207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3209 ;;; Implementation of the Fresnel Integral C(z)
3211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3213 ;;; fresnel_c distributes over bags
3215 (defprop %fresnel_c (mlist $matrix mequal) distribute_over)
3217 ;;; fresnel_c has mirror symmetry
3219 (defprop %fresnel_c t commutes-with-conjugate)
3221 ;;; fresnel_c is an odd function
3222 ;;; Maxima has two mechanism to define a reflection property
3223 ;;; 1. Declare the feature oddfun or evenfun
3224 ;;; 2. Put a reflection rule on the property list
3226 ;;; The second way is used for the trig functions. We use it here too.
3228 (defprop %fresnel_c odd-function-reflect reflection-rule)
3230 ;;; Differentiation of the Fresnel Integral C
3232 (defprop %fresnel_c
3233 ((z)
3234 ((%cos) ((mtimes) ((rat) 1 2) $%pi ((mexpt) z 2))))
3235 grad)
3237 ;;; Integration of the Fresnel Integral C
3239 (defprop %fresnel_c
3240 ((z)
3241 ((mplus)
3242 ((mtimes) z ((%fresnel_c) z))
3243 ((mtimes) -1
3244 ((mexpt) $%pi -1)
3245 ((%sin) ((mtimes) ((rat) 1 2) $%pi ((mexpt) z 2))))))
3246 integral)
3248 ;;; Limits of the Fresnel Integral C
3250 (defprop %fresnel_c simplim%fresnel_c simplim%function)
3251 (defun simplim%fresnel_c (exp var val)
3252 (let ((arg (limit (cadr exp) var val 'think)))
3253 (cond ((eq arg '$inf)
3254 '((rat simp) 1 2))
3255 ((eq arg '$minf)
3256 '((rat simp) -1 2))
3258 `((%fresnel_c) ,arg)))))
3260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3262 ;;; fresnel_c is a simplifying function
3263 (def-simplifier fresnel_c (z)
3264 (cond
3266 ;; Check for specific values
3268 ((zerop1 z) z)
3269 ((eq z '$inf) '((rat simp) 1 2))
3270 ((eq z '$minf) '((rat simp) -1 2))
3272 ;; Check for numerical evaluation
3273 ((numerical-eval-p z)
3274 (to (bigfloat::bf-fresnel-c (bigfloat::to z))))
3277 ;; Check for argument simplification
3279 ((taylorize (mop form) (second form)))
3280 ((and $%iargs (multiplep z '$%i))
3281 (mul '$%i (simplify (list '(%fresnel_c) (coeff z '$%i 1)))))
3282 ((apply-reflection-simp (mop form) z $trigsign))
3284 ;; Representation through equivalent functions
3286 ($erf_representation
3287 (mul
3288 (div (sub 1 '$%i) 4)
3289 (add
3290 (simplify
3291 (list
3292 '(%erf)
3293 (mul (div (add 1 '$%i) 2) (power '$%pi '((rat simp) 1 2)) z)))
3294 (mul '$%i
3295 (simplify
3296 (list
3297 '(%erf)
3298 (mul (div (sub 1 '$%i) 2)
3299 (power '$%pi '((rat simp) 1 2)) z)))))))
3301 ($hypergeometric_representation
3302 (mul z
3303 (ftake '%hypergeometric
3304 (list '(mlist) (div 1 4))
3305 (list '(mlist) (div 1 2) (div 5 4))
3306 (mul -1 (div (mul (power '$%pi 2) (power z 4)) 16)))))
3309 (give-up))))
3310 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3312 ;;; Implementation of the Beta function
3314 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3316 ;;; The code for the implementation of the beta function is in the files
3317 ;;; csimp2.lisp, simp.lisp and mactex.lisp.
3318 ;;; At this place we only implement the operator property SYMMETRIC.
3320 ;;; Beta is symmetric beta(a,b) = beta(b,a)
3322 (eval-when
3323 (:load-toplevel :execute)
3324 (let (($context '$global) (context '$global))
3325 (meval '(($declare) %beta $symmetric))
3326 ;; Let's remove built-in symbols from list for user-defined properties.
3327 (setq $props (remove '%beta $props))))
3329 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3331 ;;; Implementation of the Incomplete Beta function
3333 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3335 (defvar *beta-incomplete-maxit* 10000)
3336 (defvar *beta-incomplete-eps* 1.0e-15)
3338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3340 ;;; beta_incomplete distributes over bags
3342 (defprop %beta_incomplete (mlist $matrix mequal) distribute_over)
3344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3346 (defprop %beta_incomplete
3347 ((a b z)
3348 ;; Derivative wrt a
3349 ((mplus)
3350 ((mtimes) ((%beta_incomplete) a b z) ((%log) z))
3351 ((mtimes) -1
3352 ((mexpt) ((%gamma) a) 2)
3353 (($hypergeometric_regularized)
3354 ((mlist) a a ((mplus) 1 ((mtimes) -1 b)))
3355 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
3357 ((mexpt) z a)))
3358 ;; Derivative wrt b
3359 ((mplus)
3360 ((mtimes)
3361 ((%beta) a b)
3362 ((mplus)
3363 ((mqapply) (($psi array) 0) b)
3364 ((mtimes) -1 ((mqapply) (($psi array) 0) ((mplus) a b)))))
3365 ((mtimes) -1
3366 ((%beta_incomplete) b a ((mplus) 1 ((mtimes) -1 z)))
3367 ((%log) ((mplus) 1 ((mtimes) -1 z))))
3368 ((mtimes)
3369 ((mexpt) ((%gamma) b) 2)
3370 (($hypergeometric_regularized)
3371 ((mlist) b b ((mplus) 1 ((mtimes) -1 a)))
3372 ((mlist) ((mplus) 1 b) ((mplus) 1 b))
3373 ((mplus) 1 ((mtimes) -1 z)))
3374 ((mexpt) ((mplus) 1 ((mtimes) -1 z)) b)))
3375 ;; The derivative wrt z
3376 ((mtimes)
3377 ((mexpt) ((mplus) 1 ((mtimes) -1 z)) ((mplus) -1 b))
3378 ((mexpt) z ((mplus) -1 a))))
3379 grad)
3381 ;;; Integral of the Incomplete Beta function
3383 (defprop %beta_incomplete
3384 ((a b z)
3385 nil
3387 ((mplus)
3388 ((mtimes) -1 ((%beta_incomplete) ((mplus) 1 a) b z))
3389 ((mtimes) ((%beta_incomplete) a b z) z)))
3390 integral)
3392 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3394 (def-simplifier beta_incomplete (a b z)
3395 (let (($simpsum t))
3396 (when *debug-gamma*
3397 (format t "~&SIMP-BETA-INCOMPLETE:~%")
3398 (format t "~& : a = ~A~%" a)
3399 (format t "~& : b = ~A~%" b)
3400 (format t "~& : z = ~A~%" z))
3401 (cond
3403 ;; Check for specific values
3405 ((zerop1 z)
3406 (let ((sgn ($sign ($realpart a))))
3407 (cond ((member sgn '($neg $zero))
3408 (simp-domain-error
3409 (intl:gettext
3410 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.")
3411 a b z))
3412 ((member sgn '($pos $pz))
3415 (give-up)))))
3417 ((and (onep1 z) (eq ($sign ($realpart b)) '$pos))
3418 ;; z=1 and realpart(b)>0. Simplify to a Beta function.
3419 ;; If we have to evaluate numerically preserve the type.
3420 (cond
3421 ((complex-float-numerical-eval-p a b z)
3422 (ftake* '%beta ($float a) ($float b)))
3423 ((complex-bigfloat-numerical-eval-p a b z)
3424 (ftake* '%beta ($bfloat a) ($bfloat b)))
3426 (ftake* '%beta a b))))
3428 ((or (zerop1 a)
3429 (and (integer-representation-p a)
3430 (eq ($sign a) '$neg)
3431 (or (and (mnump b)
3432 (not (integer-representation-p b)))
3433 (eq ($sign (add a b)) '$pos))))
3434 ;; The argument a is zero or a is negative and the argument b is
3435 ;; not in a valid range. Beta incomplete is undefined.
3436 ;; It would be more correct to return Complex infinity.
3437 (simp-domain-error
3438 (intl:gettext
3439 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.") a b z))
3441 ;; Check for numerical evaluation in Float or Bigfloat precision
3443 ((complex-float-numerical-eval-p a b z)
3444 (cond
3445 ((not (and (integer-representation-p a) (< a 0.0)))
3446 (let ((*beta-incomplete-eps* (bigfloat:epsilon ($float 1.0))))
3447 (beta-incomplete ($float a) ($float b) ($float z))))
3449 ;; Negative integer a and b is in a valid range. Expand.
3450 ($rectform
3451 (beta-incomplete-expand-negative-integer
3452 (truncate a) ($float b) ($float z))))))
3454 ((complex-bigfloat-numerical-eval-p a b z)
3455 (cond
3456 ((not (and (integer-representation-p a) (eq ($sign a) '$neg)))
3457 (let ((*beta-incomplete-eps*
3458 (bigfloat:epsilon (bigfloat:bigfloat 1.0))))
3459 (beta-incomplete ($bfloat a) ($bfloat b) ($bfloat z))))
3461 ;; Negative integer a and b is in a valid range. Expand.
3462 ($rectform
3463 (beta-incomplete-expand-negative-integer
3464 ($truncate a) ($bfloat b) ($bfloat z))))))
3466 ;; Argument simplifications and transformations
3468 ((and (integerp b)
3469 (plusp b)
3470 (or (not (integerp a))
3471 (plusp a)))
3472 ;; Expand for b a positive integer and a not a negative integer.
3473 (mul
3474 (ftake* '%beta a b)
3475 (power z a)
3476 (let ((index (gensumindex)))
3477 (simpsum1
3478 (div
3479 (mul
3480 (simplify (list '($pochhammer) a index))
3481 (power (sub 1 z) index))
3482 (simplify (list '(mfactorial) index)))
3483 index 0 (sub b 1)))))
3485 ((and (integerp a) (plusp a))
3486 ;; Expand for a a positive integer.
3487 (mul
3488 (ftake* '%beta a b)
3489 (sub 1
3490 (mul
3491 (power (sub 1 z) b)
3492 (let ((index (gensumindex)))
3493 (simpsum1
3494 (div
3495 (mul
3496 (simplify (list '($pochhammer) b index))
3497 (power z index))
3498 (simplify (list '(mfactorial) index)))
3499 index 0 (sub a 1)))))))
3501 ((and (integerp a) (minusp a) (integerp b) (plusp b) (<= b (- a)))
3502 ;; Expand for a a negative integer and b an integer with b <= -a.
3503 (mul
3504 (power z a)
3505 (let ((index (gensumindex)))
3506 (simpsum1
3507 (div
3508 (mul (simplify (list '($pochhammer) (sub 1 b) index))
3509 (power z index))
3510 (mul (add index a)
3511 (simplify (list '(mfactorial) index))))
3512 index 0 (sub b 1)))))
3514 ((and $beta_expand (mplusp a) (integerp (cadr a)) (plusp (cadr a)))
3515 (let ((n (cadr a))
3516 (a (simplify (cons '(mplus) (cddr a)))))
3517 (sub
3518 (mul
3519 (div
3520 (simplify (list '($pochhammer) a n))
3521 (simplify (list '($pochhammer) (add a b) n)))
3522 (ftake '%beta_incomplete a b z))
3523 (mul
3524 (power (add a b n -1) -1)
3525 (let ((index (gensumindex)))
3526 (simpsum1
3527 (mul
3528 (div
3529 (simplify (list '($pochhammer)
3530 (add 1 (mul -1 a) (mul -1 n))
3531 index))
3532 (simplify (list '($pochhammer)
3533 (add 2 (mul -1 a) (mul -1 b) (mul -1 n))
3534 index)))
3535 (mul (power (sub 1 z) b)
3536 (power z (add a n (mul -1 index) -1))))
3537 index 0 (sub n 1)))))))
3539 ((and $beta_expand (mplusp a) (integerp (cadr a)) (minusp (cadr a)))
3540 (let ((n (- (cadr a)))
3541 (a (simplify (cons '(mplus) (cddr a)))))
3542 (sub
3543 (mul
3544 (div
3545 (simplify (list '($pochhammer) (add 1 (mul -1 a) (mul -1 b)) n))
3546 (simplify (list '($pochhammer) (sub 1 a) n)))
3547 (ftake '%beta_incomplete a b z))
3548 (mul
3549 (div
3550 (simplify
3551 (list '($pochhammer) (add 2 (mul -1 a) (mul -1 b)) (sub n 1)))
3552 (simplify (list '($pochhammer) (sub 1 a) n)))
3553 (let ((index (gensumindex)))
3554 (simpsum1
3555 (mul
3556 (div
3557 (simplify (list '($pochhammer) (sub 1 a) index))
3558 (simplify (list '($pochhammer)
3559 (add 2 (mul -1 a) (mul -1 b))
3560 index)))
3561 (mul (power (sub 1 z) b)
3562 (power z (add a (mul -1 index) -1))))
3563 index 0 (sub n 1)))))))
3565 ($hypergeometric_representation
3566 ;; There are several cases to consider.
3568 ;; For -a not an integer see
3569 ;; http://functions.wolfram.com/06.19.26.0005.01
3571 ;; beta_incomplete(a,b,z) = z^a/a*%f[2,1]([a,1-b],[a+1],z)
3573 ;; For -b not an integer see
3574 ;; http://functions.wolfram.com/06.19.26.0007.01
3576 ;; beta_incomplete(a,b,z) = beta(a,b) -
3577 ;; (1-z)^b*z^a/b*%f[2,1]([1,a+b],[b+1],1-z)
3579 ;; For a+b not a positive integer see
3580 ;; http://functions.wolfram.com/06.19.26.0008.01
3582 ;; beta_incomplete(a,b,z) =
3583 ;; z^a*(-z)^(b-1)/(a+b-1)*%f[2,1]([1-b,-a-b+1],[-a-b+2],1/z)
3584 ;; + z^a*beta(1-a-b,a)*(-z)^(-a)
3586 ;; We need to handle more cases here
3587 (mul (div (power z a)
3589 (ftake '%hypergeometric
3590 (make-mlist a (sub 1 b))
3591 (make-mlist (add 1 a))
3592 z)))
3595 (give-up)))))
3597 (defun beta-incomplete-expand-negative-integer (a b z)
3598 (mul
3599 (power z a)
3600 (let ((index (gensumindex)) ($simpsum t))
3601 (simpsum1
3602 (div
3603 (mul (simplify (list '($pochhammer) (sub 1 b) index))
3604 (power z index))
3605 (mul (add index a) (simplify (list '(mfactorial) index))))
3606 index 0 (sub b 1)))))
3608 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3610 (defun beta-incomplete (a b z)
3611 (cond
3612 ((eq ($sign (sub (mul ($realpart z) ($realpart (add a b 2)))
3613 ($realpart (add a 1))))
3614 '$pos)
3615 ($rectform
3616 (sub
3617 (ftake* '%beta a b)
3618 (to (numeric-beta-incomplete b a (sub 1.0 z))))))
3620 (to (numeric-beta-incomplete a b z)))))
3622 (defun numeric-beta-incomplete (a b z)
3623 (when *debug-gamma*
3624 (format t "~&NUMERIC-BETA-INCOMPLETE enters continued fractions~%"))
3625 (let ((a (bigfloat:to a))
3626 (b (bigfloat:to b))
3627 (z (bigfloat:to z)))
3628 (do* ((beta-maxit *beta-incomplete-maxit*)
3629 (beta-eps *beta-incomplete-eps*)
3630 (beta-min (bigfloat:* beta-eps beta-eps))
3631 (ab (bigfloat:+ a b))
3632 (ap (bigfloat:+ a 1.0))
3633 (am (bigfloat:- a 1.0))
3634 (c 1.0)
3635 (d (bigfloat:- 1.0 (bigfloat:/ (bigfloat:* z ab) ap)))
3636 (d (if (bigfloat:< (bigfloat:abs d) beta-min) beta-min d))
3637 (d (bigfloat:/ 1.0 d))
3638 (h d)
3639 (aa 0.0)
3640 (de 0.0)
3641 (m2 0)
3642 (m 1 (+ m 1)))
3643 ((> m beta-maxit)
3644 (merror (intl:gettext "beta_incomplete: continued fractions failed for beta_incomplete(~:M, ~:M, ~:M).") a b z))
3645 (setq m2 (+ m m))
3646 (setq aa (bigfloat:/ (bigfloat:* m z (bigfloat:- b m))
3647 (bigfloat:* (bigfloat:+ am m2)
3648 (bigfloat:+ a m2))))
3649 (setq d (bigfloat:+ 1.0 (bigfloat:* aa d)))
3650 (when (bigfloat:< (bigfloat:abs d) beta-min) (setq d beta-min))
3651 (setq c (bigfloat:+ 1.0 (bigfloat:/ aa c)))
3652 (when (bigfloat:< (bigfloat:abs c) beta-min) (setq c beta-min))
3653 (setq d (bigfloat:/ 1.0 d))
3654 (setq h (bigfloat:* h d c))
3655 (setq aa (bigfloat:/ (bigfloat:* -1
3656 (bigfloat:+ a m)
3657 (bigfloat:+ ab m) z)
3658 (bigfloat:* (bigfloat:+ a m2)
3659 (bigfloat:+ ap m2))))
3660 (setq d (bigfloat:+ 1.0 (bigfloat:* aa d)))
3661 (when (bigfloat:< (bigfloat:abs d) beta-min) (setq d beta-min))
3662 (setq c (bigfloat:+ 1.0 (bigfloat:/ aa c)))
3663 (when (bigfloat:< (bigfloat:abs c) beta-min) (setq c beta-min))
3664 (setq d (bigfloat:/ 1.0 d))
3665 (setq de (bigfloat:* d c))
3666 (setq h (bigfloat:* h de))
3667 (when (bigfloat:< (bigfloat:abs (bigfloat:- de 1.0)) beta-eps)
3668 (when *debug-gamma*
3669 (format t "~&Continued fractions finished.~%")
3670 (format t "~& z = ~A~%" z)
3671 (format t "~& a = ~A~%" a)
3672 (format t "~& b = ~A~%" b)
3673 (format t "~& h = ~A~%" h))
3674 (return
3675 (let ((result
3676 (bigfloat:/
3677 (bigfloat:* h
3678 (bigfloat:expt z a)
3679 (bigfloat:expt (bigfloat:- 1.0 z) b)) a)))
3680 (when *debug-gamma*
3681 (format t "~& result = ~A~%" result))
3682 result))))))
3684 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3686 ;;; Implementation of the Generalized Incomplete Beta function
3688 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3690 ;;; beta_incomplete_generalized distributes over bags
3692 (defprop %beta_incomplete_generalized (mlist $matrix mequal) distribute_over)
3694 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3696 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
3697 ;;; but not on the negative real axis and for z1 or z2 real and > 1.
3698 ;;; We support a conjugate-function which test these cases.
3700 (defprop %beta_incomplete_generalized
3701 conjugate-beta-incomplete-generalized conjugate-function)
3703 (defun conjugate-beta-incomplete-generalized (args)
3704 (let ((a (first args))
3705 (b (second args))
3706 (z1 (third args))
3707 (z2 (fourth args)))
3708 (cond ((and (off-negative-real-axisp z1)
3709 (not (and (zerop1 ($imagpart z1))
3710 (eq ($sign (sub ($realpart z1) 1)) '$pos)))
3711 (off-negative-real-axisp z2)
3712 (not (and (zerop1 ($imagpart z2))
3713 (eq ($sign (sub ($realpart z2) 1)) '$pos))))
3714 (simplify
3715 (list
3716 '(%beta_incomplete_generalized)
3717 (simplify (list '($conjugate) a))
3718 (simplify (list '($conjugate) b))
3719 (simplify (list '($conjugate) z1))
3720 (simplify (list '($conjugate) z2)))))
3722 (list
3723 '($conjugate simp)
3724 (simplify (list '(%beta_incomplete_generalized)
3725 a b z1 z2)))))))
3727 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3729 (defprop %beta_incomplete_generalized
3730 ((a b z1 z2)
3731 ;; Derivative wrt a
3732 ((mplus)
3733 ((mtimes) -1
3734 ((%beta_incomplete) a b z1)
3735 ((%log) z1))
3736 ((mtimes)
3737 ((mexpt) ((%gamma) a) 2)
3738 ((mplus)
3739 ((mtimes)
3740 (($hypergeometric_regularized)
3741 ((mlist) a a ((mplus) 1 ((mtimes) -1 b)))
3742 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
3744 ((mexpt) z1 a))
3745 ((mtimes) -1
3746 (($hypergeometric_regularized)
3747 ((mlist) a a ((mplus) 1 ((mtimes) -1 b)))
3748 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
3750 ((mexpt) z2 a))))
3751 ((mtimes) ((%beta_incomplete) a b z2) ((%log) z2)))
3752 ;; Derivative wrt b
3753 ((mplus)
3754 ((mtimes)
3755 ((%beta_incomplete) b a ((mplus) 1 ((mtimes) -1 z1)))
3756 ((%log) ((mplus) 1 ((mtimes) -1 z1))))
3757 ((mtimes) -1
3758 ((%beta_incomplete) b a ((mplus) 1 ((mtimes) -1 z2)))
3759 ((%log) ((mplus) 1 ((mtimes) -1 z2))))
3760 ((mtimes) -1
3761 ((mexpt) ((%gamma) b) 2)
3762 ((mplus)
3763 ((mtimes)
3764 (($hypergeometric_regularized)
3765 ((mlist) b b ((mplus) 1 ((mtimes) -1 a)))
3766 ((mlist) ((mplus) 1 b) ((mplus) 1 b))
3767 ((mplus) 1 ((mtimes) -1 z1)))
3768 ((mexpt) ((mplus) 1 ((mtimes) -1 z1)) b))
3769 ((mtimes) -1
3770 (($hypergeometric_regularized)
3771 ((mlist) b b ((mplus) 1 ((mtimes) -1 a)))
3772 ((mlist) ((mplus) 1 b) ((mplus) 1 b))
3773 ((mplus) 1 ((mtimes) -1 z2)))
3774 ((mexpt) ((mplus) 1 ((mtimes) -1 z2)) b)))))
3775 ;; The derivative wrt z1
3776 ((mtimes) -1
3777 ((mexpt)
3778 ((mplus) 1 ((mtimes) -1 z1))
3779 ((mplus) -1 b))
3780 ((mexpt) z1 ((mplus) -1 a)))
3781 ;; The derivative wrt z2
3782 ((mtimes)
3783 ((mexpt)
3784 ((mplus) 1 ((mtimes) -1 z2))
3785 ((mplus) -1 b))
3786 ((mexpt) z2 ((mplus) -1 a))))
3787 grad)
3789 ;;; Integral of the Incomplete Beta function
3791 (defprop %beta_incomplete_generalized
3792 ((a b z1 z2)
3793 nil
3795 ;; Integral wrt z1
3796 ((mplus)
3797 ((%beta_incomplete) ((mplus) 1 a) b z1)
3798 ((mtimes) ((%beta_incomplete_generalized) a b z1 z2) z1))
3799 ;; Integral wrt z2
3800 ((mplus)
3801 ((mtimes) -1
3802 ((%beta_incomplete) ((mplus) 1 a) b z2))
3803 ((mtimes) ((%beta_incomplete_generalized) a b z1 z2) z2)))
3804 integral)
3806 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3808 (def-simplifier beta_incomplete_generalized (a b z1 z2)
3809 (let (($simpsum t))
3810 (cond
3812 ;; Check for specific values
3814 ((zerop1 z2)
3815 (let ((sgn ($sign ($realpart a))))
3816 (cond ((eq sgn '$neg)
3817 (simp-domain-error
3818 (intl:gettext
3819 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3820 a b z1 z2))
3821 ((member sgn '($pos $pz))
3822 (mul -1 (ftake '%beta_incomplete a b z1)))
3824 (give-up)))))
3826 ((zerop1 z1)
3827 (let ((sgn ($sign ($realpart a))))
3828 (cond ((eq sgn '$neg)
3829 (simp-domain-error
3830 (intl:gettext
3831 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3832 a b z1 z2))
3833 ((member sgn '($pos $pz))
3834 (mul -1 (ftake '%beta_incomplete a b z2)))
3836 (give-up)))))
3838 ((and (onep1 z2) (or (not (mnump a)) (not (mnump b)) (not (mnump z1))))
3839 (let ((sgn ($sign ($realpart b))))
3840 (cond ((member sgn '($pos $pz))
3841 (sub (ftake* '%beta a b)
3842 (ftake '%beta_incomplete a b z1)))
3844 (give-up)))))
3846 ((and (onep1 z1) (or (not (mnump a)) (not (mnump b)) (not (mnump z2))))
3847 (let ((sgn ($sign ($realpart b))))
3848 (cond ((member sgn '($pos $pz))
3849 (sub (ftake '%beta_incomplete a b z2)
3850 (ftake* '%beta a b)))
3852 (give-up)))))
3854 ;; Check for numerical evaluation in Float or Bigfloat precision
3856 ((complex-float-numerical-eval-p a b z1 z2)
3857 (let ((*beta-incomplete-eps* (bigfloat:epsilon ($float 1.0))))
3858 (sub (beta-incomplete ($float a) ($float b) ($float z2))
3859 (beta-incomplete ($float a) ($float b) ($float z1)))))
3861 ((complex-bigfloat-numerical-eval-p a b z1 z2)
3862 (let ((*beta-incomplete-eps*
3863 (bigfloat:epsilon (bigfloat:bigfloat 1.0))))
3864 (sub (beta-incomplete ($bfloat a) ($bfloat b) ($bfloat z2))
3865 (beta-incomplete ($bfloat a) ($bfloat b) ($bfloat z1)))))
3867 ;; Check for argument simplifications and transformations
3869 ((and (integerp a) (plusp a))
3870 (mul
3871 (ftake* '%beta a b)
3872 (sub
3873 (mul
3874 (power (sub 1 z1) b)
3875 (let ((index (gensumindex)))
3876 (simpsum1
3877 (div
3878 (mul
3879 (simplify (list '($pochhammer) b index))
3880 (power z1 index))
3881 (simplify (list '(mfactorial) index)))
3882 index 0 (sub a 1))))
3883 (mul
3884 (power (sub 1 z2) b)
3885 (let ((index (gensumindex)))
3886 (simpsum1
3887 (div
3888 (mul
3889 (simplify (list '($pochhammer) b index))
3890 (power z2 index))
3891 (simplify (list '(mfactorial) index)))
3892 index 0 (sub a 1)))))))
3894 ((and (integerp b) (plusp b))
3895 (mul
3896 (ftake* '%beta a b)
3897 (sub
3898 (mul
3899 (power z2 a)
3900 (let ((index (gensumindex)))
3901 (simpsum1
3902 (div
3903 (mul
3904 (simplify (list '($pochhammer) a index))
3905 (power (sub 1 z2) index))
3906 (simplify (list '(mfactorial) index)))
3907 index 0 (sub b 1))))
3908 (mul
3909 (power z1 a)
3910 (let ((index (gensumindex)))
3911 (simpsum1
3912 (div
3913 (mul
3914 (simplify (list '($pochhammer) a index))
3915 (power (sub 1 z1) index))
3916 (simplify (list '(mfactorial) index)))
3917 index 0 (sub b 1)))))))
3919 ((and $beta_expand (mplusp a) (integerp (cadr a)) (plusp (cadr a)))
3920 (let ((n (cadr a))
3921 (a (simplify (cons '(mplus) (cddr a)))))
3922 (add
3923 (mul
3924 (div
3925 (simplify (list '($pochhammer) a n))
3926 (simplify (list '($pochhammer) (add a b) n)))
3927 (take '(%beta_incomplete_generalized) a b z1 z2))
3928 (mul
3929 (power (add a b n -1) -1)
3930 (let ((index (gensumindex)))
3931 (simpsum1
3932 (mul
3933 (div
3934 (simplify (list '($pochhammer)
3935 (add 1 (mul -1 a) (mul -1 n))
3936 index))
3937 (simplify (list '($pochhammer)
3938 (add 2 (mul -1 a) (mul -1 b) (mul -1 n))
3939 index)))
3940 (sub
3941 (mul (power (sub 1 z1) b)
3942 (power z1 (add a n (mul -1 index) -1)))
3943 (mul (power (sub 1 z2) b)
3944 (power z2 (add a n (mul -1 index) -1)))))
3945 index 0 (sub n 1)))))))
3947 ((and $beta_expand (mplusp a) (integerp (cadr a)) (minusp (cadr a)))
3948 (let ((n (- (cadr a)))
3949 (a (simplify (cons '(mplus) (cddr a)))))
3950 (sub
3951 (mul
3952 (div
3953 (simplify (list '($pochhammer) (add 1 (mul -1 a) (mul -1 b)) n))
3954 (simplify (list '($pochhammer) (sub 1 a) n)))
3955 (take '(%beta_incomplete_generalized) a b z1 z2))
3956 (mul
3957 (div
3958 (simplify
3959 (list '($pochhammer) (add 2 (mul -1 a) (mul -1 b)) (sub n 1)))
3960 (simplify (list '($pochhammer) (sub 1 a) n)))
3961 (let ((index (gensumindex)))
3962 (simpsum1
3963 (mul
3964 (div
3965 (simplify (list '($pochhammer) (sub 1 a) index))
3966 (simplify (list '($pochhammer)
3967 (add 2 (mul -1 a) (mul -1 b))
3968 index)))
3969 (sub
3970 (mul (power (sub 1 z2) b)
3971 (power z2 (add a (mul -1 index) -1)))
3972 (mul (power (sub 1 z1) b)
3973 (power z1 (add a (mul -1 index) -1)))))
3974 index 0 (sub n 1)))))))
3977 (give-up)))))
3979 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3981 ;;; Implementation of the Regularized Incomplete Beta function
3983 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3985 ;;; beta_incomplete_regularized distributes over bags
3987 (defprop %beta_incomplete_regularized (mlist $matrix mequal) distribute_over)
3989 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3991 (defprop %beta_incomplete_regularized
3992 ((a b z)
3993 ;; Derivative wrt a
3994 ((mplus)
3995 ((mtimes) -1
3996 ((%gamma) a)
3997 (($hypergeometric_regularized)
3998 ((mlist) a a ((mplus) 1 ((mtimes) -1 b)))
3999 ((mlist) ((mplus) 1 a) ((mplus) 1 a)) z)
4000 ((mexpt) ((%gamma) b) -1)
4001 ((%gamma) ((mplus) a b))
4002 ((mexpt) z a))
4003 ((mtimes)
4004 ((%beta_incomplete_regularized) a b z)
4005 ((mplus)
4006 ((mtimes) -1 ((mqapply) (($psi array) 0) a))
4007 ((mqapply) (($psi array) 0) ((mplus) a b))
4008 ((%log) z))))
4009 ;; Derivative wrt b
4010 ((mplus)
4011 ((mtimes)
4012 ((%beta_incomplete_regularized) b a ((mplus) 1 ((mtimes) -1 z)))
4013 ((mplus)
4014 ((mqapply) (($psi array) 0) b)
4015 ((mtimes) -1 ((mqapply) (($psi array) 0) ((mplus) a b)))
4016 ((mtimes) -1 ((%log) ((mplus) 1 ((mtimes) -1 z))))))
4017 ((mtimes)
4018 ((mexpt) ((%gamma) a) -1)
4019 ((%gamma) b)
4020 ((%gamma) ((mplus) a b))
4021 (($hypergeometric_regularized)
4022 ((mlist) b b ((mplus) 1 ((mtimes) -1 a)))
4023 ((mlist) ((mplus) 1 b) ((mplus) 1 b))
4024 ((mplus) 1 ((mtimes) -1 z)))
4025 ((mexpt) ((mplus) 1 ((mtimes) -1 z)) b)))
4026 ;; The derivative wrt z
4027 ((mtimes)
4028 ((mexpt) ((%beta) a b) -1)
4029 ((mexpt) ((mplus) 1 ((mtimes) -1 z)) ((mplus) -1 b))
4030 ((mexpt) z ((mplus) -1 a))))
4031 grad)
4033 ;;; Integral of the Generalized Incomplete Beta function
4035 (defprop %beta_incomplete_regularized
4036 ((a b z)
4037 nil
4039 ;; Integral wrt z
4040 ((mplus)
4041 ((mtimes) -1 a
4042 ((%beta_incomplete_regularized) ((mplus) 1 a) b z)
4043 ((mexpt) ((mplus) a b) -1))
4044 ((mtimes) ((%beta_incomplete_regularized) a b z) z)))
4045 integral)
4047 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4049 (def-simplifier beta_incomplete_regularized (a b z)
4050 (let (($simpsum t))
4051 (cond
4053 ;; Check for specific values
4055 ((zerop1 z)
4056 (let ((sgn ($sign ($realpart a))))
4057 (cond ((eq sgn '$neg)
4058 (simp-domain-error
4059 (intl:gettext
4060 "beta_incomplete_regularized: beta_incomplete_regularized(~:M,~:M,~:M) is undefined.")
4061 a b z))
4062 ((member sgn '($pos $pz))
4065 (give-up)))))
4067 ((and (onep1 z)
4068 (or (not (mnump a))
4069 (not (mnump b))
4070 (not (mnump z))))
4071 (let ((sgn ($sign ($realpart b))))
4072 (cond ((member sgn '($pos $pz))
4075 (give-up)))))
4077 ((and (integer-representation-p b)
4078 (if ($bfloatp b) (minusp (cadr b)) (minusp b)) )
4079 ;; Problem: for b a negative integer the Regularized Incomplete
4080 ;; Beta function is defined to be zero. BUT: When we calculate
4081 ;; e.g. beta_incomplete(1.0,-2.0,1/2)/beta(1.0,-2.0) we get the
4082 ;; result -3.0, because beta_incomplete and beta are defined for
4083 ;; for this case. How do we get a consistent behaviour?
4086 ((and (integer-representation-p a)
4087 (if ($bfloatp a) (minusp (cadr a)) (minusp a)) )
4088 (cond
4089 ;; TODO: The following line does not work for bigfloats.
4090 ((and (integer-representation-p b) (<= b (- a)))
4091 ;; Does $beta_incomplete or simpbeta underflow in this case?
4092 (div (ftake '%beta_incomplete a b z)
4093 (ftake* '%beta a b)))
4095 1)))
4097 ;; Check for numerical evaluation in Float or Bigfloat precision
4099 ((complex-float-numerical-eval-p a b z)
4100 (let ((*beta-incomplete-eps* (bigfloat:epsilon ($float 1.0)))
4101 beta ibeta )
4102 (setq a ($float a) b ($float b))
4103 (if (or (< ($abs (setq beta (ftake* '%beta a b))) 1e-307)
4104 (< ($abs (setq ibeta (beta-incomplete a b ($float z)))) 1e-307) )
4105 ;; In case of underflow (see bug #2999) or precision loss use bigfloats
4106 ;; and emporarily give some extra precision but avoid fpprec dependency.
4107 ;; Is this workaround correct for complex values?
4108 (let ((fpprec 70))
4109 ($float (take '(%beta_incomplete_regularized) ($bfloat a) ($bfloat b) z)) )
4110 ($rectform (div ibeta beta)) )))
4112 ((complex-bigfloat-numerical-eval-p a b z)
4113 (let ((*beta-incomplete-eps*
4114 (bigfloat:epsilon (bigfloat:bigfloat 1.0))))
4115 (setq a ($bfloat a) b ($bfloat b))
4116 ($rectform
4117 (div (beta-incomplete a b ($bfloat z))
4118 (ftake* '%beta a b)))))
4120 ;; Check for argument simplifications and transformations
4122 ((and (integerp b) (plusp b))
4123 (div (ftake '%beta_incomplete a b z)
4124 (ftake* '%beta a b)))
4126 ((and (integerp a) (plusp a))
4127 (div (ftake '%beta_incomplete a b z)
4128 (ftake* '%beta a b)))
4130 ((and $beta_expand (mplusp a) (integerp (cadr a)) (plusp (cadr a)))
4131 (let ((n (cadr a))
4132 (a (simplify (cons '(mplus) (cddr a)))))
4133 (sub
4134 (take '(%beta_incomplete_regularized) a b z)
4135 (mul
4136 (power (add a b n -1) -1)
4137 (power (ftake* '%beta (add a n) b) -1)
4138 (let ((index (gensumindex)))
4139 (simpsum1
4140 (mul
4141 (div
4142 (simplify (list '($pochhammer)
4143 (add 1 (mul -1 a) (mul -1 n))
4144 index))
4145 (simplify (list '($pochhammer)
4146 (add 2 (mul -1 a) (mul -1 b) (mul -1 n))
4147 index)))
4148 (power (sub 1 z) b)
4149 (power z (add a n (mul -1 index) -1)))
4150 index 0 (sub n 1)))))))
4152 ((and $beta_expand (mplusp a) (integerp (cadr a)) (minusp (cadr a)))
4153 (let ((n (- (cadr a)))
4154 (a (simplify (cons '(mplus) (cddr a)))))
4155 (sub
4156 (take '(%beta_incomplete_regularized) a b z)
4157 (mul
4158 (power (add a b -1) -1)
4159 (power (ftake* '%beta a b) -1)
4160 (let ((index (gensumindex)))
4161 (simpsum1
4162 (mul
4163 (div
4164 (simplify (list '($pochhammer) (sub 1 a) index))
4165 (simplify (list '($pochhammer)
4166 (add 2 (mul -1 a) (mul -1 b))
4167 index)))
4168 (power (sub 1 z) b)
4169 (power z (add a (mul -1 index) -1)))
4170 index 0 (sub n 1)))))))
4173 (give-up)))))
4175 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;