Improve the translation of notequal
[maxima.git] / src / gamma.lisp
blob745dcdb20b496bdb8fdf61d1cd83b81a3b87e662
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 (declare-top (special $factlim $gamma_expand))
78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80 (defmvar $factorial_expand nil)
81 (defmvar $beta_expand nil)
83 (defmvar $erf_representation nil
84 "When T erfc, erfi and erf_generalized are transformed to erf.")
86 (defmvar $erf_%iargs nil
87 "When T erf and erfi simplifies for an imaginary argument.")
89 (defmvar $hypergeometric_representation nil
90 "When T a transformation to a hypergeometric representation is done.")
92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
93 ;;; The following functions test if numerical evaluation has to be done.
94 ;;; The functions should help to test for numerical evaluation more consitent
95 ;;; and without complicated conditional tests including more than one or two
96 ;;; arguments.
97 ;;;
98 ;;; The functions take a list of arguments. All arguments have to be a CL or
99 ;;; Maxima number. If all arguments are numbers we have two cases:
100 ;;; 1. $numer is T we return T. The function has to be evaluated numerically.
101 ;;; 2. One of the args is a float or a bigfloat. Evaluate numerically.
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104 ;;; Test for numerically evaluation in float precision
106 (defun float-numerical-eval-p (&rest args)
107 (let ((flag nil))
108 (dolist (ll args)
109 (when (not (float-or-rational-p ll))
110 (return-from float-numerical-eval-p nil))
111 (when (floatp ll) (setq flag t)))
112 (if (or $numer flag) t nil)))
114 ;;; Test for numerically evaluation in complex float precision
116 (defun complex-float-numerical-eval-p (&rest args)
117 "Determine if ARGS consists of numerical values by determining if
118 the real and imaginary parts of each arg are nuemrical (but not
119 bigfloats). A non-NIL result is returned if at least one of args is
120 a floating-point value or if numer is true. If the result is
121 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P"
122 (let (flag values)
123 (dolist (ll args)
124 (multiple-value-bind (bool rll ill)
125 (complex-number-p ll 'float-or-rational-p)
126 (unless bool
127 (return-from complex-float-numerical-eval-p nil))
128 ;; Always save the result from complex-number-p. But for backward
129 ;; compatibility, only set the flag if any item is a float.
130 (push (add rll (mul ill '$%i)) values)
131 (setf flag (or flag (or (floatp rll) (floatp ill))))))
132 (when (or $numer flag)
133 ;; Return the values in the same order as the args!
134 (nreverse values))))
136 ;;; Test for numerically evaluation in bigfloat precision
138 (defun bigfloat-numerical-eval-p (&rest args)
139 (let ((flag nil))
140 (dolist (ll args)
141 (when (not (bigfloat-or-number-p ll))
142 (return-from bigfloat-numerical-eval-p nil))
143 (when ($bfloatp ll)
144 (setq flag t)))
145 (if (or $numer flag) t nil)))
147 ;;; Test for numerically evaluation in complex bigfloat precision
149 (defun complex-bigfloat-numerical-eval-p (&rest args)
150 "Determine if ARGS consists of numerical values by determining if
151 the real and imaginary parts of each arg are nuemrical (including
152 bigfloats). A non-NIL result is returned if at least one of args is
153 a floating-point value or if numer is true. If the result is
154 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P."
156 (let (flag values)
157 (dolist (ll args)
158 (multiple-value-bind (bool rll ill)
159 (complex-number-p ll 'bigfloat-or-number-p)
160 (unless bool
161 (return-from complex-bigfloat-numerical-eval-p nil))
162 ;; Always save the result from complex-number-p. But for backward
163 ;; compatibility, only set the flag if any item is a bfloat.
164 (push (add rll (mul ill '$%i)) values)
165 (when (or ($bfloatp rll) ($bfloatp ill))
166 (setf flag t))))
167 (when (or $numer flag)
168 ;; Return the values in the same order as the args!
169 (nreverse values))))
171 ;;; Test for numerical evaluation in any precision, real or complex.
172 (defun numerical-eval-p (&rest args)
173 (or (apply 'float-numerical-eval-p args)
174 (apply 'complex-float-numerical-eval-p args)
175 (apply 'bigfloat-numerical-eval-p args)
176 (apply 'complex-bigfloat-numerical-eval-p args)))
178 ;;; Check for an integer or a float or bigfloat representation. When we
179 ;;; have a float or bigfloat representation return the integer value.
181 (defun integer-representation-p (x)
182 (let ((val nil))
183 (cond ((integerp x) x)
184 ((and (floatp x) (= 0 (nth-value 1 (truncate x))))
185 (nth-value 0 (truncate x)))
186 ((and ($bfloatp x)
187 (eq ($sign (sub (setq val ($truncate x)) x)) '$zero))
188 val)
189 (t nil))))
191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
193 ;;; The changes to the parser to connect the operator !! to double_factorial(z)
195 ;(def-mheader |$!!| (%double_factorial))
197 ;(def-led (|$!!| 160.) (op left)
198 ; (list '$expr
199 ; (mheader '$!!)
200 ; (convert left '$expr)))
202 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
204 ;;; The implementation of the function Double factorial
206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
208 ;;; Double factorial distributes over bags
210 (defprop %double_factorial (mlist $matrix mequal) distribute_over)
212 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
214 ;;; Double factorial has mirror symmetry
216 (defprop %double_factorial t commutes-with-conjugate)
218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
220 ;;; Differentiation of Double factorial
222 (defprop %double_factorial
223 ((z)
224 ((mtimes)
225 ((rat) 1 2)
226 ((%double_factorial) z)
227 ((mplus)
228 ((%log) 2)
229 ((mqapply)
230 (($psi array) 0)
231 ((mplus) 1 ((mtimes) ((rat) 1 2) z)))
232 ((mtimes)
233 ((rat) 1 2) $%pi
234 ((%log) ((mtimes) 2 ((mexpt) $%pi -1)))
235 ((%sin) ((mtimes) $%pi z))))))
236 grad)
238 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
240 ;;; Double factorial is a simplifying function
242 (def-simplifier double_factorial (z)
243 (cond
244 ((and (fixnump z) (> z -1) (or (minusp $factlim) (< z $factlim)))
245 ;; Positive Integer less then $factlim or $factlim is -1. Call gfact.
246 (gfact z (floor (/ z 2)) 2))
248 ((and (mnump z)
249 (eq ($sign z) '$neg)
250 (zerop1 (sub (simplify (list '(%truncate) (div z 2))) (div z 2))))
251 ;; Even negative integer or real representation. Not defined.
252 (simp-domain-error
253 (intl:gettext
254 "double_factorial: double_factorial(~:M) is undefined.") z))
256 ((or (integerp z) ; at this point odd negative integer. Evaluate.
257 (complex-float-numerical-eval-p z))
258 (cond
259 ((and (integerp z) (= z -1)) 1) ; Special cases -1 and -3
260 ((and (integerp z) (= z -3)) -1)
262 ;; Odd negative integer, float or complex float.
263 (complexify
264 (double-factorial
265 (complex ($float ($realpart z)) ($float ($imagpart z))))))))
267 ((and (not (ratnump z))
268 (complex-bigfloat-numerical-eval-p z))
269 ;; bigfloat or complex bigfloat.
270 (bfloat-double-factorial
271 (add ($bfloat ($realpart z)) (mul '$%i ($bfloat ($imagpart z))))))
273 ;; double_factorial(inf) -> inf
274 ((eq z '$inf) '$inf)
276 ((and $factorial_expand
277 (mplusp z)
278 (integerp (cadr z)))
279 (let ((k (cadr z))
280 (n (simplify (cons '(mplus) (cddr z)))))
281 (cond
282 ((= k -1)
283 ;; Special case double_factorial(n-1)
284 ;; Not sure if this simplification is useful.
285 (div (simplify (list '(mfactorial) n))
286 (simplify (list '(%double_factorial) n))))
287 ((= k (* 2 (truncate (/ k 2))))
288 ;; Special case double_factorial(2*k+n), k integer
289 (setq k (/ k 2))
290 ($factor ; we get more simple expression when factoring
291 (mul
292 (power 2 k)
293 (simplify (list '($pochhammer) (add (div n 2) 1) k))
294 (simplify (list '(%double_factorial) n)))))
296 (give-up)))))
299 (give-up))))
301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
302 ;;; Double factorial for a complex float argument. The result is a CL complex.
303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
305 (defun double-factorial (z)
306 (let ((pival (float pi)))
308 (expt
309 (/ 2 pival)
310 (/ (- 1 (cos (* pival z))) 4))
311 (expt 2e0 (/ z 2))
312 (gamma-lanczos (+ 1 (/ z 2))))))
314 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
315 ;;; Double factorial for a bigfloat or complex bigfloat argument
316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
318 (defun bfloat-double-factorial (z)
319 (let* ((pival ($bfloat '$%pi))
320 (bigfloat1 ($bfloat bigfloatone))
321 (bigfloat2 (add bigfloat1 bigfloat1))
322 (bigfloat4 (add bigfloat2 bigfloat2))
323 ($ratprint nil))
324 (cmul
325 (cpower
326 (cdiv bigfloat2 pival)
327 (cdiv (sub bigfloat1
328 (simplify (list '(%cos) (cmul pival z)))) bigfloat4))
329 (cmul
330 (cpower bigfloat2 (cdiv z bigfloat2))
331 (simplify (list '(%gamma) (add bigfloat1 (cdiv z bigfloat2))))))))
333 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
335 ;;; The implementation of the Incomplete Gamma function
337 ;;; A&S 6.5.3:
339 ;;; inf
340 ;;; /
341 ;;; [ a - 1 - t
342 ;;; gamma_incomplete(a, z) = I t %e dt
343 ;;; ]
344 ;;; /
345 ;;; z
347 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
349 (defvar *debug-gamma* nil)
351 ;; TODO: This is currently called by integrate-exp-special in sin.lisp.
352 ;; Need to fix that before this can be removed.
353 (defmfun $gamma_incomplete (a z)
354 (simplify (list '(%gamma_incomplete) a z)))
356 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
359 ;;; Incomplete Gamma distributes over bags
361 (defprop %gamma_incomplete (mlist $matrix mequal) distribute_over)
363 ;;; Incomplete Gamma function has not mirror symmetry for z on the negative
364 ;;; real axis. We support a conjugate-function which test this case.
366 (defprop %gamma_incomplete conjugate-gamma-incomplete conjugate-function)
368 (defun conjugate-gamma-incomplete (args)
369 (let ((a (first args)) (z (second args)))
370 (cond ((off-negative-real-axisp z)
371 ;; Definitely not on the negative real axis for z. Mirror symmetry.
372 (simplify
373 (list
374 '(%gamma_incomplete)
375 (simplify (list '($conjugate) a))
376 (simplify (list '($conjugate) z)))))
378 ;; On the negative real axis or no information. Unsimplified.
379 (list
380 '($conjugate simp)
381 (simplify (list '(%gamma_incomplete) a z)))))))
383 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
385 ;;; Derivative of the Incomplete Gamma function
387 (putprop '%gamma_incomplete
388 `((a z)
389 ,(lambda (a z)
390 (cond ((member ($sign a) '($pos $pz))
391 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2
392 ;; function and the Generalized Incomplete Gamma function
393 ;; (functions.wolfram.com), only for a>0.
394 `((mplus)
395 ((mtimes)
396 ((mexpt) ((%gamma) ,a) 2)
397 ((mexpt) ,z ,a)
398 (($hypergeometric_regularized)
399 ((mlist) ,a ,a)
400 ((mlist) ((mplus) 1 ,a) ((mplus) 1 ,a))
401 ((mtimes) -1 ,z)))
402 ((mtimes) -1
403 ((%gamma_incomplete_generalized) ,a 0 ,z)
404 ((%log) ,z))
405 ((mtimes)
406 ((%gamma) ,a)
407 ((mqapply) (($psi array) 0) ,a))))
409 ;; No derivative. Maxima generates a noun form.
410 nil)))
411 ;; The derivative wrt z
412 ((mtimes) -1
413 ((mexpt) $%e ((mtimes) -1 z))
414 ((mexpt) z ((mplus) -1 a))))
415 'grad)
417 ;;; Integral of the Incomplete Gamma function
419 (defprop %gamma_incomplete
420 ((a z)
422 ((mplus)
423 ((mtimes) -1 ((%gamma_incomplete) ((mplus) 1 a) z))
424 ((mtimes) ((%gamma_incomplete) a z) z)))
425 integral)
427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
429 ;;; We support a simplim%function. The function is looked up in simplimit and
430 ;;; handles specific values of the function.
432 (defprop %gamma_incomplete simplim%gamma_incomplete simplim%function)
434 (defun simplim%gamma_incomplete (expr var val)
435 ;; Look for the limit of the arguments.
436 (let ((a (limit (cadr expr) var val 'think))
437 (z (limit (caddr expr) var val 'think)))
438 (cond
440 ((eq z '$infinity) ;; http://dlmf.nist.gov/8.11#i
441 (cond ((and (zerop1 ($realpart (caddr expr)))
442 (eq ($csign (m+ -1 (cadr expr))) '$neg))
444 (t (throw 'limit t))))
446 ;; Handle an argument 0 at this place.
447 ((or (zerop1 z)
448 (eq z '$zeroa)
449 (eq z '$zerob))
450 (let ((sgn ($sign ($realpart a))))
451 (cond ((zerop1 a) '$inf)
452 ((member sgn '($neg $nz)) '$infinity)
453 ;; Call the simplifier of the function.
454 (t (simplify (list '(%gamma_incomplete) a z))))))
456 ;; All other cases are handled by the simplifier of the function.
457 (simplify (list '(%gamma_incomplete) a z))))))
459 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
461 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
463 ;;; Implementation of the Lower Incomplete gamma function:
465 ;;; A&S 6.5.2
467 ;;; z
468 ;;; /
469 ;;; [ a - 1 - t
470 ;;; gamma_incomplete_lower(a, z) = I t %e dt
471 ;;; ]
472 ;;; /
473 ;;; 0
474 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
475 ;;; distribute over bags (aggregates)
477 (defprop %gamma_incomplete_lower (mlist $matrix mequal) distribute_over)
479 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
481 ;; (defprop %gamma_incomplete_lower ??? grad) WHAT TO PUT HERE ??
484 ;; Handles some special cases for the order a and simplifies it to an
485 ;; equivalent form, possibly involving erf and gamma_incomplete_lower
486 ;; to a lower order.
487 (def-simplifier gamma_incomplete_lower (a z)
488 (cond
489 ((or
490 (float-numerical-eval-p a z)
491 (complex-float-numerical-eval-p a z)
492 (bigfloat-numerical-eval-p a z)
493 (complex-bigfloat-numerical-eval-p a z))
494 (ftake '%gamma_incomplete_generalized a 0 z))
495 ((gamma-incomplete-lower-expand a z))
497 (give-up))))
499 ;; Try to express gamma_incomplete_lower(a,z) in simpler terms for
500 ;; special values of the order a. If we can't, return NIL to say so.
501 (defun gamma-incomplete-lower-expand (a z)
502 (cond ((and $gamma_expand (integerp a) (eql a 1))
503 ;; gamma_incomplete_lower(0, x) = 1-exp(x)
504 (sub 1 (m^t '$%e (neg z))))
505 ((and $gamma_expand (integerp a) (plusp a))
506 ;; gamma_incomplete_lower(a,z) can be simplified if a is a
507 ;; positive integer. Since gamma_incomplete_lower(a,z) =
508 ;; gamma(a) - gamma_incomplete(a,z), use gamma_incomplete to
509 ;; get the result.
510 (sub (simpgamma (list '(%gamma) a) 1 nil)
511 (take '(%gamma_incomplete) a z)))
512 ((and $gamma_expand (alike1 a 1//2))
513 ;; A&S 6.5.12:
515 ;; gamma_incomplete_lower(1/2,x^2) = sqrt(%pi)*erf(x)
517 ;; gamma_incomplete_lower(1/2,z) = sqrt(%pi)*erf(sqrt(x))
519 (mul (power '$%pi '((rat simp) 1 2))
520 (take '(%erf) (power z '((rat simp) 1 2)))))
521 ((and $gamma_expand (mplusp a) (integerp (cadr a)))
522 ;; gamma_incomplete_lower(a+n,z), where n is an integer
523 (let ((n (cadr a))
524 (a (simplify (cons '(mplus) (cddr a)))))
525 (cond
526 ((> n 0)
527 ;; gamma_incomplete_lower(a+n,z). See DLMF 8.8.7:
529 ;; gamma_incomplete_lower(a+n,z)
530 ;; = pochhammer(a,n)*gamma_incomplete_lower(a,z)
531 ;; -z^a*exp(-z)*sum(gamma(a+n)gamma(a+k+1)*z^k,k,0,n-1)
532 (sub
533 (mul
534 (simplify (list '($pochhammer) a n))
535 (simplify (list '(%gamma_incomplete_lower) a z)))
536 (mul
537 (power z a)
538 (power '$%e (mul -1 z))
539 (let ((gamma-a+n (simpgamma (list '(%gamma) (add a n)) 1 nil))
540 (index (gensumindex))
541 ($simpsum t))
542 (simpsum1
543 (mul
544 (div gamma-a+n
545 (simpgamma (list '(%gamma) (add a index 1)) 1 nil))
546 (power z index))
547 index 0 (add n -1))))))
548 ((< n 0)
549 (setq n (- n))
550 ;; See DLMF 8.8.8. For simplicity let g(a,z) = gamma_incomplete_lower(a,z).
552 ;; g(a,z) = gamma(a)/gamma(a-n)*g(a-n,z)
553 ;; - z^(a-1)*exp(z)*sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
555 ;; Rewrite:
556 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
557 ;; + gamma(a-n)/gamma(a)*z^(a-1)*exp(-z)
558 ;; * sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
559 ;; Or
560 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
561 ;; + z^(a-1)*exp(-z)
562 ;; * sum(gamma(a-n)/gamma(a-k)*z^(-k),k,0,n-1)
563 (let ((gamma-a-n (simpgamma (list '(%gamma) (sub a n)) 1 nil))
564 (index (gensumindex))
565 ($simpsum t))
566 (add
567 (mul
568 (div gamma-a-n
569 (list '(%gamma) a))
570 (simplify (list '(%gamma_incomplete_lower) a z)))
571 (mul
572 (power z (sub a 1))
573 (power '$%e (mul -1 z))
574 (simpsum1
575 (mul
576 (div gamma-a-n
577 (simpgamma (list '(%gamma) (sub a index)) 1 nil))
578 (power z (mul -1 index)))
579 index 0 (add n -1)))))))))
580 ((and $gamma_expand (consp a) (eq 'rat (caar a))
581 (integerp (second a))
582 (integerp (third a)))
583 ;; gamma_incomplete_lower of (numeric) rational order.
584 ;; Expand it out so that the resulting order is between 0 and
585 ;; 1.
586 (multiple-value-bind (n order)
587 (floor (/ (second a) (third a)))
588 ;; a = n + order where 0 <= order < 1.
589 (let ((rat-order (rat (numerator order) (denominator order))))
590 (cond
591 ((zerop n)
592 ;; Nothing to do if the order is already between 0 and 1
593 (list '(%gamma_incomplete_lower simp) a z))
595 ;; Use gamma_incomplete(a+n,z) above. and then substitue
596 ;; a=order. This works for n positive or negative.
597 (let* ((ord (gensym))
598 (g (simplify (list '(%gamma_incomplete_lower) (add ord n) z))))
599 ($substitute rat-order ord g)))))))
601 ;; No expansion so return nil to indicate that
602 nil)))
604 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
606 ;;; Incomplete Gamma function is a simplifying function
608 (def-simplifier gamma_incomplete (a z)
609 (let (($simpsum t)
610 (ratorder))
611 (cond
613 ;; Check for specific values
615 ((zerop1 z)
616 ;; gamma_incomplete(v,0) is gamma(v) only if the realpart(v) >
617 ;; 0. If realpart(v) <= 0, gamma_incomplete is undefined. For
618 ;; all other cases, return the noun form.
619 (let ((sgn ($sign ($realpart a))))
620 (cond ((member sgn '($neg $zero))
621 (simp-domain-error
622 (intl:gettext
623 "gamma_incomplete: gamma_incomplete(~:M,~:M) is undefined.")
624 a z))
625 ((member sgn '($pos $pz)) ($gamma a))
626 (t (give-up)))))
628 ((eq z '$inf) 0)
629 ((and (eq z '$minf)
630 (eql a 0))
631 '$infinity)
633 ;; Check for numerical evaluation in Float or Bigfloat precision
635 ((float-numerical-eval-p a z)
636 (when *debug-gamma*
637 (format t "~&SIMP-GAMMA-INCOMPLETE in float-numerical-eval-p~%"))
638 ;; a and z are Maxima numbers, at least one has a float value
639 (let ((a ($float a))
640 (z ($float z)))
641 (cond
642 ((or (= a 0.0)
643 (and (= 0 (- a (truncate a)))
644 (< a 0.0)))
645 ;; a is zero or a negative float representing an integer.
646 ;; For these cases the numerical routines of gamma-incomplete
647 ;; do not work. Call the numerical routine for the Exponential
648 ;; Integral E(n,z). The routine is called with a positive integer!.
649 (setq a (truncate a))
650 (complexify (* (expt z a) (expintegral-e (- 1 a) z))))
652 (complexify (gamma-incomplete a z))))))
654 ((complex-float-numerical-eval-p a z)
655 (when *debug-gamma*
656 (format t
657 "~&SIMP-GAMMA-INCOMPLETE in complex-float-numerical-eval-p~%"))
658 ;; a and z are Maxima numbers, at least one is a complex value and
659 ;; we have at least one float part
660 (let ((ca (complex ($float ($realpart a)) ($float ($imagpart a))))
661 (cz (complex ($float ($realpart z)) ($float ($imagpart z)))))
662 (cond
663 ((and (= (imagpart ca) 0.0)
664 (or (= (realpart ca) 0.0)
665 (and (= 0 (- (realpart ca) (truncate (realpart ca))))
666 (< (realpart ca) 0.0))))
667 ;; Call expintegral-e. See comment above.
668 (setq ca (truncate (realpart ca)))
669 (complexify (* (expt cz ca) (expintegral-e (- 1 ca) cz))))
671 (complexify (gamma-incomplete ca cz))))))
673 ((bigfloat-numerical-eval-p a z)
674 (when *debug-gamma*
675 (format t "~&SIMP-GAMMA-INCOMPLETE in bigfloat-numerical-eval-p~%"))
676 (let ((a ($bfloat a))
677 (z ($bfloat z)))
678 (cond
679 ((or (eq ($sign a) '$zero)
680 (and (eq ($sign (sub a ($truncate a))) '$zero)
681 (eq ($sign a) '$neg)))
682 ;; Call bfloat-expintegral-e. See comment above.
683 (setq a ($truncate a))
684 ($rectform (mul (power z a) (bfloat-expintegral-e (- 1 a) z))))
686 (bfloat-gamma-incomplete a z)))))
688 ((complex-bigfloat-numerical-eval-p a z)
689 (when *debug-gamma*
690 (format t
691 "~&SIMP-GAMMA-INCOMPLETE in complex-bigfloat-numerical-eval-p~%"))
692 (let ((ca (add ($bfloat ($realpart a))
693 (mul '$%i ($bfloat ($imagpart a)))))
694 (cz (add ($bfloat ($realpart z))
695 (mul '$%i ($bfloat ($imagpart z))))))
696 (cond
697 ((and (eq ($sign ($imagpart ca)) '$zero)
698 (or (eq ($sign ($realpart ca)) '$zero)
699 (and (eq ($sign (sub ($realpart ca)
700 ($truncate ($realpart ca))))
701 '$zero)
702 (eq ($sign ($realpart ca)) '$neg))))
703 ;; Call bfloat-expintegral-e. See comment above.
704 (when *debug-gamma*
705 (format t
706 "~& bigfloat-numerical-eval-p calls bfloat-expintegral-e~%"))
707 (setq a ($truncate ($realpart a)))
708 ($rectform (mul (power cz a)
709 (bfloat-expintegral-e (- 1 a) cz))))
711 (complex-bfloat-gamma-incomplete ca cz)))))
713 ;; Check for transformations and argument simplification
715 ((and $gamma_expand (integerp a))
716 ;; Integer or a symbol declared to be an integer. Expand in a series.
717 (let ((sgn ($sign a)))
718 (cond
719 ((eq sgn '$zero)
720 (add
721 (mul -1
722 (simplify (list '(%expintegral_ei) (mul -1 z))))
723 (mul
724 '((rat simp) 1 2)
725 (sub
726 (simplify (list '(%log) (mul -1 z)))
727 (simplify (list '(%log) (div -1 z)))))
728 (mul -1 (simplify (list '(%log) z)))))
729 ((member sgn '($pos $pz))
730 (mul
731 (simplify (list '(%gamma) a))
732 (power '$%e (mul -1 z))
733 (let ((index (gensumindex)))
734 (simpsum1
735 (div
736 (power z index)
737 (let (($gamma_expand nil))
738 ;; Simplify gamma, but do not expand to avoid division
739 ;; by zero.
740 (simplify (list '(%gamma) (add index 1)))))
741 index 0 (sub a 1)))))
742 ((member sgn '($neg $nz))
743 (sub
744 (mul
745 (div
746 (power -1 (add (mul -1 a) -1))
747 (simplify (list '(%gamma) (add (mul -1 a) 1))))
748 (add
749 (simplify (list '(%expintegral_ei) (mul -1 z)))
750 (mul
751 '((rat simp) -1 2)
752 (sub
753 (simplify (list '(%log) (mul -1 z)))
754 (simplify (list '(%log) (div -1 z)))))
755 (simplify (list '(%log) z))))
756 (mul
757 (power '$%e (mul -1 z))
758 (let ((index (gensumindex)))
759 (simpsum1
760 (div
761 (power z (add index a -1))
762 (simplify (list '($pochhammer) a index)))
763 index 1 (mul -1 a))))))
764 (t (give-up)))))
766 ((and $gamma_expand (setq ratorder (max-numeric-ratio-p a 2)))
767 ;; We have a half integral order and $gamma_expand is not NIL.
768 ;; We expand in a series with the Erfc function
769 (setq ratorder (- ratorder (/ 1 2)))
770 (cond
771 ((equal ratorder 0)
772 (mul
773 (power '$%pi '((rat simp) 1 2))
774 (simplify (list '(%erfc) (power z '((rat simp) 1 2))))))
775 ((> ratorder 0)
776 (sub
777 (mul
778 (simplify (list '(%gamma) a))
779 (simplify (list '(%erfc) (power z '((rat simp) 1 2)))))
780 (mul
781 (power -1 (sub ratorder 1))
782 (power '$%e (mul -1 z))
783 (power z '((rat simp) 1 2))
784 (let ((index (gensumindex)))
785 (simpsum1
786 (mul -1 ; we get more simple results
787 (simplify ; when multiplying with -1
788 (list
789 '($pochhammer)
790 (sub '((rat simp) 1 2) ratorder)
791 (sub ratorder (add index 1))))
792 (power (mul -1 z) index))
793 index 0 (sub ratorder 1))))))
794 ((< ratorder 0)
795 (setq ratorder (- ratorder))
796 (sub
797 (div
798 (mul
799 (power -1 ratorder)
800 (power '$%pi '((rat simp) 1 2))
801 (simplify (list '(%erfc) (power z '((rat simp) 1 2)))))
802 (simplify (list '($pochhammer) '((rat simp) 1 2) ratorder)))
803 (mul
804 (power z (sub '((rat simp) 1 2) ratorder))
805 (power '$%e (mul -1 z))
806 (let ((index (gensumindex)))
807 (simpsum1
808 (div
809 (power z index)
810 (simplify
811 (list
812 '($pochhammer)
813 (sub '((rat simp) 1 2) ratorder)
814 (add index 1))))
815 index 0 (sub ratorder 1))))))))
817 ((and $gamma_expand (mplusp a) (integerp (cadr a)))
818 ;; Handle gamma_incomplete(a+n, z), where n is a numerical integer
819 (let ((n (cadr a))
820 (a (simplify (cons '(mplus) (cddr a)))))
821 (cond
822 ((> n 0)
823 ;; See DLMF 8.8.9: https://dlmf.nist.gov/8.8.E9
825 ;; gamma_incomplete(a+n,z) = pochhammer(a,n)*gamma_incomplete(a,z)
826 ;; + z^a*exp(-z)*sum(gamma(a+n)/gamma(a+k+1)*z^k,k,0,n-1)
827 (add
828 (mul
829 (simplify (list '($pochhammer) a n))
830 (simplify (list '(%gamma_incomplete) a z)))
831 (mul
832 (power '$%e (mul -1 z))
833 (power z a)
834 (let ((gamma-a+n (simpgamma (list '(%gamma) (add a n)) 1 nil))
835 (index (gensumindex)))
836 (simpsum1
837 (mul
838 (div gamma-a+n
839 (simpgamma (list '(%gamma) (add a index 1)) 1 nil))
840 (power z index))
841 index 0 (add n -1))))))
842 ((< n 0)
843 (setq n (- n))
844 ;; See http://functions.wolfram.com/06.06.17.0004.01
846 ;; gamma_incomplate(a,z) =
847 ;; (-1)^n*pochhammer(1-a,n)
848 ;; *[gamma_incomplete(a-n,z)
849 ;; + z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)]
851 ;; Rerarrange this in terms of gamma_incomplete(a-n,z):
853 ;; gamma_incomplete(a-n,z) =
854 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
855 ;; -z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)
857 ;; Change the summation index to go from k = 0 to n-1:
859 ;; z^(a-n-1)*sum(z^k/pochhammer(a-n,k),k,1,n)
860 ;; = z^(a-n-1)*sum(z^(k+1)/pochhammer(a-n,k+1),k,0,n-1)
861 ;; = z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
863 ;; Thuus:
864 ;; gamma_incomplete(a-n,z) =
865 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
866 ;; -z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
867 (sub
868 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
869 (div
870 (mul
871 (power -1 n)
872 (simplify (list '(%gamma_incomplete) a z)))
873 (simplify (list '($pochhammer) (sub 1 a) n)))
874 (mul
875 (power '$%e (mul -1 z))
876 (power z (sub a n))
877 ;; sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
878 (let ((index (gensumindex)))
879 (simpsum1
880 (div
881 (power z index)
882 (simplify (list '($pochhammer) (sub a n) (add index 1))))
883 index 0 (sub n 1)))))))))
884 ((and $gamma_expand (consp a) (eq 'rat (caar a))
885 (integerp (second a))
886 (integerp (third a)))
887 ;; gamma_incomplete of (numeric) rational order. Expand it out
888 ;; so that the resulting order is between 0 and 1.
889 (multiple-value-bind (n order)
890 (floor (/ (second a) (third a)))
891 ;; a = n + order where 0 <= order < 1.
892 (let ((rat-order (rat (numerator order) (denominator order))))
893 (cond
894 ((zerop n)
895 ;; Nothing to do if the order is already between 0 and 1
896 (give-up))
898 ;; Use gamma_incomplete(a+n,z) above. and then substitue
899 ;; a=order. This works for n positive or negative.
900 (let* ((ord (gensym))
901 (g (simplify (list '(%gamma_incomplete) (add ord n) z))))
902 ($substitute rat-order ord g)))))))
904 (t (give-up)))))
906 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
907 ;;; Numerical evaluation of the Incomplete Gamma function
909 ;;; gamma-incomplete (a,z) - real and complex double float
910 ;;; bfloat-gamma-incomplete (a z) - bigfloat
911 ;;; complex-bfloat-gamma-incomplete (a z) - complex bigfloat
913 ;;; Expansion in a power series for abs(x) < R, where R is
914 ;;; *gamma-radius* + real(a) if real(a) > 0 or *gamma-radius*
915 ;;; otherwise.
917 ;;; (A&S 6.5.29):
919 ;;; inf
920 ;;; ===
921 ;;; \ gamma(a)
922 ;;; gamma(a,z) = exp(-x)*z^a * > ------------ * z^n
923 ;;; / gamma(a+1+n)
924 ;;; ===
925 ;;; n=0
927 ;;; This expansion does not work for an integer a<=0, because the Gamma function
928 ;;; in the denominator is not defined for a=0 and negative integers. For this
929 ;;; case we use the Exponential Integral E for numerically evaluation. The
930 ;;; Incomplete Gamma function and the Exponential integral are connected by
932 ;;; gamma(a,z) = z^a * expintegral_e(1-a,z)
934 ;;; When the series is not used, two forms of the continued fraction
935 ;;; are used. When z is not near the negative real axis use the
936 ;;; continued fractions (A&S 6.5.31):
938 ;;; 1 1-a 1 2-a 2
939 ;;; gamma(a,z) = exp(-z) z^a *( -- --- --- --- --- ... )
940 ;;; z+ 1+ z+ 1+ z+
942 ;;; The accuracy is controlled by *gamma-incomplete-eps* for double float
943 ;;; precision. For bigfloat precision epsilon is 10^(-$fpprec). The expansions
944 ;;; in a power series or continued fractions stops if *gamma-incomplete-maxit*
945 ;;; is exceeded and an Maxima error is thrown.
947 ;;; The above fraction does not converge on the negative real axis and
948 ;;; converges very slowly near the axis. In this case, use the
949 ;;; relationship
951 ;;; gamma(a,z) = gamma(a) - gamma_lower(a,z)
953 ;;; The continued fraction for gamma_incomplete_lower(a,z) is
954 ;;; (http://functions.wolfram.com/06.06.10.0009.01):
956 ;;; gamma_lower(a,z) = exp(-z) * z^a / cf(a,z)
958 ;;; where
960 ;;; -a*z z (a+1)*z 2*z (a+2)*z
961 ;;; cf(a,z) = a + ---- ---- ------- ---- -------
962 ;;; a+1+ a+2- a+3+ a+4- a+5+
964 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
966 (defvar *gamma-incomplete-maxit* 10000)
967 (defvar *gamma-incomplete-eps* (* 2 flonum-epsilon))
968 (defvar *gamma-incomplete-min* 1.0e-32)
970 (defvar *gamma-radius* 1.0
971 "Controls the radius within a series expansion is done.")
972 (defvar *gamma-imag* 1.0)
974 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
976 ;;; The numerical evaluation for CL float or complex values a and x
977 ;;; When the flag regularized is T, the result is divided by gamma(a) and
978 ;;; Maxima returns the numercial result for gamma_incomplete_regularized
980 (defun gamma-incomplete (a x &optional (regularized nil))
981 (setq x (+ x (cond ((complexp x) #C(0.0 0.0)) ((realp x) 0.0))))
983 (let ((factor
984 ;; Compute the factor needed to scale the series or continued
985 ;; fraction. This is x^a*exp(-x) or x^a*exp(-x)/gamma(a)
986 ;; depending on whether we want a non-regularized or
987 ;; regularized form. We want to compute the factor carefully
988 ;; to avoid unnecessary overflow if possible.
989 (cond (regularized
990 (or (try-float-computation
991 #'(lambda ()
992 ;; gammafloat is more accurate for real
993 ;; values of a.
994 (cond ((complexp a)
995 (/ (* (expt x a) (exp (- x)))
996 (gamma-lanczos a)))
998 (/ (* (expt x a) (exp (- x)))
999 (gammafloat a))))))
1000 ;; Easy way failed. Use logs to compute the
1001 ;; result. This loses some precision, especially
1002 ;; for large values of a and/or x because we use
1003 ;; many bits to hold the exponent part.
1004 (exp (- (* a (log x))
1006 (log-gamma-lanczos (if (complexp a)
1008 (complex a)))))))
1010 (or (try-float-computation
1011 #'(lambda ()
1012 (* (expt x a) (exp (- x)))))
1013 ;; Easy way failed, so use the log form.
1014 (exp (- (* a (log x))
1015 x)))))))
1016 (multiple-value-bind (result lower-incomplete-tail-p)
1017 (%gamma-incomplete a x)
1018 (cond (lower-incomplete-tail-p
1019 ;; %gamma-incomplete compute the lower incomplete gamma
1020 ;; function, so we need to subtract that from gamma(a),
1021 ;; more or less.
1022 (cond (regularized
1023 (- 1 (* result factor)))
1024 ((complexp a)
1025 (- (gamma-lanczos a) (* result factor)))
1027 (- (gammafloat a) (* result factor)))))
1029 ;; Continued fraction used. Just multiply by the factor
1030 ;; to get the final result.
1031 (* factor result))))))
1033 ;; Compute the key part of the gamma incomplete function using either
1034 ;; a series expression or a continued fraction expression. Two values
1035 ;; are returned: the value itself and a boolean, indicating what the
1036 ;; computed value is. If the boolean non-NIL, then the computed value
1037 ;; is the lower incomplete gamma function.
1038 (defun %gamma-incomplete (a x)
1039 (let ((gm-maxit *gamma-incomplete-maxit*)
1040 (gm-eps *gamma-incomplete-eps*)
1041 (gm-min *gamma-incomplete-min*))
1042 (when *debug-gamma*
1043 (format t "~&GAMMA-INCOMPLETE with ~A and ~A~%" a x))
1044 (cond
1045 ;; The series expansion is done for x within a circle of radius
1046 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1047 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1048 ;; continued fraction is used.
1049 ((and (> (abs x) (+ *gamma-radius*
1050 (if (> (realpart a) 0.0) (realpart a) 0.0))))
1051 (cond ((and (< (realpart x) 0)
1052 (< (abs (imagpart x))
1053 (* *gamma-imag* (abs (realpart x)))))
1054 ;; For x near the negative real axis, use the
1055 ;; relationship gamma_incomplete(a,z) = gamma(a) -
1056 ;; gamma_incomplete_lower(a,z), where
1057 ;; gamma_incomplete_lower(a,z) is the lower poart of the
1058 ;; incomplete gamma function. We can evaluate that
1059 ;; using a continued fraction from
1060 ;; http://functions.wolfram.com/06.06.10.0009.01. (Note
1061 ;; that the alternative fraction,
1062 ;; http://functions.wolfram.com/06.06.10.0007.01,
1063 ;; appears to be less accurate.)
1065 ;; Also note that this appears to be valid for all
1066 ;; values of x (real or complex), but we don't want to
1067 ;; use this everywhere for gamma_incomplete. Consider
1068 ;; what happens for large real x. gamma_incomplete(a,x)
1069 ;; is small, but gamma_incomplete(a,x) = gamma(x) - cf
1070 ;; will have large roundoff errors.
1071 (when *debug-gamma*
1072 (format t "~&GAMMA-INCOMPLETE in continued fractions for lower integral~%"))
1073 (let ((a (bigfloat:to a))
1074 (x (bigfloat:to x))
1075 (bigfloat::*debug-cf-eval* *debug-gamma*)
1076 (bigfloat::*max-cf-iterations* *gamma-incomplete-maxit*))
1077 (values (/ (bigfloat::lentz #'(lambda (n)
1078 (+ n a))
1079 #'(lambda (n)
1080 (if (evenp n)
1081 (* (ash n -1) x)
1082 (- (* (+ a (ash n -1)) x))))))
1083 t)))
1085 ;; Expansion in continued fractions for gamma_incomplete.
1086 (when *debug-gamma*
1087 (format t "~&GAMMA-INCOMPLETE in continued fractions~%"))
1088 (do* ((i 1 (+ i 1))
1089 (an (- a 1.0) (* i (- a i)))
1090 (b (+ 3.0 x (- a)) (+ b 2.0))
1091 (c (/ 1.0 gm-min))
1092 (d (/ 1.0 (- b 2.0)))
1093 (h d)
1094 (del 0.0))
1095 ((> i gm-maxit)
1096 (merror (intl:gettext "gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x))
1097 (setq d (+ (* an d) b))
1098 (when (< (abs d) gm-min) (setq d gm-min))
1099 (setq c (+ b (/ an c)))
1100 (when (< (abs c) gm-min) (setq c gm-min))
1101 (setq d (/ 1.0 d))
1102 (setq del (* d c))
1103 (setq h (* h del))
1104 (when (< (abs (- del 1.0)) gm-eps)
1105 ;; Return nil to indicate we used the continued fraction.
1106 (return (values h nil)))))))
1108 ;; Expansion in a series
1109 (when *debug-gamma*
1110 (format t "~&GAMMA-INCOMPLETE in series~%"))
1111 (do* ((i 1 (+ i 1))
1112 (ap a (+ ap 1.0))
1113 (del (/ 1.0 a) (* del (/ x ap)))
1114 (sum del (+ sum del)))
1115 ((> i gm-maxit)
1116 (merror (intl:gettext "gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x))
1117 (when (< (abs del) (* (abs sum) gm-eps))
1118 (when *debug-gamma* (format t "~&Series converged.~%"))
1119 ;; Return T to indicate we used the series and the series
1120 ;; is for the integral from 0 to x, not x to inf.
1121 (return (values sum t))))))))
1123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1125 ;;; This function is called for a and x real
1127 (defun bfloat-gamma-incomplete (a x)
1128 (let* ((gm-maxit *gamma-incomplete-maxit*)
1129 (gm-eps (power ($bfloat 10.0) (- $fpprec)))
1130 (gm-min (mul gm-eps gm-eps))
1131 ($ratprint nil))
1132 (cond
1133 ;; The series expansion is done for x within a circle of radius
1134 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1135 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1136 ;; continued fraction is used.
1137 ((eq ($sign (sub (simplify (list '(mabs) x))
1138 (add *gamma-radius*
1139 (if (eq ($sign a) '$pos) a 0.0))))
1140 '$pos)
1141 (cond
1142 ((and (eq ($sign x) '$pos))
1143 ;; Expansion in continued fractions of the Incomplete Gamma function
1144 (do* ((i 1 (+ i 1))
1145 (an (sub a 1.0) (mul i (sub a i)))
1146 (b (add 3.0 x (mul -1 a)) (add b 2.0))
1147 (c (div 1.0 gm-min))
1148 (d (div 1.0 (sub b 2.0)))
1149 (h d)
1150 (del 0.0))
1151 ((> i gm-maxit)
1152 (merror (intl:gettext "gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x))
1153 (when *debug-gamma*
1154 (format t "~&in continued fractions:~%")
1155 (mformat t "~& : i = ~M~%" i)
1156 (mformat t "~& : h = ~M~%" h))
1157 (setq d (add (mul an d) b))
1158 (when (eq ($sign (sub (simplify (list '(mabs) d)) gm-min)) '$neg)
1159 (setq d gm-min))
1160 (setq c (add b (div an c)))
1161 (when (eq ($sign (sub (simplify (list '(mabs) c)) gm-min)) '$neg)
1162 (setq c gm-min))
1163 (setq d (div 1.0 d))
1164 (setq del (mul d c))
1165 (setq h (mul h del))
1166 (when (eq ($sign (sub (simplify (list '(mabs) (sub del 1.0))) gm-eps))
1167 '$neg)
1168 (return
1169 (mul h
1170 (power x a)
1171 (power ($bfloat '$%e) (mul -1 x)))))))
1173 ;; Expand to multiply everything out.
1174 ($expand
1175 ;; Expansion in continued fraction for the lower incomplete gamma.
1176 (sub (simplify (list '(%gamma) a))
1177 ;; NOTE: We want (power x a) instead of bigfloat:expt
1178 ;; because this preserves how maxima computes x^a when
1179 ;; x is negative and a is rational. For, example
1180 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1181 ;; principal value.
1182 (mul (power x a)
1183 (power ($bfloat '$%e) (mul -1 x))
1184 (let ((a (bigfloat:to a))
1185 (x (bigfloat:to x)))
1186 (to (bigfloat:/
1187 (bigfloat:lentz
1188 #'(lambda (n)
1189 (bigfloat:+ n a))
1190 #'(lambda (n)
1191 (if (evenp n)
1192 (bigfloat:* (ash n -1) x)
1193 (bigfloat:- (bigfloat:* (bigfloat:+ a (ash n -1))
1194 x))))))))))))))
1197 ;; Series expansion of the Incomplete Gamma function
1198 (do* ((i 1 (+ i 1))
1199 (ap a (add ap 1.0))
1200 (del (div 1.0 a) (mul del (div x ap)))
1201 (sum del (add sum del)))
1202 ((> i gm-maxit)
1203 (merror (intl:gettext "gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x))
1204 (when *debug-gamma*
1205 (format t "~&GAMMA-INCOMPLETE in series:~%")
1206 (mformat t "~& : i = ~M~%" i)
1207 (mformat t "~& : ap = ~M~%" ap)
1208 (mformat t "~& : x/ap = ~M~%" (div x ap))
1209 (mformat t "~& : del = ~M~%" del)
1210 (mformat t "~& : sum = ~M~%" sum))
1211 (when (eq ($sign (sub (simplify (list '(mabs) del))
1212 (mul (simplify (list '(mabs) sum)) gm-eps)))
1213 '$neg)
1214 (when *debug-gamma* (mformat t "~&Series converged to ~M.~%" sum))
1215 (return
1216 (sub (simplify (list '(%gamma) a))
1217 ($rectform
1218 (mul sum
1219 (power x a)
1220 (power ($bfloat '$%e) (mul -1 x))))))))))))
1222 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1224 (defun complex-bfloat-gamma-incomplete (a x)
1225 (let* ((gm-maxit *gamma-incomplete-maxit*)
1226 (gm-eps (power ($bfloat 10.0) (- $fpprec)))
1227 (gm-min (mul gm-eps gm-eps))
1228 ($ratprint nil))
1229 (when *debug-gamma*
1230 (format t "~&COMPLEX-BFLOAT-GAMMA-INCOMPLETE~%")
1231 (format t " : a = ~A~%" a)
1232 (format t " : x = ~A~%" x))
1233 (cond
1234 ;; The series expansion is done for x within a circle of radius
1235 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1236 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1237 ;; continued fraction is used.
1238 ((and (eq ($sign (sub (simplify (list '(mabs) x))
1239 (add *gamma-radius*
1240 (if (eq ($sign ($realpart a)) '$pos)
1241 ($realpart a)
1242 0.0))))
1243 '$pos))
1244 (cond
1245 ((not (and (eq ($sign ($realpart x)) '$neg)
1246 (eq ($sign (sub (simplify (list '(mabs) ($imagpart x)))
1247 (simplify (list '(mabs) ($realpart x)))))
1248 '$neg)))
1249 ;; Expansion in continued fractions of the Incomplete Gamma function
1250 (when *debug-gamma*
1251 (format t "~&in continued fractions:~%"))
1252 (do* ((i 1 (+ i 1))
1253 (an (sub a 1.0) (mul i (sub a i)))
1254 (b (add 3.0 x (mul -1 a)) (add b 2.0))
1255 (c (cdiv 1.0 gm-min))
1256 (d (cdiv 1.0 (sub b 2.0)))
1257 (h d)
1258 (del 0.0))
1259 ((> i gm-maxit)
1260 (merror (intl:gettext "gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x))
1261 (setq d (add (cmul an d) b))
1262 (when (eq ($sign (sub (simplify (list '(mabs) d)) gm-min)) '$neg)
1263 (setq d gm-min))
1264 (setq c (add b (cdiv an c)))
1265 (when (eq ($sign (sub (simplify (list '(mabs) c)) gm-min)) '$neg)
1266 (setq c gm-min))
1267 (setq d (cdiv 1.0 d))
1268 (setq del (cmul d c))
1269 (setq h (cmul h del))
1270 (when (eq ($sign (sub (simplify (list '(mabs) (sub del 1.0)))
1271 gm-eps))
1272 '$neg)
1273 (return
1274 ($bfloat ; force evaluation of expressions with sin or cos
1275 (cmul h
1276 (cmul
1277 (cpower x a)
1278 (cpower ($bfloat '$%e) ($bfloat (mul -1 x))))))))))
1280 ;; Expand to multiply everything out.
1281 ($expand
1282 ;; Expansion in continued fraction for the lower incomplete gamma.
1283 (sub ($rectform (simplify (list '(%gamma) a)))
1284 ;; NOTE: We want (power x a) instead of bigfloat:expt
1285 ;; because this preserves how maxima computes x^a when
1286 ;; x is negative and a is rational. For, example
1287 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1288 ;; principal value.
1289 (mul ($rectform (power x a))
1290 ($rectform (power ($bfloat '$%e) (mul -1 x)))
1291 (let ((a (bigfloat:to a))
1292 (x (bigfloat:to x)))
1293 (to (bigfloat:/
1294 (bigfloat:lentz
1295 #'(lambda (n)
1296 (bigfloat:+ n a))
1297 #'(lambda (n)
1298 (if (evenp n)
1299 (bigfloat:* (ash n -1) x)
1300 (bigfloat:- (bigfloat:* (bigfloat:+ a (ash n -1))
1301 x))))))))))))))
1303 ;; Series expansion of the Incomplete Gamma function
1304 (when *debug-gamma*
1305 (format t "~&GAMMA-INCOMPLETE in series:~%"))
1306 (do* ((i 1 (+ i 1))
1307 (ap a (add ap 1.0))
1308 (del (cdiv 1.0 a) (cmul del (cdiv x ap)))
1309 (sum del (add sum del)))
1310 ((> i gm-maxit)
1311 (merror (intl:gettext "gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x))
1312 (when (eq ($sign (sub (simplify (list '(mabs) del))
1313 (mul (simplify (list '(mabs) sum)) gm-eps)))
1314 '$neg)
1315 (when *debug-gamma* (format t "~&Series converged.~%"))
1316 (return
1317 ($bfloat ; force evaluation of expressions with sin or cos
1318 (sub (simplify (list '(%gamma) a))
1319 (cmul sum
1320 (cmul
1321 (cpower x a)
1322 (cpower ($bfloat '$%e) (mul -1 x)))))))))))))
1324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1326 ;;; Implementation of the Generalized Incomplete Gamma function
1328 ;;; z2
1329 ;;; /
1330 ;;; [ a - 1 - t
1331 ;;; gamma_incomplete_generalized(a, z1, z2) = I t %e dt
1332 ;;; ]
1333 ;;; /
1334 ;;; z1
1336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1338 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1339 ;;; on the negative real axis.
1340 ;;; We support a conjugate-function which test this case.
1342 (defprop %gamma_incomplete_generalized
1343 conjugate-gamma-incomplete-generalized conjugate-function)
1345 (defun conjugate-gamma-incomplete-generalized (args)
1346 (let ((a (first args)) (z1 (second args)) (z2 (third args)))
1347 (cond ((and (off-negative-real-axisp z1) (off-negative-real-axisp z2))
1348 ;; z1 and z2 definitely not on the negative real axis.
1349 ;; Mirror symmetry.
1350 (simplify
1351 (list
1352 '(%gamma_incomplete_generalized)
1353 (simplify (list '($conjugate) a))
1354 (simplify (list '($conjugate) z1))
1355 (simplify (list '($conjugate) z2)))))
1357 ;; On the negative real axis or no information. Unsimplified.
1358 (list
1359 '($conjugate simp)
1360 (simplify (list '(%gamma_incomplete_generalized) a z1 z2)))))))
1362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1364 ;;; Generalized Incomplete Gamma distributes over bags
1366 (defprop %gamma_incomplete_generalized (mlist $matrix mequal) distribute_over)
1368 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1370 ;;; Differentiation of Generalized Incomplete Gamma function
1372 (defprop %gamma_incomplete_generalized
1373 ((a z1 z2)
1374 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1375 ;; and the Generalized Incomplete Gamma function (functions.wolfram.com)
1376 ((mplus)
1377 ((mtimes)
1378 ((mexpt) ((%gamma) a) 2)
1379 ((mexpt) z1 a)
1380 (($hypergeometric_regularized)
1381 ((mlist) a a)
1382 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
1383 ((mtimes) -1 z1)))
1384 ((mtimes) -1
1385 ((mexpt) ((%gamma) a) 2)
1386 ((mexpt) z2 a)
1387 (($hypergeometric_regularized)
1388 ((mlist) a a)
1389 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
1390 ((mtimes) -1 z2)))
1391 ((mtimes) -1
1392 ((%gamma_incomplete_generalized) a 0 z1)
1393 ((%log) z1))
1394 ((mtimes)
1395 ((%gamma_incomplete_generalized) a 0 z2)
1396 ((%log) z2)))
1397 ;; The derivative wrt z1
1398 ((mtimes) -1
1399 ((mexpt) $%e ((mtimes) -1 z1))
1400 ((mexpt) z1 ((mplus) -1 a)))
1401 ;; The derivative wrt z2
1402 ((mtimes)
1403 ((mexpt) $%e ((mtimes) -1 z2))
1404 ((mexpt) z2 ((mplus) -1 a))))
1405 grad)
1407 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1409 ;;; Generalized Incomplete Gamma function is a simplifying function
1411 (def-simplifier gamma_incomplete_generalized (a z1 z2)
1412 (let (($simpsum t))
1413 (cond
1415 ;; Check for specific values
1417 ((zerop1 z2)
1418 (let ((sgn ($sign ($realpart a))))
1419 (cond
1420 ((member sgn '($pos $pz))
1421 (sub
1422 (simplify (list '(%gamma_incomplete) a z1))
1423 (simplify (list '(%gamma) a))))
1425 (give-up)))))
1427 ((zerop1 z1)
1428 (let ((sgn ($sign ($realpart a))))
1429 (cond
1430 ((member sgn '($pos $pz))
1431 (sub
1432 (simplify (list '(%gamma) a))
1433 (simplify (list '(%gamma_incomplete) a z2))))
1435 (give-up)))))
1437 ((zerop1 (sub z1 z2)) 0)
1439 ((eq z2 '$inf) (simplify (list '(%gamma_incomplete) a z1)))
1440 ((eq z1 '$inf) (mul -1 (simplify (list '(%gamma_incomplete) a z2))))
1442 ;; Check for numerical evaluation in Float or Bigfloat precision
1443 ;; Use the numerical routines of the Incomplete Gamma function
1445 ((float-numerical-eval-p a z1 z2)
1446 (complexify
1447 (- (gamma-incomplete ($float a) ($float z1))
1448 (gamma-incomplete ($float a) ($float z2)))))
1450 ((complex-float-numerical-eval-p a z1 z2)
1451 (let ((ca (complex ($float ($realpart a)) ($float ($imagpart a))))
1452 (cz1 (complex ($float ($realpart z1)) ($float ($imagpart z1))))
1453 (cz2 (complex ($float ($realpart z2)) ($float ($imagpart z2)))))
1454 (complexify (- (gamma-incomplete ca cz1) (gamma-incomplete ca cz2)))))
1456 ((bigfloat-numerical-eval-p a z1 z2)
1457 (sub (bfloat-gamma-incomplete ($bfloat a) ($bfloat z1))
1458 (bfloat-gamma-incomplete ($bfloat a) ($bfloat z2))))
1460 ((complex-bigfloat-numerical-eval-p a z1 z2)
1461 (let ((ca (add ($bfloat ($realpart a))
1462 (mul '$%i ($bfloat ($imagpart a)))))
1463 (cz1 (add ($bfloat ($realpart z1))
1464 (mul '$%i ($bfloat ($imagpart z1)))))
1465 (cz2 (add ($bfloat ($realpart z2))
1466 (mul '$%i ($bfloat ($imagpart z2))))))
1467 (sub (complex-bfloat-gamma-incomplete ca cz1)
1468 (complex-bfloat-gamma-incomplete ca cz2))))
1470 ;; Check for transformations and argument simplification
1472 ((and $gamma_expand (mplusp a) (integerp (cadr a)))
1473 ;; Expand gamma_incomplete_generalized(a+n,z1,z2) with n an integer
1474 (let ((n (cadr a))
1475 (a (simplify (cons '(mplus) (cddr a)))))
1476 (cond
1477 ((> n 0)
1478 (mul
1479 (simplify (list '($pochhammer) a n))
1480 (add
1481 (simplify (list '(%gamma_incomplete_generalized) a z1 z2))
1482 (mul
1483 (power '$%e (mul -1 z1))
1484 (let ((index (gensumindex)))
1485 (simpsum1
1486 (div
1487 (power z1 (add a index -1))
1488 (simplify (list '($pochhammer) a index)))
1489 index 1 n)))
1490 (mul -1
1491 (power '$%e (mul -1 z2))
1492 (let ((index (gensumindex)))
1493 (simpsum1
1494 (div
1495 (power z2 (add a index -1))
1496 (simplify (list '($pochhammer) a index)))
1497 index 1 n))))))
1499 ((< n 0)
1500 (setq n (- n))
1501 (add
1502 (mul
1503 (div
1504 (power -1 n)
1505 ($factor (simplify (list '($pochhammer) (sub 1 a) n))))
1506 (simplify (list '(%gamma_incomplete_generalized) a z1 z2)))
1507 (mul -1
1508 (power '$%e (mul -1 z2))
1509 (let ((index (gensumindex)))
1510 (simpsum1
1511 (div
1512 (power z1 (add a index (- n) -1))
1513 (simplify (list '($pochhammer) (sub a n) index)))
1514 index 1 n)))
1515 (mul
1516 (power '$%e (mul -1 z2))
1517 (let ((index (gensumindex)))
1518 (simpsum1
1519 (div
1520 (power z2 (add a index (- n) -1))
1521 (simplify (list '($pochhammer) (sub a n) index)))
1522 index 1 n))))))))
1524 (t (give-up)))))
1526 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1528 ;;; Implementation of the Regularized Incomplete Gamma function
1530 ;;; A&S 6.5.1
1532 ;;; gamma_incomplete(a, z)
1533 ;;; gamma_incomplete_regularized(a, z) = ----------------------
1534 ;;; gamma(a)
1535 ;;;
1536 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1538 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1540 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1541 ;;; on the negative real axis.
1542 ;;; We support a conjugate-function which test this case.
1544 (defprop %gamma_incomplete_regularized
1545 conjugate-gamma-incomplete-regularized conjugate-function)
1547 (defun conjugate-gamma-incomplete-regularized (args)
1548 (let ((a (first args)) (z (second args)))
1549 (cond ((off-negative-real-axisp z)
1550 ;; z definitely not on the negative real axis. Mirror symmetry.
1551 (simplify
1552 (list
1553 '(%gamma_incomplete_regularized)
1554 (simplify (list '($conjugate) a))
1555 (simplify (list '($conjugate) z)))))
1557 ;; On the negative real axis or no information. Unsimplified.
1558 (list
1559 '($conjugate simp)
1560 (simplify (list '(%gamma_incomplete_regularized) a z)))))))
1562 ;;; Regularized Incomplete Gamma distributes over bags
1564 (defprop %gamma_incomplete_regularized (mlist $matrix mequal) distribute_over)
1566 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1568 ;;; Differentiation of Regularized Incomplete Gamma function
1570 (defprop %gamma_incomplete_regularized
1571 ((a z)
1572 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1573 ;; and the Regularized Generalized Incomplete Gamma function
1574 ;; (functions.wolfram.com)
1575 ((mplus)
1576 ((mtimes)
1577 ((%gamma) a)
1578 ((mexpt) z a)
1579 (($hypergeometric_regularized)
1580 ((mlist) a a)
1581 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
1582 ((mtimes) -1 z)))
1583 ((mtimes)
1584 ((%gamma_incomplete_generalized_regularized) a z 0)
1585 ((mplus)
1586 ((%log) z)
1587 ((mtimes) -1 ((mqapply) (($psi array) 0) a)))))
1588 ;; The derivative wrt z
1589 ((mtimes)
1591 ((mexpt) $%e ((mtimes) -1 z))
1592 ((mexpt) z ((mplus) -1 a))
1593 ((mexpt) ((%gamma) a) -1)))
1594 grad)
1596 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1598 ;;; Regularized Incomplete Gamma function is a simplifying function
1600 (def-simplifier gamma_incomplete_regularized (a z)
1601 (let (($simpsum t)
1602 (ratorder 0))
1604 (cond
1606 ;; Check for specific values
1608 ((zerop1 z)
1609 (let ((sgn ($sign ($realpart a))))
1610 (cond ((member sgn '($neg $zero))
1611 (simp-domain-error
1612 (intl:gettext
1613 "gamma_incomplete_regularized: gamma_incomplete_regularized(~:M,~:M) is undefined.")
1614 a z))
1615 ((member sgn '($pos $pz)) 1)
1616 (t (give-up)))))
1618 ((zerop1 a) 0)
1619 ((eq z '$inf) 0)
1621 ;; Check for numerical evaluation in Float or Bigfloat precision
1623 ((float-numerical-eval-p a z)
1624 (complexify
1625 ;; gamma_incomplete returns a regularized result
1626 (gamma-incomplete ($float a) ($float z) t)))
1628 ((complex-float-numerical-eval-p a z)
1629 (let ((ca (complex ($float ($realpart a)) ($float ($imagpart a))))
1630 (cz (complex ($float ($realpart z)) ($float ($imagpart z)))))
1631 ;; gamma_incomplete returns a regularized result
1632 (complexify (gamma-incomplete ca cz t))))
1634 ((bigfloat-numerical-eval-p a z)
1635 (div (bfloat-gamma-incomplete ($bfloat a) ($bfloat z))
1636 (simplify (list '(%gamma) ($bfloat a)))))
1638 ((complex-bigfloat-numerical-eval-p a z)
1639 (let ((ca (add ($bfloat ($realpart a))
1640 (mul '$%i ($bfloat ($imagpart a)))))
1641 (cz (add ($bfloat ($realpart z))
1642 (mul '$%i ($bfloat ($imagpart z))))))
1643 ($rectform
1644 (div
1645 (complex-bfloat-gamma-incomplete ca cz)
1646 (simplify (list '(%gamma) ca))))))
1648 ;; Check for transformations and argument simplification
1650 ((and $gamma_expand (integerp a))
1651 ;; An integer. Expand the expression.
1652 (let ((sgn ($sign a)))
1653 (cond
1654 ((member sgn '($pos $pz))
1655 (mul
1656 (power '$%e (mul -1 z))
1657 (let ((index (gensumindex)))
1658 (simpsum1
1659 (div
1660 (power z index)
1661 (let (($gamma_expand nil))
1662 (simplify (list '(%gamma) (add index 1)))))
1663 index 0 (sub a 1)))))
1664 ((member sgn '($neg $nz)) 0)
1665 (t (give-up)))))
1667 ((and $gamma_expand (setq ratorder (max-numeric-ratio-p a 2)))
1668 ;; We have a half integral order and $gamma_expand is not NIL.
1669 ;; We expand in a series with the Erfc function
1670 (setq ratorder (- ratorder (/ 1 2)))
1671 (when *debug-gamma*
1672 (format t "~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in RATORDER~%")
1673 (format t "~& : a = ~A~%" a)
1674 (format t "~& : ratorder = ~A~%" ratorder))
1675 (cond
1676 ((equal ratorder 0)
1677 (simplify (list '(%erfc) (power z '((rat simp) 1 2)))))
1679 ((> ratorder 0)
1680 (add
1681 (simplify (list '(%erfc) (power z '((rat simp) 1 2))))
1682 (mul
1683 (power -1 (sub ratorder 1))
1684 (power '$%e (mul -1 z))
1685 (power z '((rat simp) 1 2))
1686 (div 1 (simplify (list '(%gamma) a)))
1687 (let ((index (gensumindex)))
1688 (simpsum1
1689 (mul
1690 (power (mul -1 z) index)
1691 (simplify (list '($pochhammer)
1692 (sub '((rat simp) 1 2) ratorder)
1693 (sub ratorder (add index 1)))))
1694 index 0 (sub ratorder 1))))))
1696 ((< ratorder 0)
1697 (setq ratorder (- ratorder))
1698 (add
1699 (simplify (list '(%erfc) (power z '((rat simp) 1 2))))
1700 (mul -1
1701 (power '$%e (mul -1 z))
1702 (power z (sub '((rat simp) 1 2) ratorder))
1703 (inv (simplify (list '(%gamma) (sub '((rat simp) 1 2) ratorder))))
1704 (let ((index (gensumindex)))
1705 (simpsum1
1706 (div
1707 (power z index)
1708 (simplify (list '($pochhammer)
1709 (sub '((rat simp) 1 2) ratorder)
1710 (add index 1))))
1711 index 0 (sub ratorder 1))))))))
1713 ((and $gamma_expand (mplusp a) (integerp (cadr a)))
1714 (when *debug-gamma*
1715 (format t "~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in COND (mplusp)~%"))
1716 (let ((n (cadr a))
1717 (a (simplify (cons '(mplus) (cddr a)))))
1718 (cond
1719 ((> n 0)
1720 (add
1721 (simplify (list '(%gamma_incomplete_regularized) a z))
1722 ;; We factor the second summand.
1723 ;; Some factors vanish and the result is more readable.
1724 ($factor
1725 (mul
1726 (power '$%e (mul -1 z))
1727 (power z (add a -1))
1728 (div 1 (simplify (list '(%gamma) a)))
1729 (let ((index (gensumindex)))
1730 (simpsum1
1731 (div
1732 (power z index)
1733 (simplify (list '($pochhammer) a index)))
1734 index 1 n))))))
1735 ((< n 0)
1736 (setq n (- n))
1737 (add
1738 (simplify (list '(%gamma_incomplete_regularized) a z))
1739 ;; We factor the second summand.
1740 ($factor
1741 (mul -1
1742 (power '$%e (mul -1 z))
1743 (power z (sub a (add n 1)))
1744 (div 1 (simplify (list '(%gamma) (add a (- n)))))
1745 (let ((index (gensumindex)))
1746 (simpsum1
1747 (div
1748 (power z index)
1749 (simplify (list '($pochhammer) (add a (- n)) index)))
1750 index 1 n)))))))))
1751 ((and $gamma_expand (consp a) (eq 'rat (caar a))
1752 (integerp (second a))
1753 (integerp (third a)))
1754 ;; gamma_incomplete_regularized of numeric rational order.
1755 ;; Expand it out so that the resulting order is between 0 and
1756 ;; 1. Use gamma_incomplete_regularized(a+n,z) to do the dirty
1757 ;; work.
1758 (multiple-value-bind (n order)
1759 (floor (/ (second a) (third a)))
1760 ;; a = n + order where 0 <= order < 1.
1761 (let ((rat-order (rat (numerator order) (denominator order))))
1762 (cond
1763 ((zerop n)
1764 ;; Nothing to do if the order is already between 0 and 1
1765 (give-up))
1767 ;; Use gamma_incomplete_regularized(a+n,z) above. and
1768 ;; then substitue a=order. This works for n positive or
1769 ;; negative.
1770 (let* ((ord (gensym))
1771 (g (simplify (list '(%gamma_incomplete_regularized) (add ord n) z))))
1772 ($substitute rat-order ord g)))))))
1774 (t (give-up)))))
1776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1778 ;;; Implementation of the Logarithm of the Gamma function
1780 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1782 (defmfun $log_gamma (z)
1783 (simplify (list '(%log_gamma) z)))
1785 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1787 (defprop $log_gamma %log_gamma alias)
1788 (defprop $log_gamma %log_gamma verb)
1790 (defprop %log_gamma $log_gamma reversealias)
1791 (defprop %log_gamma $log_gamma noun)
1793 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1795 (defprop %log_gamma simp-log-gamma operators)
1797 ;;; Logarithm of the Gamma function distributes over bags
1799 (defprop %log_gamma (mlist $matrix mequal) distribute_over)
1801 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1803 (defprop %log_gamma
1804 ((z)
1805 ((mqapply) (($psi array) 0) z))
1806 grad)
1808 ;; integrate(log_gamma(x),x) = psi[-2](x)
1809 (defun log-gamma-integral (x)
1810 (take '(mqapply) (take '($psi) -2) x))
1812 (putprop '%log_gamma (list (list 'x) #'log-gamma-integral) 'integral)
1814 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1816 (defun simp-log-gamma (expr z simpflag)
1817 (oneargcheck expr)
1818 (setq z (simpcheck (cadr expr) simpflag))
1819 (cond
1821 ;; Check for specific values
1823 ((and (mnump z)
1824 (or (zerop1 z)
1825 (and (eq ($sign z) '$neg)
1826 (zerop1 (sub z ($truncate z))))))
1827 ;; We have zero, a negative integer or a float or bigfloat representation.
1828 (simp-domain-error
1829 (intl:gettext "log_gamma: log_gamma(~:M) is undefined.") z))
1831 ((eq z '$inf) '$inf)
1833 ;; Check for numerical evaluation
1835 ((float-numerical-eval-p z)
1836 (complexify (log-gamma-lanczos (complex ($float z) 0))))
1838 ((complex-float-numerical-eval-p z)
1839 (complexify
1840 (log-gamma-lanczos
1841 (complex ($float ($realpart z)) ($float ($imagpart z))))))
1843 ((bigfloat-numerical-eval-p z)
1844 (bfloat-log-gamma ($bfloat z)))
1846 ((complex-bigfloat-numerical-eval-p z)
1847 (complex-bfloat-log-gamma
1848 (add ($bfloat ($realpart z)) (mul '$%i ($bfloat ($imagpart z))))))
1850 ;; Transform to Logarithm of Factorial for integer values
1851 ;; At this point the integer value is positive and not zero.
1853 ((integerp z)
1854 (simplify (list '(%log) (simplify (list '(mfactorial) (- z 1))))))
1856 (t (eqtest (list '(%log_gamma) z) expr))))
1858 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1859 ;;; The functions log-gamma-lanczos, bfloat-log-gamma and
1860 ;;; complex-bfloat-log-gamma are modified versions of the related functions
1861 ;;; gamma-lanczos, bffac and cbffac. The functions return the Logarithm of
1862 ;;; the Gamma function. If we have to calculate the quotient of Gamma functions,
1863 ;;; e. g. for the Beta function, it is much more appropriate to use the
1864 ;;; logarithmic versions to avoid overflow.
1866 ;;; Be careful log(gamma(z)) is only for realpart(z) positive equal to
1867 ;;; log_gamma(z). For a negative realpart(z) log_gamma differ by multiple of
1868 ;;; %pi from log(gamma(z)). But we always have exp(log_gamma(z))= gamma(z).
1869 ;;; The terms to get the transformation for log_gamma(-z) are taken from
1870 ;;; functions.wolfram.com.
1871 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1873 (defun log-gamma-lanczos (z)
1874 (declare (type (complex flonum) z)
1875 (optimize (safety 3)))
1876 (let ((c (make-array 15 :element-type 'flonum
1877 :initial-contents
1878 '(0.99999999999999709182
1879 57.156235665862923517
1880 -59.597960355475491248
1881 14.136097974741747174
1882 -0.49191381609762019978
1883 .33994649984811888699e-4
1884 .46523628927048575665e-4
1885 -.98374475304879564677e-4
1886 .15808870322491248884e-3
1887 -.21026444172410488319e-3
1888 .21743961811521264320e-3
1889 -.16431810653676389022e-3
1890 .84418223983852743293e-4
1891 -.26190838401581408670e-4
1892 .36899182659531622704e-5))))
1893 (declare (type (simple-array flonum (15)) c))
1894 (if (minusp (realpart z))
1895 (let ((z (- z)))
1899 (- (float pi))
1900 (complex 0 1)
1901 (abs (floor (realpart z)))
1902 (- 1 (abs (signum (imagpart z)))))
1903 (log (float pi))
1904 (- (log (- z)))
1905 (- (log (sin (* (float pi) (- z (floor (realpart z)))))))
1907 (float pi)
1908 (complex 0 1)
1909 (floor (realpart z))
1910 (signum (imagpart z))))
1911 (log-gamma-lanczos z)))
1912 (let* ((z (- z 1))
1913 (zh (+ z 1/2))
1914 (zgh (+ zh 607/128))
1915 (lnzp (* (/ zh 2) (log zgh)))
1916 (ss
1917 (do ((sum 0.0)
1918 (pp (1- (length c)) (1- pp)))
1919 ((< pp 1)
1920 sum)
1921 (incf sum (/ (aref c pp) (+ z pp))))))
1922 (+ (log (sqrt (float (* 2 pi))))
1923 (log (+ ss (aref c 0)))
1924 (+ (- zgh) (* 2 lnzp)))))))
1926 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1928 (defun bfloat-log-gamma (z)
1929 (let (($ratprint nil)
1930 (bigfloat%pi ($bfloat '$%pi)))
1931 (cond
1932 ((eq ($sign z) '$neg)
1933 (let ((z (mul -1 z)))
1934 (sub
1935 (add
1936 (mul -1 bigfloat%pi '$%i
1937 (simplify (list '(mabs) (simplify (list '($floor) ($realpart z)))))
1938 (sub 1
1939 (simplify
1940 (list '(mabs) (simplify (list '(%signum) ($imagpart z)))))))
1941 (simplify (list '(%log) bigfloat%pi))
1942 (mul -1 (simplify (list '(%log) (mul -1 z))))
1943 (mul -1
1944 (simplify (list '(%log)
1945 (simplify (list '(%sin)
1946 (mul
1947 bigfloat%pi
1948 (sub z (simplify (list '($floor) ($realpart z))))))))))
1949 (mul
1950 bigfloat%pi '$%i
1951 (simplify (list '($floor) ($realpart z)))
1952 (simplify (list '(%signum) ($imagpart z)))))
1953 (bfloat-log-gamma z))))
1955 (let* ((k (* 2 (+ 1 ($entier (* 0.41 $fpprec)))))
1956 (m ($bfloat bigfloatone))
1957 (z+k (add z k -1))
1958 (y (power z+k 2))
1959 (x ($bfloat bigfloatzero))
1960 (ii))
1961 (dotimes (i (/ k 2))
1962 (setq ii (* 2 (+ i 1)))
1963 (setq m (mul m (add z ii -2) (add z ii -1)))
1964 (setq x (div
1965 (add x
1966 (div ($bern (+ k (- ii) 2))
1967 (* (+ k (- ii) 1) (+ k (- ii) 2))))
1968 y)))
1969 (add
1970 (div (simplify (list '(%log) (mul 2 bigfloat%pi z+k))) 2)
1971 (mul z+k (add (simplify (list '(%log) z+k)) x -1))
1972 (mul -1 (simplify (list '(%log) m)))))))))
1974 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1976 (defun complex-bfloat-log-gamma (z)
1977 (let (($ratprint nil)
1978 (bigfloat%pi ($bfloat '$%pi)))
1979 (cond
1980 ((eq ($sign ($realpart z)) '$neg)
1981 (let ((z (mul -1 z)))
1982 (sub
1983 (add
1984 (mul -1 bigfloat%pi '$%i
1985 (simplify (list '(mabs) (simplify (list '($floor) ($realpart z)))))
1986 (sub 1
1987 (simplify
1988 (list '(mabs) (simplify (list '(%signum) ($imagpart z)))))))
1989 (simplify (list '(%log) bigfloat%pi))
1990 (mul -1 (simplify (list '(%log) (mul -1 z))))
1991 (mul -1
1992 (simplify (list '(%log)
1993 (simplify (list '(%sin)
1994 (mul
1995 bigfloat%pi
1996 (sub z (simplify (list '($floor) ($realpart z))))))))))
1997 (mul
1998 bigfloat%pi '$%i
1999 (simplify (list '($floor) ($realpart z)))
2000 (simplify (list '(%signum) ($imagpart z)))))
2001 (complex-bfloat-log-gamma z))))
2003 (let* ((k (* 2 (+ 1 ($entier (* 0.41 $fpprec)))))
2004 (m ($bfloat bigfloatone))
2005 (z+k (add z k -1))
2006 (y ($rectform (power z+k 2)))
2007 (x ($bfloat bigfloatzero))
2008 (ii))
2009 (dotimes (i (/ k 2))
2010 (setq ii (* 2 (+ i 1)))
2011 (setq m ($rectform (mul m (add z ii -2) (add z ii -1))))
2012 (setq x ($rectform
2013 (div
2014 (add x
2015 (div ($bern (+ k (- ii) 2))
2016 (* (+ k (- ii) 1) (+ k (- ii) 2))))
2017 y))))
2018 ($rectform
2019 (add
2020 (div (simplify (list '(%log) (mul 2 bigfloat%pi z+k))) 2)
2021 (mul z+k (add (simplify (list '(%log) z+k)) x -1))
2022 (mul -1 (simplify (list '(%log) m))))))))))
2024 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2026 ;;; Implementation of the Error function Erf(z)
2028 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2030 ;; TODO: This is called by simp-expintegral-e in expintegral.lisp.
2031 ;; Can't remove this until that is fixed.
2032 (defmfun $erf (z)
2033 (simplify (list '(%erf) z)))
2035 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2037 ;;; erf has mirror symmetry
2039 (defprop %erf t commutes-with-conjugate)
2041 ;;; erf is an odd function
2043 (defprop %erf odd-function-reflect reflection-rule)
2045 ;;; erf distributes over bags
2047 (defprop %erf (mlist $matrix mequal) distribute_over)
2049 ;;; Derivative of the Error function erf
2051 (defprop %erf
2052 ((z)
2053 ((mtimes) 2
2054 ((mexpt) $%pi ((rat) -1 2))
2055 ((mexpt) $%e ((mtimes) -1 ((mexpt) z 2)))))
2056 grad)
2058 ;;; Integral of the Error function erf
2060 (defprop %erf
2061 ((z)
2062 ((mplus)
2063 ((mtimes)
2064 ((mexpt) $%pi ((rat) -1 2))
2065 ((mexpt) $%e ((mtimes) -1 ((mexpt) z 2))))
2066 ((mtimes) z ((%erf) z))))
2067 integral)
2069 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2071 (defun erf-hypergeometric (z)
2072 ; See A&S 7.1.21 or http://functions.wolfram.com/06.25.26.0001.01
2073 (mul 2
2075 (power '$%pi '((rat simp) -1 2))
2076 (list '(%hypergeometric simp)
2077 (list '(mlist simp) '((rat simp) 1 2))
2078 (list '(mlist simp) '((rat simp) 3 2))
2079 (mul -1 (power z 2)))))
2081 ;;; erf is a simplifying function
2083 (def-simplifier erf (z)
2084 (cond
2086 ;; Check for specific values
2088 ((zerop1 z) z)
2089 ((eq z '$inf) 1)
2090 ((eq z '$minf) -1)
2092 ;; Check for numerical evaluation
2094 ((float-numerical-eval-p z)
2095 (bigfloat::bf-erf ($float z)))
2096 ((complex-float-numerical-eval-p z)
2097 (complexify
2098 (bigfloat::bf-erf (complex ($float ($realpart z)) ($float ($imagpart z))))))
2099 ((bigfloat-numerical-eval-p z)
2100 (to (bigfloat::bf-erf (bigfloat:to ($bfloat z)))))
2101 ((complex-bigfloat-numerical-eval-p z)
2102 (to (bigfloat::bf-erf
2103 (bigfloat:to (add ($bfloat ($realpart z)) (mul '$%i ($bfloat ($imagpart z))))))))
2105 ;; Argument simplification
2107 ((taylorize (mop form) (second form)))
2108 ((and $erf_%iargs
2109 (not $erf_representation)
2110 (multiplep z '$%i))
2111 (mul '$%i (simplify (list '(%erfi) (coeff z '$%i 1)))))
2112 ((apply-reflection-simp (mop form) z $trigsign))
2114 ;; Representation through more general functions
2116 ($hypergeometric_representation
2117 (erf-hypergeometric z))
2119 ;; Transformation to Erfc or Erfi
2121 ((and $erf_representation
2122 (not (eq $erf_representation '$erf)))
2123 (case $erf_representation
2124 (%erfc
2125 (sub 1 (take '(%erfc) z)))
2126 (%erfi
2127 (mul -1 '$%i (take '(%erfi) (mul '$%i z))))
2129 (give-up))))
2132 (give-up))))
2134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2136 (defun erf (z)
2137 ;; We use the slatec routine for float values.
2138 (slatec:derf (float z)))
2140 ;; Compute erf(z) using the relationship
2142 ;; erf(z) = sqrt(z^2)/z*(1 - gamma_incomplete(1/2,z^2)/sqrt(%pi))
2144 ;; When z is real sqrt(z^2)/z is signum(z). For complex z,
2145 ;; sqrt(z^2)/z = 1 if -%pi/2 < arg(z) <= %pi/2 and -1 otherwise.
2147 ;; This relationship has serious round-off issues when z is small
2148 ;; because gamma_incomplete(1/2,z^2)/sqrt(%pi) is near 1.
2150 ;; complex-erf is for (lisp) complex numbers; bfloat-erf is for real
2151 ;; bfloats, and complex-bfloat-erf is for complex bfloats. Care is
2152 ;; taken to return real results for real arguments and imaginary
2153 ;; results for imaginary arguments
2154 (defun complex-erf (z)
2155 (let ((result
2157 (if (or (< (realpart z) 0.0) (and (= (realpart z) 0.0) (< (imagpart z) 0.0)))
2160 (- 1.0
2161 (* (/ (sqrt (float pi))) (gamma-incomplete 0.5 (* z z)))))))
2162 (cond
2163 ((= (imagpart z) 0.0)
2164 ;; Pure real argument, the result is real
2165 (complex (realpart result) 0.0))
2166 ((= (realpart z) 0.0)
2167 ;; Pure imaginary argument, the result is pure imaginary
2168 (complex 0.0 (imagpart result)))
2170 result))))
2172 (defun bfloat-erf (z)
2173 ;; Warning! This has round-off problems when abs(z) is very small.
2174 (let ((1//2 ($bfloat '((rat simp) 1 2))))
2175 ;; The argument is real, the result is real too
2176 ($realpart
2177 (mul
2178 (simplify (list '(%signum) z))
2179 (sub 1
2180 (mul
2181 (div 1 (power ($bfloat '$%pi) 1//2))
2182 (bfloat-gamma-incomplete 1//2 ($bfloat (power z 2)))))))))
2184 (defun complex-bfloat-erf (z)
2185 ;; Warning! This has round-off problems when abs(z) is very small.
2186 (let* (($ratprint nil)
2187 (1//2 ($bfloat '((rat simp) 1 2)))
2188 (result
2189 (cmul
2190 (cdiv (cpower (cpower z 2) 1//2) z)
2191 (sub 1
2192 (cmul
2193 (div 1 (power ($bfloat '$%pi) 1//2))
2194 (complex-bfloat-gamma-incomplete
2195 1//2
2196 ($bfloat (cpower z 2))))))))
2197 (cond
2198 ((zerop1 ($imagpart z))
2199 ;; Pure real argument, the result is real
2200 ($realpart result))
2201 ((zerop1 ($realpart z))
2202 ;; Pure imaginary argument, the result is pure imaginary
2203 (mul '$%i ($imagpart result)))
2205 ;; A general complex result
2206 result))))
2208 (in-package :bigfloat)
2210 ;; Erf(z) for all z. Z must be a CL real or complex number or a
2211 ;; BIGFLOAT or COMPLEX-BIGFLOAT object. The result will be of the
2212 ;; same type as Z.
2213 (defun bf-erf (z)
2214 (cond ((typep z 'cl:real)
2215 ;; Use Slatec derf, which should be faster than the series.
2216 (maxima::erf z))
2217 ((<= (abs z) 0.476936)
2218 ;; Use the series A&S 7.1.5 for small x:
2220 ;; erf(z) = 2*z/sqrt(%pi) * sum((-1)^n*z^(2*n)/n!/(2*n+1), n, 0, inf)
2222 ;; The threshold is approximately erf(x) = 0.5. (Doesn't
2223 ;; have to be super accurate.) This gives max accuracy when
2224 ;; using the identity erf(x) = 1 - erfc(x).
2225 (let ((z^2 (* z z)))
2226 (/ (* 2 z (sum-power-series z^2
2227 #'(lambda (k)
2228 (let ((2k (+ k k)))
2229 (- (/ (- 2k 1)
2231 (+ 2k 1)))))))
2232 (sqrt (%pi z)))))
2234 ;; The general case.
2235 (etypecase z
2236 (cl:real (maxima::erf z))
2237 (cl:complex (maxima::complex-erf z))
2238 (bigfloat
2239 (bigfloat (maxima::$bfloat (maxima::$expand (maxima::bfloat-erf (maxima::to z))))))
2240 (complex-bigfloat
2241 (bigfloat (maxima::$bfloat (maxima::$expand (maxima::complex-bfloat-erf (maxima::to z))))))))))
2243 (defun bf-erfc (z)
2244 ;; Compute erfc(z) via 1 - erf(z) is not very accurate if erf(z) is
2245 ;; near 1. Wolfram says
2247 ;; erfc(z) = 1 - sqrt(z^2)/z * (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2, z^2))
2249 ;; For real(z) > 0, sqrt(z^2)/z is 1 so
2251 ;; erfc(z) = 1 - (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2252 ;; = 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2)
2254 ;; For real(z) < 0, sqrt(z^2)/z is -1 so
2256 ;; erfc(z) = 1 + (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2257 ;; = 2 - 1/sqrt(pi)*gamma_incomplete(1/2,z^2)
2258 (flet ((gamma-inc (z)
2259 (etypecase z
2260 (cl:number
2261 (maxima::gamma-incomplete 0.5 z))
2262 (bigfloat
2263 (bigfloat:to (maxima::$bfloat
2264 (maxima::bfloat-gamma-incomplete (maxima::$bfloat maxima::1//2)
2265 (maxima::to z)))))
2266 (complex-bigfloat
2267 (bigfloat:to (maxima::$bfloat
2268 (maxima::complex-bfloat-gamma-incomplete (maxima::$bfloat maxima::1//2)
2269 (maxima::to z))))))))
2270 (if (>= (realpart z) 0)
2271 (/ (gamma-inc (* z z))
2272 (sqrt (%pi z)))
2273 (- 2
2274 (/ (gamma-inc (* z z))
2275 (sqrt (%pi z)))))))
2277 (in-package :maxima)
2279 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2281 ;;; Implementation of the Generalized Error function Erf(z1,z2)
2283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2285 ;;; Generalized Erf has mirror symmetry
2287 (defprop %erf_generalized t commutes-with-conjugate)
2289 ;;; Generalized Erf distributes over bags
2291 (defprop %erf_generalized (mlist $matrix mequal) distribute_over)
2293 ;;; Generalized Erf is antisymmetric Erf(z1,z2) = - Erf(z2,z1)
2295 (eval-when
2296 #+gcl (load eval)
2297 #-gcl (:load-toplevel :execute)
2298 (let (($context '$global) (context '$global))
2299 (meval '(($declare) %erf_generalized $antisymmetric))
2300 ;; Let's remove built-in symbols from list for user-defined properties.
2301 (setq $props (remove '%erf_generalized $props))))
2303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2305 (defprop %erf_generalized
2306 ((z1 z2)
2307 ;; derivative wrt z1
2308 ((mtimes) -2
2309 ((mexpt) $%pi ((rat) -1 2))
2310 ((mexpt) $%e ((mtimes) -1 ((mexpt) z1 2))))
2311 ;; derviative wrt z2
2312 ((mtimes) 2
2313 ((mexpt) $%pi ((rat) -1 2))
2314 ((mexpt) $%e ((mtimes) -1 ((mexpt) z2 2)))))
2315 grad)
2317 ;;; ----------------------------------------------------------------------------
2319 (defprop %erf_generalized simplim%erf_generalized simplim%function)
2321 (defun simplim%erf_generalized (expr var val)
2322 ;; Look for the limit of the arguments.
2323 (let ((z1 (limit (cadr expr) var val 'think))
2324 (z2 (limit (caddr expr) var val 'think)))
2325 (cond
2326 ;; Handle infinities at this place.
2327 ((or (eq z2 '$inf)
2328 (alike1 z2 '((mtimes) -1 $minf)))
2329 (sub 1 (take '(%erf) z1)))
2330 ((or (eq z2 '$minf)
2331 (alike1 z2 '((mtimes) -1 $inf)))
2332 (sub (mul -1 (take '(%erf) z1)) 1))
2333 ((or (eq z1 '$inf)
2334 (alike1 z1 '((mtimes) -1 $minf)))
2335 (sub (take '(%erf) z2) 1))
2336 ((or (eq z1 '$minf)
2337 (alike1 z1 '((mtimes) -1 $inf)))
2338 (add (take '(%erf) z2) 1))
2340 ;; All other cases are handled by the simplifier of the function.
2341 (simplify (list '(%erf_generalized) z1 z2))))))
2343 ;;; ----------------------------------------------------------------------------
2345 (def-simplifier erf_generalized (z1 z2)
2346 (cond
2348 ;; Check for specific values
2350 ((and (zerop1 z1) (zerop1 z2)) 0)
2351 ((zerop1 z1) (take '(%erf) z2))
2352 ((zerop1 z2) (mul -1 (take '(%erf) z1)))
2353 ((or (eq z2 '$inf)
2354 (alike1 z2 '((mtimes) -1 $minf)))
2355 (sub 1 (take '(%erf) z1)))
2356 ((or (eq z2 '$minf)
2357 (alike1 z2 '((mtimes) -1 $inf)))
2358 (sub (mul -1 (take '(%erf) z1)) 1))
2359 ((or (eq z1 '$inf)
2360 (alike1 z1 '((mtimes) -1 $minf)))
2361 (sub (take '(%erf) z2) 1))
2362 ((or (eq z1 '$minf)
2363 (alike1 z1 '((mtimes) -1 $inf)))
2364 (add (take '(%erf) z2) 1))
2366 ;; Check for numerical evaluation. Use erf(z1,z2) = erf(z2)-erf(z1)
2368 ((float-numerical-eval-p z1 z2)
2369 (- (bigfloat::bf-erf ($float z2))
2370 (bigfloat::bf-erf ($float z1))))
2371 ((complex-float-numerical-eval-p z1 z2)
2372 (complexify
2374 (bigfloat::bf-erf
2375 (complex ($float ($realpart z2)) ($float ($imagpart z2))))
2376 (bigfloat::bf-erf
2377 (complex ($float ($realpart z1)) ($float ($imagpart z1)))))))
2378 ((bigfloat-numerical-eval-p z1 z2)
2379 (to (bigfloat:-
2380 (bigfloat::bf-erf (bigfloat:to ($bfloat z2)))
2381 (bigfloat::bf-erf (bigfloat:to ($bfloat z1))))))
2382 ((complex-bigfloat-numerical-eval-p z1 z2)
2383 (to (bigfloat:-
2384 (bigfloat::bf-erf
2385 (bigfloat:to (add ($bfloat ($realpart z2)) (mul '$%i ($bfloat ($imagpart z2))))))
2386 (bigfloat::bf-erf
2387 (bigfloat:to (add ($bfloat ($realpart z1)) (mul '$%i ($bfloat ($imagpart z1)))))))))
2389 ;; Argument simplification
2391 ((and $trigsign (great (mul -1 z1) z1) (great (mul -1 z2) z2))
2392 (mul -1 (simplify (list '(%erf_generalized) (mul -1 z1) (mul -1 z2)))))
2394 ;; Representation through more general functions
2396 ($hypergeometric_representation
2397 (sub (erf-hypergeometric z2) (erf-hypergeometric z1)))
2399 ;; Transformation to Erf
2401 ($erf_representation
2402 (sub (simplify (list '(%erf) z2)) (simplify (list '(%erf) z1))))
2405 (give-up))))
2407 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2409 ;;; Implementation of the Complementary Error function Erfc(z)
2411 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2413 ;; TODO: called by simp-expintegral-e in expintegral.lisp. Need to
2414 ;; keep this around until that is fixed.
2415 (defmfun $erfc (z)
2416 (simplify (list '(%erfc) z)))
2418 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2420 (defprop %erfc t commutes-with-conjugate)
2422 ;;; Complementary Error function distributes over bags
2424 (defprop %erfc (mlist $matrix mequal) distribute_over)
2426 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2428 (defprop %erfc
2429 ((z)
2430 ((mtimes) -2
2431 ((mexpt) $%pi ((rat) -1 2))
2432 ((mexpt) $%e ((mtimes) -1 ((mexpt) z 2)))))
2433 grad)
2435 ;;; Integral of the Error function erfc
2437 (defprop %erfc
2438 ((z)
2439 ((mplus)
2440 ((mtimes) -1
2441 ((mexpt) $%pi ((rat) -1 2))
2442 ((mexpt) $%e ((mtimes) -1 ((mexpt) z 2))))
2443 ((mtimes) z ((%erfc) z))))
2444 integral)
2446 ;;; ----------------------------------------------------------------------------
2448 (defprop %erfc simplim%erfc simplim%function)
2450 (defun simplim%erfc (expr var val)
2451 ;; Look for the limit of the arguments.
2452 (let ((z (limit (cadr expr) var val 'think)))
2453 (cond
2454 ;; Handle infinities at this place.
2455 ((eq z '$inf) 0)
2456 ((eq z '$minf) 2)
2457 ((eq z '$infinity) ;; parallel to code in simplim%erf-%tanh
2458 (destructuring-let (((rpart . ipart) (trisplit (cadr expr)))
2459 (ans ()) (rlim ()))
2460 (setq rlim (limit rpart var val 'think))
2461 (setq ans
2462 (limit (m* rpart (m^t ipart -1)) var val 'think))
2463 (setq ans ($asksign (m+ `((mabs) ,ans) -1)))
2464 (cond ((or (eq ans '$pos) (eq ans '$zero))
2465 (cond ((eq rlim '$inf) 0)
2466 ((eq rlim '$minf) 2)
2467 (t '$und)))
2468 (t '$und))))
2469 ((eq z '$ind) '$ind)
2471 ;; All other cases are handled by the simplifier of the function.
2472 (simplify (list '(%erfc) z))))))
2474 ;;; ----------------------------------------------------------------------------
2476 (def-simplifier erfc (z)
2477 (cond
2479 ;; Check for specific values
2481 ((zerop1 z) 1)
2482 ((eq z '$inf) 0)
2483 ((eq z '$minf) 2)
2485 ;; Check for numerical evaluation.
2487 ((numerical-eval-p z)
2488 (to (bigfloat::bf-erfc (bigfloat:to z))))
2490 ;; Argument simplification
2492 ((taylorize (mop form) (second form)))
2493 ((and $trigsign (great (mul -1 z) z))
2494 (sub 2 (simplify (list '(%erfc) (mul -1 z)))))
2496 ;; Representation through more general functions
2498 ($hypergeometric_representation
2499 (sub 1 (erf-hypergeometric z)))
2501 ;; Transformation to Erf or Erfi
2503 ((and $erf_representation
2504 (not (eq $erf_representation '$erfc)))
2505 (case $erf_representation
2506 (%erf
2507 (sub 1 (take '(%erf) z)))
2508 (%erfi
2509 (add 1 (mul '$%i (take '(%erfi) (mul '$%i z)))))
2511 (give-up))))
2514 (give-up))))
2516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2518 ;;; Implementation of the Imaginary Error function Erfi(z)
2520 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2522 ;; TODO: Called by integrate-exp-special in sin.lisp. That needs to
2523 ;; be fixed before this can be removed.
2524 (defmfun $erfi (z)
2525 (simplify (list '(%erfi) z)))
2527 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2529 ;;; erfi has mirror symmetry
2531 (defprop %erfi t commutes-with-conjugate)
2533 ;;; erfi is an odd function
2535 (defprop %erfi odd-function-reflect reflection-rule)
2537 ;;; erfi distributes over bags
2539 (defprop %erfi (mlist $matrix mequal) distribute_over)
2541 ;;; Derivative of the Error function erfi
2543 (defprop %erfi
2544 ((z)
2545 ((mtimes) 2
2546 ((mexpt) $%pi ((rat) -1 2))
2547 ((mexpt) $%e ((mexpt) z 2))))
2548 grad)
2550 ;;; Integral of the Error function erfi
2552 (defprop %erfi
2553 ((z)
2554 ((mplus)
2555 ((mtimes) -1
2556 ((mexpt) $%pi ((rat) -1 2))
2557 ((mexpt) $%e ((mexpt) z 2)))
2558 ((mtimes) z ((%erfi) z))))
2559 integral)
2561 ;;; ----------------------------------------------------------------------------
2563 (defprop %erfi simplim%erfi simplim%function)
2565 (defun simplim%erfi (expr var val)
2566 ;; Look for the limit of the arguments.
2567 (let ((z (limit (cadr expr) var val 'think)))
2568 (cond
2569 ;; Handle infinities at this place.
2570 ((eq z '$inf) '$inf)
2571 ((eq z '$minf) '$minf)
2573 ;; All other cases are handled by the simplifier of the function.
2574 (simplify (list '(%erfi) z))))))
2576 ;;; ----------------------------------------------------------------------------
2578 (in-package :bigfloat)
2579 (defun bf-erfi (z)
2580 (flet ((erfi (z)
2581 ;; Use the relationship erfi(z) = -%i*erf(%i*z)
2582 (let* ((iz (complex (- (imagpart z)) (realpart z))) ; %i*z
2583 (result (bf-erf iz)))
2584 (complex (imagpart result) (- (realpart result))))))
2585 ;; Take care to return real results when the argument is real.
2586 (if (realp z)
2587 (if (minusp z)
2588 (- (bf-erfi (- z)))
2589 (realpart (erfi z)))
2590 (erfi z))))
2592 (in-package :maxima)
2594 ;;; erfi is an simplifying function
2596 (def-simplifier erfi (z)
2597 (cond
2599 ;; Check for specific values
2601 ((zerop1 z) z)
2602 ((eq z '$inf) '$inf)
2603 ((eq z '$minf) '$minf)
2605 ;; Check for numerical evaluation. Use erfi(z) = -%i*erf(%i*z).
2607 ((numerical-eval-p z)
2608 (to (bigfloat::bf-erfi (bigfloat:to z))))
2610 ;; Argument simplification
2612 ((taylorize (mop form) (second form)))
2613 ((and $erf_%iargs
2614 (multiplep z '$%i))
2615 (mul '$%i (simplify (list '(%erf) (coeff z '$%i 1)))))
2616 ((apply-reflection-simp (mop form) z $trigsign))
2618 ;; Representation through more general functions
2620 ($hypergeometric_representation
2621 (mul -1 '$%i (erf-hypergeometric (mul '$%i z))))
2623 ;; Transformation to Erf or Erfc
2625 ((and $erf_representation
2626 (not (eq $erf_representation '$erfi)))
2627 (case $erf_representation
2628 (%erf
2629 (mul -1 '$%i (take '(%erf) (mul '$%i z))))
2630 (%erfc
2631 (sub (mul '$%i (take '(%erfc) (mul '$%i z))) '$%i))
2633 (give-up))))
2636 (give-up))))
2638 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2640 ;;; The implementation of the Inverse Error function
2642 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2644 ;;; The Inverse Error function distributes over bags
2646 (defprop %inverse_erf (mlist $matrix mequal) distribute_over)
2648 ;;; inverse_erf is the inverse of the erf function
2650 (defprop %inverse_erf %erf $inverse)
2651 (defprop %erf %inverse_erf $inverse)
2653 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2655 ;;; Differentiation of the Inverse Error function
2657 (defprop %inverse_erf
2658 ((z)
2659 ((mtimes)
2660 ((rat) 1 2)
2661 ((mexpt) $%pi ((rat) 1 2))
2662 ((mexpt) $%e ((mexpt) ((%inverse_erf) z) 2))))
2663 grad)
2665 ;;; Integral of the Inverse Error function
2667 (defprop %inverse_erf
2668 ((z)
2669 ((mtimes) -1
2670 ((mexpt) $%pi ((rat) -1 2))
2671 ((mexpt) $%e ((mtimes) -1 ((mexpt) ((%inverse_erf) z) 2)))))
2672 integral)
2674 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2676 ;;; We support a simplim%function. The function is looked up in simplimit and
2677 ;;; handles specific values of the function.
2679 (defprop %inverse_erf simplim%inverse_erf simplim%function)
2681 (defun simplim%inverse_erf (expr var val)
2682 ;; Look for the limit of the argument.
2683 (let ((z (limit (cadr expr) var val 'think)))
2684 (cond
2685 ;; Handle an argument 1 at this place
2686 ((onep1 z) '$inf)
2687 ((onep1 (mul -1 z)) '$minf)
2689 ;; All other cases are handled by the simplifier of the function.
2690 (simplify (list '(%inverse_erf) z))))))
2692 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2694 ;;; The Inverse Error function is a simplifying function
2696 (def-simplifier inverse_erf (z)
2697 (cond
2698 ((or (onep1 z)
2699 (onep1 (mul -1 z)))
2700 (simp-domain-error
2701 (intl:gettext "inverse_erf: inverse_erf(~:M) is undefined.") z))
2702 ((zerop1 z) z)
2703 ((numerical-eval-p z)
2704 (to (bigfloat::bf-inverse-erf (bigfloat:to z))))
2705 ((taylorize (mop form) (cadr form)))
2707 (give-up))))
2709 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2711 ;;; The implementation of the Inverse Complementary Error function
2713 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2715 ;;; Inverse Complementary Error function distributes over bags
2717 (defprop %inverse_erfc (mlist $matrix mequal) distribute_over)
2719 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2721 ;;; inverse_erfc is the inverse of the erfc function
2723 (defprop %inverse_erfc %erfc $inverse)
2724 (defprop %erfc %inverse_erfc $inverse)
2727 ;;; Differentiation of the Inverse Complementary Error function
2729 (defprop %inverse_erfc
2730 ((z)
2731 ((mtimes)
2732 ((rat) -1 2)
2733 ((mexpt) $%pi ((rat) 1 2))
2734 ((mexpt) $%e ((mexpt) ((%inverse_erfc) z) 2))))
2735 grad)
2737 ;;; Integral of the Inverse Complementary Error function
2739 (defprop %inverse_erfc
2740 ((z)
2741 ((mtimes)
2742 ((mexpt) $%pi ((rat) -1 2))
2743 ((mexpt) $%e
2744 ((mtimes) -1 ((mexpt) ((%inverse_erfc) z) 2)))))
2745 integral)
2747 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2749 ;;; We support a simplim%function. The function is looked up in simplimit and
2750 ;;; handles specific values of the function.
2752 (defprop %inverse_erfc simplim%inverse_erfc simplim%function)
2754 (defun simplim%inverse_erfc (expr var val)
2755 ;; Look for the limit of the argument.
2756 (let ((z (limit (cadr expr) var val 'think)))
2757 (cond
2758 ;; Handle an argument 0 at this place
2759 ((or (zerop1 z)
2760 (eq z '$zeroa)
2761 (eq z '$zerob))
2762 '$inf)
2763 ((zerop1 (add z -2)) '$minf)
2765 ;; All other cases are handled by the simplifier of the function.
2766 (simplify (list '(%inverse_erfc) z))))))
2768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2770 ;;; Inverse Complementary Error function is a simplifying function
2771 (def-simplifier inverse_erfc (z)
2772 (cond
2773 ((or (zerop1 z)
2774 (zerop1 (add z -2)))
2775 (simp-domain-error
2776 (intl:gettext "inverse_erfc: inverse_erfc(~:M) is undefined.") z))
2777 ((onep1 z) 0)
2778 ((numerical-eval-p z)
2779 (to (bigfloat::bf-inverse-erfc (bigfloat:to z))))
2780 ((taylorize (mop form) (cadr form)))
2782 (give-up))))
2784 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2786 ;;; Implementation of the Newton algorithm to calculate numerical values
2787 ;;; of the Inverse Error functions in float or bigfloat precision.
2788 ;;; The algorithm is a modified version of the routine in newton1.mac.
2790 (defvar *debug-newton* nil)
2791 (defvar *newton-maxcount* 1000)
2792 (defvar *newton-epsilon-factor* 50)
2793 (defvar *newton-epsilon-factor-float* 10)
2795 (defun float-newton (expr var x0 eps)
2796 (do ((s (sdiff expr var))
2797 (xn x0)
2798 (sn)
2799 (count 0 (+ count 1)))
2800 ((> count *newton-maxcount*)
2801 (merror
2802 (intl:gettext "float-newton: Newton does not converge for ~:M") expr))
2803 (setq sn ($float (maxima-substitute xn var expr)))
2804 (when (< (abs sn) eps) (return xn))
2805 (when *debug-newton* (format t "~&xn = ~A~%" xn))
2806 (setq xn ($float (sub xn (div sn (maxima-substitute xn var s)))))))
2808 (defun bfloat-newton (expr var x0 eps)
2809 (do ((s (sdiff expr var))
2810 (xn x0)
2811 (sn)
2812 (count 0 (+ count 1)))
2813 ((> count *newton-maxcount*)
2814 (merror
2815 (intl:gettext "bfloat-newton: Newton does not converge for ~:M") expr))
2816 (setq sn ($bfloat (maxima-substitute xn var expr)))
2817 (when (eq ($sign (sub (simplify (list '(mabs) sn)) eps)) '$neg)
2818 (return xn))
2819 (when *debug-newton* (format t "~&xn = ~A~%" xn))
2820 (setq xn ($bfloat (sub xn (div sn (maxima-substitute xn var s)))))))
2823 (in-package :bigfloat)
2825 ;; Compute inverse_erf(z) for z a real or complex number, including
2826 ;; bigfloat objects. The value is computing using a Newton iteration
2827 ;; to solve erf(x) = z.
2828 (defun bf-inverse-erf (z)
2829 (cond ((zerop z)
2831 ((= (abs z) 1)
2832 (maxima::merror
2833 (intl:gettext "bf-inverse-erf: inverse_erf(~M) is undefined")
2835 ((minusp (realpart z))
2836 ;; inverse_erf is odd because erf is.
2837 (- (bf-inverse-erf (- z))))
2839 (labels
2840 ((approx (z)
2841 ;; Find an approximate solution for x = inverse_erf(z).
2842 (let ((result
2843 (cond ((<= (abs z) 1)
2844 ;; For small z, inverse_erf(z) = z*sqrt(%pi)/2
2845 ;; + O(z^3). Thus, x = z*sqrt(%pi)/2 is our
2846 ;; initial starting point.
2847 (* z (sqrt (%pi z)) 1/2))
2849 ;; For |z| > 1 and realpart(z) >= 0, we have
2850 ;; the asymptotic series z = erf(x) = 1 -
2851 ;; exp(-x^2)/x/sqrt(%pi).
2853 ;; Then
2854 ;; x = sqrt(-log(x*sqrt(%pi)*(1-z))
2856 ;; We can use this as a fixed-point iteration
2857 ;; to find x, and we can start the iteration at
2858 ;; x = 1. Just do one more iteration. I (RLT)
2859 ;; think that's close enough to get the Newton
2860 ;; algorithm to converge.
2861 (let* ((sp (sqrt (%pi z)))
2862 (a (sqrt (- (log (* sp (- 1 z)))))))
2863 (setf a (sqrt (- (log (* a sp (- 1 z))))))
2864 (setf a (sqrt (- (log (* a sp (- 1 z)))))))))))
2865 (when maxima::*debug-newton*
2866 (format t "approx = ~S~%" result))
2867 result)))
2868 (let ((two/sqrt-pi (/ 2 (sqrt (%pi z))))
2869 (eps
2870 ;; Try to pick a reasonable epsilon value for the
2871 ;; Newton iteration.
2872 (cond ((<= (abs z) 1)
2873 (typecase z
2874 (cl:real (* maxima::*newton-epsilon-factor-float*
2875 maxima::flonum-epsilon))
2876 (t (* maxima::*newton-epsilon-factor* (epsilon z)))))
2878 (* maxima::*newton-epsilon-factor* (epsilon z))))))
2879 (when maxima::*debug-newton*
2880 (format t "eps = ~S~%" eps))
2881 (flet ((diff (x)
2882 ;; Derivative of erf(x)
2883 (* two/sqrt-pi (exp (- (* x x))))))
2884 (bf-newton #'bf-erf
2885 #'diff
2887 (approx z)
2888 eps)))))))
2890 (defun bf-inverse-erfc (z)
2891 (cond ((zerop z)
2892 (maxima::merror
2893 (intl:gettext "bf-inverse-erfc: inverse_erfc(~M) is undefined")
2895 ((= z 1)
2896 (float 0 z))
2898 (flet
2899 ((approx (z)
2900 ;; Find an approximate solution for x =
2901 ;; inverse_erfc(z). We have inverse_erfc(z) =
2902 ;; inverse_erf(1-z), so that's a good starting point.
2903 ;; We don't need full precision, so a float value is
2904 ;; good enough. But if 1-z is 1, inverse_erf is
2905 ;; undefined, so we need to do something else.
2906 (let ((result
2907 (let ((1-z (float (- 1 z) 0.0)))
2908 (cond ((= 1 1-z)
2909 (if (minusp (realpart z))
2910 (bf-inverse-erf (+ 1 (* 5 maxima::flonum-epsilon)))
2911 (bf-inverse-erf (- 1 (* 5 maxima::flonum-epsilon)))))
2913 (bf-inverse-erf 1-z))))))
2914 (when maxima::*debug-newton*
2915 (format t "approx = ~S~%" result))
2916 result)))
2917 (let ((-two/sqrt-pi (/ -2 (sqrt (%pi z))))
2918 (eps (* maxima::*newton-epsilon-factor* (epsilon z))))
2919 (when maxima::*debug-newton*
2920 (format t "eps = ~S~%" eps))
2921 (flet ((diff (x)
2922 ;; Derivative of erfc(x)
2923 (* -two/sqrt-pi (exp (- (* x x))))))
2924 (bf-newton #'bf-erfc
2925 #'diff
2927 (approx z)
2928 eps)))))))
2930 ;; Newton iteration for solving f(x) = z, given f and the derivative
2931 ;; of f.
2932 (defun bf-newton (f df z start eps)
2933 (do ((x start)
2934 (delta (/ (- (funcall f start) z)
2935 (funcall df start))
2936 (/ (- (funcall f x) z)
2937 (funcall df x)))
2938 (count 0 (1+ count)))
2939 ((or (< (abs delta) (* (abs x) eps))
2940 (> count maxima::*newton-maxcount*))
2941 (if (> count maxima::*newton-maxcount*)
2942 (maxima::merror
2943 (intl:gettext "bf-newton: failed to converge after ~M iterations: delta = ~S, x = ~S eps = ~S")
2944 count delta x eps)
2946 (when maxima::*debug-newton*
2947 (format t "x = ~S, abs(delta) = ~S relerr = ~S~%"
2948 x (abs delta) (/ (abs delta) (abs x))))
2949 (setf x (- x delta))))
2951 (in-package :maxima)
2953 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2955 ;;; Implementation of the Fresnel Integral S(z)
2957 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2959 ;;; fresnel_s distributes over bags
2961 (defprop %fresnel_s (mlist $matrix mequal) distribute_over)
2963 ;;; fresnel_s has mirror symmetry
2965 (defprop %fresnel_s t commutes-with-conjugate)
2967 ;;; fresnel_s is an odd function
2969 ;;; Maxima has two mechanism to define a reflection property
2970 ;;; 1. Declare the feature oddfun or evenfun
2971 ;;; 2. Put a reflection rule on the property list
2973 ;;; The second way is used for the trig functions. We use it here too.
2975 ;;; This would be the first way to give the property of an odd function.
2976 ;(eval-when
2977 ; #+gcl (load eval)
2978 ; #-gcl (:load-toplevel :execute)
2979 ; (let (($context '$global) (context '$global))
2980 ; (meval '(($declare) %fresnel_s $oddfun))
2981 ; ;; Let's remove built-in symbols from list for user-defined properties.
2982 ; (setq $props (remove '%fresnel_s $props))))
2984 (defprop %fresnel_s odd-function-reflect reflection-rule)
2986 ;;; Differentiation of the Fresnel Integral S
2988 (defprop %fresnel_s
2989 ((z)
2990 ((%sin) ((mtimes) ((rat) 1 2) $%pi ((mexpt) z 2))))
2991 grad)
2993 ;;; Integration of the Fresnel Integral S
2995 (defprop %fresnel_s
2996 ((z)
2997 ((mplus)
2998 ((mtimes) z ((%fresnel_s) z))
2999 ((mtimes)
3000 ((mexpt) $%pi -1)
3001 ((%cos) ((mtimes) ((rat) 1 2) $%pi ((mexpt) z 2))))))
3002 integral)
3004 ;;; Limits of the Fresnel Integral S
3006 (defprop %fresnel_s simplim%fresnel_s simplim%function)
3007 (defun simplim%fresnel_s (exp var val)
3008 (let ((arg (limit (cadr exp) var val 'think)))
3009 (cond ((eq arg '$inf)
3010 '((rat simp) 1 2))
3011 ((eq arg '$minf)
3012 '((rat simp) -1 2))
3014 `((%fresnel_s) ,arg)))))
3016 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3018 (defvar *fresnel-maxit* 1000)
3019 (defvar *fresnel-eps* (* 2 flonum-epsilon))
3020 (defvar *fresnel-min* 1e-32)
3022 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3023 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3025 (in-package :bigfloat)
3027 (defun bf-fresnel (z)
3028 (let* ((eps (epsilon z))
3029 (maxit maxima::*fresnel-maxit*)
3030 (xmin 1.5)
3031 (bf-pi (%pi z))
3032 ;; For very small x, we have
3033 ;; fresnel_s(x) = %pi/6*z^3
3034 ;; fresnel_c(x) = x
3035 (s (* (/ bf-pi 6) z z z))
3036 (c z))
3037 (when (> (abs z) eps)
3038 (cond
3039 ((< (abs z) xmin)
3040 (when maxima::*debug-gamma*
3041 (format t "~& in FRESNEL series expansion.~%"))
3042 (let ((sums 0) (sumc z))
3043 (do ((sum 0)
3044 (sign 1)
3045 (fact (* (/ bf-pi 2) (* z z)))
3046 (term z)
3047 (odd t (not odd))
3048 (test 0)
3049 (n 3 (+ n 2))
3050 (k 1 (+ k 1)))
3051 ((> k maxit)
3052 (maxima::merror (intl:gettext "fresnel: series expansion failed for (COMPLEX-BFLOAT-FRESNEL ~:M).") z))
3053 (setq term (* term (/ fact k)))
3054 (setq sum (+ sum (/ (* sign term) n)))
3055 (setq test (* (abs sum) eps))
3056 (if odd
3057 (progn
3058 (setq sign (- sign))
3059 (setq sums sum)
3060 (setq sum sumc))
3061 (progn
3062 (setq sumc sum)
3063 (setq sum sums)))
3064 (if (< (abs term) test)
3065 (return)))
3066 (setq s sums)
3067 (setq c sumc)))
3069 (let* ((sqrt-pi (sqrt bf-pi))
3070 (z+ (* (complex 1/2 1/2)
3071 (* sqrt-pi
3072 z)))
3073 (z- (* (complex 1/2 -1/2)
3074 (* sqrt-pi
3075 z)))
3076 (erf+ (bf-erf z+))
3077 (erf- (bf-erf z-)))
3078 (setq s (* (complex 1/4 1/4)
3079 (+ erf+ (* (complex 0 -1) erf-))))
3080 (setq c (* (complex 1/4 -1/4)
3081 (+ erf+ (* (complex 0 1) erf-))))))))
3082 (values s c)))
3084 (defun bf-fresnel-s (z)
3085 (if (and (complexp z) (zerop (realpart z)))
3086 ;; A pure imaginary argument. Use fresnel_s(%i*x)=-%i*fresnel_s(x).
3087 (complex 0
3088 (- (bf-fresnel-s (imagpart z))))
3089 (let ((fs (bf-fresnel z)))
3090 (if (realp z)
3091 (realpart fs)
3092 fs))))
3094 (defun bf-fresnel-c (z)
3095 (if (and (complexp z) (zerop (realpart z)))
3096 ;; A pure imaginary argument. Use fresnel_c(%i*x)=%i*fresnel_c(x).
3097 (complex 0
3098 (bf-fresnel-c (imagpart z)))
3099 (let ((fc (nth-value 1 (bf-fresnel z))))
3100 (if (realp z)
3101 (realpart fc)
3102 fc))))
3104 (in-package :maxima)
3106 ;;; fresnel_s is a simplifying function
3107 (def-simplifier fresnel_s (z)
3108 (cond
3110 ;; Check for specific values
3112 ((zerop1 z) z)
3113 ((eq z '$inf) '((rat simp) 1 2))
3114 ((eq z '$minf) '((rat simp) -1 2))
3116 ;; Check for numerical evaluation
3117 ((numerical-eval-p z)
3118 (to (bigfloat::bf-fresnel-s (bigfloat::to z))))
3120 ;; Check for argument simplification
3122 ((taylorize (mop form) (second form)))
3123 ((and $%iargs (multiplep z '$%i))
3124 (mul -1 '$%i (simplify (list '(%fresnel_s) (coeff z '$%i 1)))))
3125 ((apply-reflection-simp (mop form) z $trigsign))
3127 ;; Representation through equivalent functions
3129 ($erf_representation
3130 (mul
3131 (div (add 1 '$%i) 4)
3132 (add
3133 (simplify
3134 (list
3135 '(%erf)
3136 (mul (div (add 1 '$%i) 2) (power '$%pi '((rat simp) 1 2)) z)))
3137 (mul -1 '$%i
3138 (simplify
3139 (list
3140 '(%erf)
3141 (mul (div (sub 1 '$%i) 2)
3142 (power '$%pi '((rat simp) 1 2)) z)))))))
3144 ($hypergeometric_representation
3145 (mul (div (mul '$%pi (power z 3)) 6)
3146 (take '($hypergeometric)
3147 (list '(mlist) (div 3 4))
3148 (list '(mlist) (div 3 2) (div 7 4))
3149 (mul -1 (div (mul (power '$%pi 2) (power z 4)) 16)))))
3152 (give-up))))
3153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3155 ;;; Implementation of the Fresnel Integral C(z)
3157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3159 ;;; fresnel_c distributes over bags
3161 (defprop %fresnel_c (mlist $matrix mequal) distribute_over)
3163 ;;; fresnel_c has mirror symmetry
3165 (defprop %fresnel_c t commutes-with-conjugate)
3167 ;;; fresnel_c is an odd function
3168 ;;; Maxima has two mechanism to define a reflection property
3169 ;;; 1. Declare the feature oddfun or evenfun
3170 ;;; 2. Put a reflection rule on the property list
3172 ;;; The second way is used for the trig functions. We use it here too.
3174 (defprop %fresnel_c odd-function-reflect reflection-rule)
3176 ;;; Differentiation of the Fresnel Integral C
3178 (defprop %fresnel_c
3179 ((z)
3180 ((%cos) ((mtimes) ((rat) 1 2) $%pi ((mexpt) z 2))))
3181 grad)
3183 ;;; Integration of the Fresnel Integral C
3185 (defprop %fresnel_c
3186 ((z)
3187 ((mplus)
3188 ((mtimes) z ((%fresnel_c) z))
3189 ((mtimes) -1
3190 ((mexpt) $%pi -1)
3191 ((%sin) ((mtimes) ((rat) 1 2) $%pi ((mexpt) z 2))))))
3192 integral)
3194 ;;; Limits of the Fresnel Integral C
3196 (defprop %fresnel_c simplim%fresnel_c simplim%function)
3197 (defun simplim%fresnel_c (exp var val)
3198 (let ((arg (limit (cadr exp) var val 'think)))
3199 (cond ((eq arg '$inf)
3200 '((rat simp) 1 2))
3201 ((eq arg '$minf)
3202 '((rat simp) -1 2))
3204 `((%fresnel_c) ,arg)))))
3206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3208 ;;; fresnel_c is a simplifying function
3209 (def-simplifier fresnel_c (z)
3210 (cond
3212 ;; Check for specific values
3214 ((zerop1 z) z)
3215 ((eq z '$inf) '((rat simp) 1 2))
3216 ((eq z '$minf) '((rat simp) -1 2))
3218 ;; Check for numerical evaluation
3219 ((numerical-eval-p z)
3220 (to (bigfloat::bf-fresnel-c (bigfloat::to z))))
3223 ;; Check for argument simplification
3225 ((taylorize (mop form) (second form)))
3226 ((and $%iargs (multiplep z '$%i))
3227 (mul '$%i (simplify (list '(%fresnel_c) (coeff z '$%i 1)))))
3228 ((apply-reflection-simp (mop form) z $trigsign))
3230 ;; Representation through equivalent functions
3232 ($erf_representation
3233 (mul
3234 (div (sub 1 '$%i) 4)
3235 (add
3236 (simplify
3237 (list
3238 '(%erf)
3239 (mul (div (add 1 '$%i) 2) (power '$%pi '((rat simp) 1 2)) z)))
3240 (mul '$%i
3241 (simplify
3242 (list
3243 '(%erf)
3244 (mul (div (sub 1 '$%i) 2)
3245 (power '$%pi '((rat simp) 1 2)) z)))))))
3247 ($hypergeometric_representation
3248 (mul z
3249 (take '($hypergeometric)
3250 (list '(mlist) (div 1 4))
3251 (list '(mlist) (div 1 2) (div 5 4))
3252 (mul -1 (div (mul (power '$%pi 2) (power z 4)) 16)))))
3255 (give-up))))
3256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3258 ;;; Implementation of the Beta function
3260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3262 ;;; The code for the implementation of the beta function is in the files
3263 ;;; csimp2.lisp, simp.lisp and mactex.lisp.
3264 ;;; At this place we only implement the operator property SYMMETRIC.
3266 ;;; Beta is symmetric beta(a,b) = beta(b,a)
3268 (eval-when
3269 #+gcl (load eval)
3270 #-gcl (:load-toplevel :execute)
3271 (let (($context '$global) (context '$global))
3272 (meval '(($declare) $beta $symmetric))
3273 ;; Let's remove built-in symbols from list for user-defined properties.
3274 (setq $props (remove '$beta $props))))
3276 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3278 ;;; Implementation of the Incomplete Beta function
3280 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3282 (defvar *beta-incomplete-maxit* 10000)
3283 (defvar *beta-incomplete-eps* 1.0e-15)
3285 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3287 ;;; beta_incomplete distributes over bags
3289 (defprop %beta_incomplete (mlist $matrix mequal) distribute_over)
3291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3293 (defprop %beta_incomplete
3294 ((a b z)
3295 ;; Derivative wrt a
3296 ((mplus)
3297 ((mtimes) ((%beta_incomplete) a b z) ((%log) z))
3298 ((mtimes) -1
3299 ((mexpt) ((%gamma) a) 2)
3300 (($hypergeometric_regularized)
3301 ((mlist) a a ((mplus) 1 ((mtimes) -1 b)))
3302 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
3304 ((mexpt) z a)))
3305 ;; Derivative wrt b
3306 ((mplus)
3307 ((mtimes)
3308 (($beta) a b)
3309 ((mplus)
3310 ((mqapply) (($psi array) 0) b)
3311 ((mtimes) -1 ((mqapply) (($psi array) 0) ((mplus) a b)))))
3312 ((mtimes) -1
3313 ((%beta_incomplete) b a ((mplus) 1 ((mtimes) -1 z)))
3314 ((%log) ((mplus) 1 ((mtimes) -1 z))))
3315 ((mtimes)
3316 ((mexpt) ((%gamma) b) 2)
3317 (($hypergeometric_regularized)
3318 ((mlist) b b ((mplus) 1 ((mtimes) -1 a)))
3319 ((mlist) ((mplus) 1 b) ((mplus) 1 b))
3320 ((mplus) 1 ((mtimes) -1 z)))
3321 ((mexpt) ((mplus) 1 ((mtimes) -1 z)) b)))
3322 ;; The derivative wrt z
3323 ((mtimes)
3324 ((mexpt) ((mplus) 1 ((mtimes) -1 z)) ((mplus) -1 b))
3325 ((mexpt) z ((mplus) -1 a))))
3326 grad)
3328 ;;; Integral of the Incomplete Beta function
3330 (defprop %beta_incomplete
3331 ((a b z)
3332 nil
3334 ((mplus)
3335 ((mtimes) -1 ((%beta_incomplete) ((mplus) 1 a) b z))
3336 ((mtimes) ((%beta_incomplete) a b z) z)))
3337 integral)
3339 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3341 (def-simplifier beta_incomplete (a b z)
3342 (let (($simpsum t))
3343 (when *debug-gamma*
3344 (format t "~&SIMP-BETA-INCOMPLETE:~%")
3345 (format t "~& : a = ~A~%" a)
3346 (format t "~& : b = ~A~%" b)
3347 (format t "~& : z = ~A~%" z))
3348 (cond
3350 ;; Check for specific values
3352 ((zerop1 z)
3353 (let ((sgn ($sign ($realpart a))))
3354 (cond ((member sgn '($neg $zero))
3355 (simp-domain-error
3356 (intl:gettext
3357 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.")
3358 a b z))
3359 ((member sgn '($pos $pz))
3362 (give-up)))))
3364 ((and (onep1 z) (eq ($sign ($realpart b)) '$pos))
3365 ;; z=1 and realpart(b)>0. Simplify to a Beta function.
3366 ;; If we have to evaluate numerically preserve the type.
3367 (cond
3368 ((complex-float-numerical-eval-p a b z)
3369 (simplify (list '($beta) ($float a) ($float b))))
3370 ((complex-bigfloat-numerical-eval-p a b z)
3371 (simplify (list '($beta) ($bfloat a) ($bfloat b))))
3373 (simplify (list '($beta) a b)))))
3375 ((or (zerop1 a)
3376 (and (integer-representation-p a)
3377 (eq ($sign a) '$neg)
3378 (or (and (mnump b)
3379 (not (integer-representation-p b)))
3380 (eq ($sign (add a b)) '$pos))))
3381 ;; The argument a is zero or a is negative and the argument b is
3382 ;; not in a valid range. Beta incomplete is undefined.
3383 ;; It would be more correct to return Complex infinity.
3384 (simp-domain-error
3385 (intl:gettext
3386 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.") a b z))
3388 ;; Check for numerical evaluation in Float or Bigfloat precision
3390 ((complex-float-numerical-eval-p a b z)
3391 (cond
3392 ((not (and (integer-representation-p a) (< a 0.0)))
3393 (let ((*beta-incomplete-eps* (bigfloat:epsilon ($float 1.0))))
3394 (beta-incomplete ($float a) ($float b) ($float z))))
3396 ;; Negative integer a and b is in a valid range. Expand.
3397 ($rectform
3398 (beta-incomplete-expand-negative-integer
3399 (truncate a) ($float b) ($float z))))))
3401 ((complex-bigfloat-numerical-eval-p a b z)
3402 (cond
3403 ((not (and (integer-representation-p a) (eq ($sign a) '$neg)))
3404 (let ((*beta-incomplete-eps*
3405 (bigfloat:epsilon (bigfloat:bigfloat 1.0))))
3406 (beta-incomplete ($bfloat a) ($bfloat b) ($bfloat z))))
3408 ;; Negative integer a and b is in a valid range. Expand.
3409 ($rectform
3410 (beta-incomplete-expand-negative-integer
3411 ($truncate a) ($bfloat b) ($bfloat z))))))
3413 ;; Argument simplifications and transformations
3415 ((and (integerp b)
3416 (plusp b)
3417 (or (not (integerp a))
3418 (plusp a)))
3419 ;; Expand for b a positive integer and a not a negative integer.
3420 (mul
3421 (simplify (list '($beta) a b))
3422 (power z a)
3423 (let ((index (gensumindex)))
3424 (simpsum1
3425 (div
3426 (mul
3427 (simplify (list '($pochhammer) a index))
3428 (power (sub 1 z) index))
3429 (simplify (list '(mfactorial) index)))
3430 index 0 (sub b 1)))))
3432 ((and (integerp a) (plusp a))
3433 ;; Expand for a a positive integer.
3434 (mul
3435 (simplify (list '($beta) a b))
3436 (sub 1
3437 (mul
3438 (power (sub 1 z) b)
3439 (let ((index (gensumindex)))
3440 (simpsum1
3441 (div
3442 (mul
3443 (simplify (list '($pochhammer) b index))
3444 (power z index))
3445 (simplify (list '(mfactorial) index)))
3446 index 0 (sub a 1)))))))
3448 ((and (integerp a) (minusp a) (integerp b) (plusp b) (<= b (- a)))
3449 ;; Expand for a a negative integer and b an integer with b <= -a.
3450 (mul
3451 (power z a)
3452 (let ((index (gensumindex)))
3453 (simpsum1
3454 (div
3455 (mul (simplify (list '($pochhammer) (sub 1 b) index))
3456 (power z index))
3457 (mul (add index a)
3458 (simplify (list '(mfactorial) index))))
3459 index 0 (sub b 1)))))
3461 ((and $beta_expand (mplusp a) (integerp (cadr a)) (plusp (cadr a)))
3462 (let ((n (cadr a))
3463 (a (simplify (cons '(mplus) (cddr a)))))
3464 (sub
3465 (mul
3466 (div
3467 (simplify (list '($pochhammer) a n))
3468 (simplify (list '($pochhammer) (add a b) n)))
3469 (ftake '%beta_incomplete a b z))
3470 (mul
3471 (power (add a b n -1) -1)
3472 (let ((index (gensumindex)))
3473 (simpsum1
3474 (mul
3475 (div
3476 (simplify (list '($pochhammer)
3477 (add 1 (mul -1 a) (mul -1 n))
3478 index))
3479 (simplify (list '($pochhammer)
3480 (add 2 (mul -1 a) (mul -1 b) (mul -1 n))
3481 index)))
3482 (mul (power (sub 1 z) b)
3483 (power z (add a n (mul -1 index) -1))))
3484 index 0 (sub n 1)))))))
3486 ((and $beta_expand (mplusp a) (integerp (cadr a)) (minusp (cadr a)))
3487 (let ((n (- (cadr a)))
3488 (a (simplify (cons '(mplus) (cddr a)))))
3489 (sub
3490 (mul
3491 (div
3492 (simplify (list '($pochhammer) (add 1 (mul -1 a) (mul -1 b)) n))
3493 (simplify (list '($pochhammer) (sub 1 a) n)))
3494 (ftake '%beta_incomplete a b z))
3495 (mul
3496 (div
3497 (simplify
3498 (list '($pochhammer) (add 2 (mul -1 a) (mul -1 b)) (sub n 1)))
3499 (simplify (list '($pochhammer) (sub 1 a) n)))
3500 (let ((index (gensumindex)))
3501 (simpsum1
3502 (mul
3503 (div
3504 (simplify (list '($pochhammer) (sub 1 a) index))
3505 (simplify (list '($pochhammer)
3506 (add 2 (mul -1 a) (mul -1 b))
3507 index)))
3508 (mul (power (sub 1 z) b)
3509 (power z (add a (mul -1 index) -1))))
3510 index 0 (sub n 1)))))))
3513 (give-up)))))
3515 (defun beta-incomplete-expand-negative-integer (a b z)
3516 (mul
3517 (power z a)
3518 (let ((index (gensumindex)) ($simpsum t))
3519 (simpsum1
3520 (div
3521 (mul (simplify (list '($pochhammer) (sub 1 b) index))
3522 (power z index))
3523 (mul (add index a) (simplify (list '(mfactorial) index))))
3524 index 0 (sub b 1)))))
3526 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3528 (defun beta-incomplete (a b z)
3529 (cond
3530 ((eq ($sign (sub (mul ($realpart z) ($realpart (add a b 2)))
3531 ($realpart (add a 1))))
3532 '$pos)
3533 ($rectform
3534 (sub
3535 (simplify (list '($beta) a b))
3536 (to (numeric-beta-incomplete b a (sub 1.0 z))))))
3538 (to (numeric-beta-incomplete a b z)))))
3540 (defun numeric-beta-incomplete (a b z)
3541 (when *debug-gamma*
3542 (format t "~&NUMERIC-BETA-INCOMPLETE enters continued fractions~%"))
3543 (let ((a (bigfloat:to a))
3544 (b (bigfloat:to b))
3545 (z (bigfloat:to z)))
3546 (do* ((beta-maxit *beta-incomplete-maxit*)
3547 (beta-eps *beta-incomplete-eps*)
3548 (beta-min (bigfloat:* beta-eps beta-eps))
3549 (ab (bigfloat:+ a b))
3550 (ap (bigfloat:+ a 1.0))
3551 (am (bigfloat:- a 1.0))
3552 (c 1.0)
3553 (d (bigfloat:- 1.0 (bigfloat:/ (bigfloat:* z ab) ap)))
3554 (d (if (bigfloat:< (bigfloat:abs d) beta-min) beta-min d))
3555 (d (bigfloat:/ 1.0 d))
3556 (h d)
3557 (aa 0.0)
3558 (de 0.0)
3559 (m2 0)
3560 (m 1 (+ m 1)))
3561 ((> m beta-maxit)
3562 (merror (intl:gettext "beta_incomplete: continued fractions failed for beta_incomplete(~:M, ~:M, ~:M).") a b z))
3563 (setq m2 (+ m m))
3564 (setq aa (bigfloat:/ (bigfloat:* m z (bigfloat:- b m))
3565 (bigfloat:* (bigfloat:+ am m2)
3566 (bigfloat:+ a m2))))
3567 (setq d (bigfloat:+ 1.0 (bigfloat:* aa d)))
3568 (when (bigfloat:< (bigfloat:abs d) beta-min) (setq d beta-min))
3569 (setq c (bigfloat:+ 1.0 (bigfloat:/ aa c)))
3570 (when (bigfloat:< (bigfloat:abs c) beta-min) (setq c beta-min))
3571 (setq d (bigfloat:/ 1.0 d))
3572 (setq h (bigfloat:* h d c))
3573 (setq aa (bigfloat:/ (bigfloat:* -1
3574 (bigfloat:+ a m)
3575 (bigfloat:+ ab m) z)
3576 (bigfloat:* (bigfloat:+ a m2)
3577 (bigfloat:+ ap m2))))
3578 (setq d (bigfloat:+ 1.0 (bigfloat:* aa d)))
3579 (when (bigfloat:< (bigfloat:abs d) beta-min) (setq d beta-min))
3580 (setq c (bigfloat:+ 1.0 (bigfloat:/ aa c)))
3581 (when (bigfloat:< (bigfloat:abs c) beta-min) (setq c beta-min))
3582 (setq d (bigfloat:/ 1.0 d))
3583 (setq de (bigfloat:* d c))
3584 (setq h (bigfloat:* h de))
3585 (when (bigfloat:< (bigfloat:abs (bigfloat:- de 1.0)) beta-eps)
3586 (when *debug-gamma*
3587 (format t "~&Continued fractions finished.~%")
3588 (format t "~& z = ~A~%" z)
3589 (format t "~& a = ~A~%" a)
3590 (format t "~& b = ~A~%" b)
3591 (format t "~& h = ~A~%" h))
3592 (return
3593 (let ((result
3594 (bigfloat:/
3595 (bigfloat:* h
3596 (bigfloat:expt z a)
3597 (bigfloat:expt (bigfloat:- 1.0 z) b)) a)))
3598 (when *debug-gamma*
3599 (format t "~& result = ~A~%" result))
3600 result))))))
3602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3604 ;;; Implementation of the Generalized Incomplete Beta function
3606 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3608 ;;; beta_incomplete_generalized distributes over bags
3610 (defprop %beta_incomplete_generalized (mlist $matrix mequal) distribute_over)
3612 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3614 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
3615 ;;; but not on the negative real axis and for z1 or z2 real and > 1.
3616 ;;; We support a conjugate-function which test these cases.
3618 (defprop %beta_incomplete_generalized
3619 conjugate-beta-incomplete-generalized conjugate-function)
3621 (defun conjugate-beta-incomplete-generalized (args)
3622 (let ((a (first args))
3623 (b (second args))
3624 (z1 (third args))
3625 (z2 (fourth args)))
3626 (cond ((and (off-negative-real-axisp z1)
3627 (not (and (zerop1 ($imagpart z1))
3628 (eq ($sign (sub ($realpart z1) 1)) '$pos)))
3629 (off-negative-real-axisp z2)
3630 (not (and (zerop1 ($imagpart z2))
3631 (eq ($sign (sub ($realpart z2) 1)) '$pos))))
3632 (simplify
3633 (list
3634 '(%beta_incomplete_generalized)
3635 (simplify (list '($conjugate) a))
3636 (simplify (list '($conjugate) b))
3637 (simplify (list '($conjugate) z1))
3638 (simplify (list '($conjugate) z2)))))
3640 (list
3641 '($conjugate simp)
3642 (simplify (list '(%beta_incomplete_generalized)
3643 a b z1 z2)))))))
3645 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3647 (defprop %beta_incomplete_generalized
3648 ((a b z1 z2)
3649 ;; Derivative wrt a
3650 ((mplus)
3651 ((mtimes) -1
3652 ((%beta_incomplete) a b z1)
3653 ((%log) z1))
3654 ((mtimes)
3655 ((mexpt) ((%gamma) a) 2)
3656 ((mplus)
3657 ((mtimes)
3658 (($hypergeometric_regularized)
3659 ((mlist) a a ((mplus) 1 ((mtimes) -1 b)))
3660 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
3662 ((mexpt) z1 a))
3663 ((mtimes) -1
3664 (($hypergeometric_regularized)
3665 ((mlist) a a ((mplus) 1 ((mtimes) -1 b)))
3666 ((mlist) ((mplus) 1 a) ((mplus) 1 a))
3668 ((mexpt) z2 a))))
3669 ((mtimes) ((%beta_incomplete) a b z2) ((%log) z2)))
3670 ;; Derivative wrt b
3671 ((mplus)
3672 ((mtimes)
3673 ((%beta_incomplete) b a ((mplus) 1 ((mtimes) -1 z1)))
3674 ((%log) ((mplus) 1 ((mtimes) -1 z1))))
3675 ((mtimes) -1
3676 ((%beta_incomplete) b a ((mplus) 1 ((mtimes) -1 z2)))
3677 ((%log) ((mplus) 1 ((mtimes) -1 z2))))
3678 ((mtimes) -1
3679 ((mexpt) ((%gamma) b) 2)
3680 ((mplus)
3681 ((mtimes)
3682 (($hypergeometric_regularized)
3683 ((mlist) b b ((mplus) 1 ((mtimes) -1 a)))
3684 ((mlist) ((mplus) 1 b) ((mplus) 1 b))
3685 ((mplus) 1 ((mtimes) -1 z1)))
3686 ((mexpt) ((mplus) 1 ((mtimes) -1 z1)) b))
3687 ((mtimes) -1
3688 (($hypergeometric_regularized)
3689 ((mlist) b b ((mplus) 1 ((mtimes) -1 a)))
3690 ((mlist) ((mplus) 1 b) ((mplus) 1 b))
3691 ((mplus) 1 ((mtimes) -1 z2)))
3692 ((mexpt) ((mplus) 1 ((mtimes) -1 z2)) b)))))
3693 ;; The derivative wrt z1
3694 ((mtimes) -1
3695 ((mexpt)
3696 ((mplus) 1 ((mtimes) -1 z1))
3697 ((mplus) -1 b))
3698 ((mexpt) z1 ((mplus) -1 a)))
3699 ;; The derivative wrt z2
3700 ((mtimes)
3701 ((mexpt)
3702 ((mplus) 1 ((mtimes) -1 z2))
3703 ((mplus) -1 b))
3704 ((mexpt) z2 ((mplus) -1 a))))
3705 grad)
3707 ;;; Integral of the Incomplete Beta function
3709 (defprop %beta_incomplete_generalized
3710 ((a b z1 z2)
3711 nil
3713 ;; Integral wrt z1
3714 ((mplus)
3715 ((%beta_incomplete) ((mplus) 1 a) b z1)
3716 ((mtimes) ((%beta_incomplete_generalized) a b z1 z2) z1))
3717 ;; Integral wrt z2
3718 ((mplus)
3719 ((mtimes) -1
3720 ((%beta_incomplete) ((mplus) 1 a) b z2))
3721 ((mtimes) ((%beta_incomplete_generalized) a b z1 z2) z2)))
3722 integral)
3724 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3726 (def-simplifier beta_incomplete_generalized (a b z1 z2)
3727 (let (($simpsum t))
3728 (cond
3730 ;; Check for specific values
3732 ((zerop1 z2)
3733 (let ((sgn ($sign ($realpart a))))
3734 (cond ((eq sgn '$neg)
3735 (simp-domain-error
3736 (intl:gettext
3737 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3738 a b z1 z2))
3739 ((member sgn '($pos $pz))
3740 (mul -1 (ftake '%beta_incomplete a b z1)))
3742 (give-up)))))
3744 ((zerop1 z1)
3745 (let ((sgn ($sign ($realpart a))))
3746 (cond ((eq sgn '$neg)
3747 (simp-domain-error
3748 (intl:gettext
3749 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3750 a b z1 z2))
3751 ((member sgn '($pos $pz))
3752 (mul -1 (ftake '%beta_incomplete a b z2)))
3754 (give-up)))))
3756 ((and (onep1 z2) (or (not (mnump a)) (not (mnump b)) (not (mnump z1))))
3757 (let ((sgn ($sign ($realpart b))))
3758 (cond ((member sgn '($pos $pz))
3759 (sub (simplify (list '($beta) a b))
3760 (ftake '%beta_incomplete a b z1)))
3762 (give-up)))))
3764 ((and (onep1 z1) (or (not (mnump a)) (not (mnump b)) (not (mnump z2))))
3765 (let ((sgn ($sign ($realpart b))))
3766 (cond ((member sgn '($pos $pz))
3767 (sub (ftake '%beta_incomplete a b z2)
3768 (simplify (list '($beta) a b))))
3770 (give-up)))))
3772 ;; Check for numerical evaluation in Float or Bigfloat precision
3774 ((complex-float-numerical-eval-p a b z1 z2)
3775 (let ((*beta-incomplete-eps* (bigfloat:epsilon ($float 1.0))))
3776 (sub (beta-incomplete ($float a) ($float b) ($float z2))
3777 (beta-incomplete ($float a) ($float b) ($float z1)))))
3779 ((complex-bigfloat-numerical-eval-p a b z1 z2)
3780 (let ((*beta-incomplete-eps*
3781 (bigfloat:epsilon (bigfloat:bigfloat 1.0))))
3782 (sub (beta-incomplete ($bfloat a) ($bfloat b) ($bfloat z2))
3783 (beta-incomplete ($bfloat a) ($bfloat b) ($bfloat z1)))))
3785 ;; Check for argument simplifications and transformations
3787 ((and (integerp a) (plusp a))
3788 (mul
3789 (simplify (list '($beta) a b))
3790 (sub
3791 (mul
3792 (power (sub 1 z1) b)
3793 (let ((index (gensumindex)))
3794 (simpsum1
3795 (div
3796 (mul
3797 (simplify (list '($pochhammer) b index))
3798 (power z1 index))
3799 (simplify (list '(mfactorial) index)))
3800 index 0 (sub a 1))))
3801 (mul
3802 (power (sub 1 z2) b)
3803 (let ((index (gensumindex)))
3804 (simpsum1
3805 (div
3806 (mul
3807 (simplify (list '($pochhammer) b index))
3808 (power z2 index))
3809 (simplify (list '(mfactorial) index)))
3810 index 0 (sub a 1)))))))
3812 ((and (integerp b) (plusp b))
3813 (mul
3814 (simplify (list '($beta) a b))
3815 (sub
3816 (mul
3817 (power z2 a)
3818 (let ((index (gensumindex)))
3819 (simpsum1
3820 (div
3821 (mul
3822 (simplify (list '($pochhammer) a index))
3823 (power (sub 1 z2) index))
3824 (simplify (list '(mfactorial) index)))
3825 index 0 (sub b 1))))
3826 (mul
3827 (power z1 a)
3828 (let ((index (gensumindex)))
3829 (simpsum1
3830 (div
3831 (mul
3832 (simplify (list '($pochhammer) a index))
3833 (power (sub 1 z1) index))
3834 (simplify (list '(mfactorial) index)))
3835 index 0 (sub b 1)))))))
3837 ((and $beta_expand (mplusp a) (integerp (cadr a)) (plusp (cadr a)))
3838 (let ((n (cadr a))
3839 (a (simplify (cons '(mplus) (cddr a)))))
3840 (add
3841 (mul
3842 (div
3843 (simplify (list '($pochhammer) a n))
3844 (simplify (list '($pochhammer) (add a b) n)))
3845 (take '(%beta_incomplete_generalized) a b z1 z2))
3846 (mul
3847 (power (add a b n -1) -1)
3848 (let ((index (gensumindex)))
3849 (simpsum1
3850 (mul
3851 (div
3852 (simplify (list '($pochhammer)
3853 (add 1 (mul -1 a) (mul -1 n))
3854 index))
3855 (simplify (list '($pochhammer)
3856 (add 2 (mul -1 a) (mul -1 b) (mul -1 n))
3857 index)))
3858 (sub
3859 (mul (power (sub 1 z1) b)
3860 (power z1 (add a n (mul -1 index) -1)))
3861 (mul (power (sub 1 z2) b)
3862 (power z2 (add a n (mul -1 index) -1)))))
3863 index 0 (sub n 1)))))))
3865 ((and $beta_expand (mplusp a) (integerp (cadr a)) (minusp (cadr a)))
3866 (let ((n (- (cadr a)))
3867 (a (simplify (cons '(mplus) (cddr a)))))
3868 (sub
3869 (mul
3870 (div
3871 (simplify (list '($pochhammer) (add 1 (mul -1 a) (mul -1 b)) n))
3872 (simplify (list '($pochhammer) (sub 1 a) n)))
3873 (take '(%beta_incomplete_generalized) a b z1 z2))
3874 (mul
3875 (div
3876 (simplify
3877 (list '($pochhammer) (add 2 (mul -1 a) (mul -1 b)) (sub n 1)))
3878 (simplify (list '($pochhammer) (sub 1 a) n)))
3879 (let ((index (gensumindex)))
3880 (simpsum1
3881 (mul
3882 (div
3883 (simplify (list '($pochhammer) (sub 1 a) index))
3884 (simplify (list '($pochhammer)
3885 (add 2 (mul -1 a) (mul -1 b))
3886 index)))
3887 (sub
3888 (mul (power (sub 1 z2) b)
3889 (power z2 (add a (mul -1 index) -1)))
3890 (mul (power (sub 1 z1) b)
3891 (power z1 (add a (mul -1 index) -1)))))
3892 index 0 (sub n 1)))))))
3895 (give-up)))))
3897 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3899 ;;; Implementation of the Regularized Incomplete Beta function
3901 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3903 ;;; beta_incomplete_regularized distributes over bags
3905 (defprop %beta_incomplete_regularized (mlist $matrix mequal) distribute_over)
3907 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3909 (defprop %beta_incomplete_regularized
3910 ((a b z)
3911 ;; Derivative wrt a
3912 ((mplus)
3913 ((mtimes) -1
3914 ((%gamma) a)
3915 (($hypergeometric_regularized)
3916 ((mlist) a a ((mplus) 1 ((mtimes) -1 b)))
3917 ((mlist) ((mplus) 1 a) ((mplus) 1 a)) z)
3918 ((mexpt) ((%gamma) b) -1)
3919 ((%gamma) ((mplus) a b))
3920 ((mexpt) z a))
3921 ((mtimes)
3922 ((%beta_incomplete_regularized) a b z)
3923 ((mplus)
3924 ((mtimes) -1 ((mqapply) (($psi array) 0) a))
3925 ((mqapply) (($psi array) 0) ((mplus) a b))
3926 ((%log) z))))
3927 ;; Derivative wrt b
3928 ((mplus)
3929 ((mtimes)
3930 ((%beta_incomplete_regularized) b a ((mplus) 1 ((mtimes) -1 z)))
3931 ((mplus)
3932 ((mqapply) (($psi array) 0) b)
3933 ((mtimes) -1 ((mqapply) (($psi array) 0) ((mplus) a b)))
3934 ((mtimes) -1 ((%log) ((mplus) 1 ((mtimes) -1 z))))))
3935 ((mtimes)
3936 ((mexpt) ((%gamma) a) -1)
3937 ((%gamma) b)
3938 ((%gamma) ((mplus) a b))
3939 (($hypergeometric_regularized)
3940 ((mlist) b b ((mplus) 1 ((mtimes) -1 a)))
3941 ((mlist) ((mplus) 1 b) ((mplus) 1 b))
3942 ((mplus) 1 ((mtimes) -1 z)))
3943 ((mexpt) ((mplus) 1 ((mtimes) -1 z)) b)))
3944 ;; The derivative wrt z
3945 ((mtimes)
3946 ((mexpt) (($beta) a b) -1)
3947 ((mexpt) ((mplus) 1 ((mtimes) -1 z)) ((mplus) -1 b))
3948 ((mexpt) z ((mplus) -1 a))))
3949 grad)
3951 ;;; Integral of the Generalized Incomplete Beta function
3953 (defprop %beta_incomplete_regularized
3954 ((a b z)
3955 nil
3957 ;; Integral wrt z
3958 ((mplus)
3959 ((mtimes) -1 a
3960 ((%beta_incomplete_regularized) ((mplus) 1 a) b z)
3961 ((mexpt) ((mplus) a b) -1))
3962 ((mtimes) ((%beta_incomplete_regularized) a b z) z)))
3963 integral)
3965 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3967 (def-simplifier beta_incomplete_regularized (a b z)
3968 (let (($simpsum t))
3969 (cond
3971 ;; Check for specific values
3973 ((zerop1 z)
3974 (let ((sgn ($sign ($realpart a))))
3975 (cond ((eq sgn '$neg)
3976 (simp-domain-error
3977 (intl:gettext
3978 "beta_incomplete_regularized: beta_incomplete_regularized(~:M,~:M,~:M) is undefined.")
3979 a b z))
3980 ((member sgn '($pos $pz))
3983 (give-up)))))
3985 ((and (onep1 z)
3986 (or (not (mnump a))
3987 (not (mnump b))
3988 (not (mnump z))))
3989 (let ((sgn ($sign ($realpart b))))
3990 (cond ((member sgn '($pos $pz))
3993 (give-up)))))
3995 ((and (integer-representation-p b)
3996 (if ($bfloatp b) (minusp (cadr b)) (minusp b)) )
3997 ;; Problem: for b a negative integer the Regularized Incomplete
3998 ;; Beta function is defined to be zero. BUT: When we calculate
3999 ;; e.g. beta_incomplete(1.0,-2.0,1/2)/beta(1.0,-2.0) we get the
4000 ;; result -3.0, because beta_incomplete and beta are defined for
4001 ;; for this case. How do we get a consistent behaviour?
4004 ((and (integer-representation-p a)
4005 (if ($bfloatp a) (minusp (cadr a)) (minusp a)) )
4006 (cond
4007 ;; TODO: The following line does not work for bigfloats.
4008 ((and (integer-representation-p b) (<= b (- a)))
4009 ;; Does $beta_incomplete or simpbeta underflow in this case?
4010 (div (ftake '%beta_incomplete a b z)
4011 (simplify (list '($beta) a b))))
4013 1)))
4015 ;; Check for numerical evaluation in Float or Bigfloat precision
4017 ((complex-float-numerical-eval-p a b z)
4018 (let ((*beta-incomplete-eps* (bigfloat:epsilon ($float 1.0)))
4019 beta ibeta )
4020 (setq a ($float a) b ($float b))
4021 (if (or (< ($abs (setq beta (simplify (list '($beta) a b)))) 1e-307)
4022 (< ($abs (setq ibeta (beta-incomplete a b ($float z)))) 1e-307) )
4023 ;; In case of underflow (see bug #2999) or precision loss use bigfloats
4024 ;; and emporarily give some extra precision but avoid fpprec dependency.
4025 ;; Is this workaround correct for complex values?
4026 (let ((fpprec 70))
4027 ($float (take '(%beta_incomplete_regularized) ($bfloat a) ($bfloat b) z)) )
4028 ($rectform (div ibeta beta)) )))
4030 ((complex-bigfloat-numerical-eval-p a b z)
4031 (let ((*beta-incomplete-eps*
4032 (bigfloat:epsilon (bigfloat:bigfloat 1.0))))
4033 (setq a ($bfloat a) b ($bfloat b))
4034 ($rectform
4035 (div (beta-incomplete a b ($bfloat z))
4036 (simplify (list '($beta) a b))))))
4038 ;; Check for argument simplifications and transformations
4040 ((and (integerp b) (plusp b))
4041 (div (ftake '%beta_incomplete a b z)
4042 (simplify (list '($beta) a b))))
4044 ((and (integerp a) (plusp a))
4045 (div (ftake '%beta_incomplete a b z)
4046 (simplify (list '($beta) a b))))
4048 ((and $beta_expand (mplusp a) (integerp (cadr a)) (plusp (cadr a)))
4049 (let ((n (cadr a))
4050 (a (simplify (cons '(mplus) (cddr a)))))
4051 (sub
4052 (take '(%beta_incomplete_regularized) a b z)
4053 (mul
4054 (power (add a b n -1) -1)
4055 (power (simplify (list '($beta) (add a n) b)) -1)
4056 (let ((index (gensumindex)))
4057 (simpsum1
4058 (mul
4059 (div
4060 (simplify (list '($pochhammer)
4061 (add 1 (mul -1 a) (mul -1 n))
4062 index))
4063 (simplify (list '($pochhammer)
4064 (add 2 (mul -1 a) (mul -1 b) (mul -1 n))
4065 index)))
4066 (power (sub 1 z) b)
4067 (power z (add a n (mul -1 index) -1)))
4068 index 0 (sub n 1)))))))
4070 ((and $beta_expand (mplusp a) (integerp (cadr a)) (minusp (cadr a)))
4071 (let ((n (- (cadr a)))
4072 (a (simplify (cons '(mplus) (cddr a)))))
4073 (sub
4074 (take '(%beta_incomplete_regularized) a b z)
4075 (mul
4076 (power (add a b -1) -1)
4077 (power (simplify (list '($beta) a b)) -1)
4078 (let ((index (gensumindex)))
4079 (simpsum1
4080 (mul
4081 (div
4082 (simplify (list '($pochhammer) (sub 1 a) index))
4083 (simplify (list '($pochhammer)
4084 (add 2 (mul -1 a) (mul -1 b))
4085 index)))
4086 (power (sub 1 z) b)
4087 (power z (add a (mul -1 index) -1)))
4088 index 0 (sub n 1)))))))
4091 (give-up)))))
4093 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;