1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Double Factorial, Incomplete Gamma function, ...
5 ;;; This file will be extended with further functions related to the
6 ;;; Factorial and Gamma functions.
8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10 ;;; This file contains the following Maxima User functions:
12 ;;; double_factorial(z)
14 ;;; gamma_incomplete(a,z)
15 ;;; gamma_incomplete_generalized(a,z1,z2)
16 ;;; gamma_incomplete_regularized(a,z)
23 ;;; erf_generalized(z1,z2)
31 ;;; beta_incomplete(a,b,z)
32 ;;; beta_incomplete_generalized(a,b,z1,z2)
33 ;;; beta_incomplete_regularized(a,b,z)
35 ;;; Maxima User variable:
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
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
49 ;;; Maxima User variable (not definied in this file):
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
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.
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.
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
71 ;;; Copyright (C) 2008 Dieter Kaiser
72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
76 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
78 (defmvar $erf_representation nil
79 "When not false, error functions are transformed to erf, erfc, or erfi
80 depending on the value of $erf_representation."
81 ;; Need to use the noun form of these.
82 :setting-list
(nil t %erf %erfc %erfi
))
84 (defmvar $erf_%iargs nil
85 "When T erf and erfi simplifies for an imaginary argument.")
87 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
88 ;;; The following functions test if numerical evaluation has to be done.
89 ;;; The functions should help to test for numerical evaluation more consistent
90 ;;; and without complicated conditional tests including more than one or two
93 ;;; The functions take a list of arguments. All arguments have to be a CL or
94 ;;; Maxima number. If all arguments are numbers we have two cases:
95 ;;; 1. $numer is T we return T. The function has to be evaluated numerically.
96 ;;; 2. One of the args is a float or a bigfloat. Evaluate numerically.
97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99 ;;; Test for numerically evaluation in float precision
101 (defun float-numerical-eval-p (&rest args
)
104 (when (not (float-or-rational-p ll
))
105 (return-from float-numerical-eval-p nil
))
106 (when (floatp ll
) (setq flag t
)))
107 (if (or $numer flag
) t nil
)))
109 ;;; Test for numerically evaluation in complex float precision
111 (defun complex-float-numerical-eval-p (&rest args
)
112 "Determine if ARGS consists of numerical values by determining if
113 the real and imaginary parts of each arg are nuemrical (but not
114 bigfloats). A non-NIL result is returned if at least one of args is
115 a floating-point value or if numer is true. If the result is
116 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P"
119 (multiple-value-bind (bool rll ill
)
120 (complex-number-p ll
'float-or-rational-p
)
122 (return-from complex-float-numerical-eval-p nil
))
123 ;; Always save the result from complex-number-p. But for backward
124 ;; compatibility, only set the flag if any item is a float.
125 (push (add rll
(mul ill
'$%i
)) values
)
126 (setf flag
(or flag
(or (floatp rll
) (floatp ill
))))))
127 (when (or $numer flag
)
128 ;; Return the values in the same order as the args!
131 ;;; Test for numerically evaluation in bigfloat precision
133 (defun bigfloat-numerical-eval-p (&rest args
)
136 (when (not (bigfloat-or-number-p ll
))
137 (return-from bigfloat-numerical-eval-p nil
))
140 (if (or $numer flag
) t nil
)))
142 ;;; Test for numerically evaluation in complex bigfloat precision
144 (defun complex-bigfloat-numerical-eval-p (&rest args
)
145 "Determine if ARGS consists of numerical values by determining if
146 the real and imaginary parts of each arg are nuemrical (including
147 bigfloats). A non-NIL result is returned if at least one of args is
148 a floating-point value or if numer is true. If the result is
149 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P."
153 (multiple-value-bind (bool rll ill
)
154 (complex-number-p ll
'bigfloat-or-number-p
)
156 (return-from complex-bigfloat-numerical-eval-p nil
))
157 ;; Always save the result from complex-number-p. But for backward
158 ;; compatibility, only set the flag if any item is a bfloat.
159 (push (add rll
(mul ill
'$%i
)) values
)
160 (when (or ($bfloatp rll
) ($bfloatp ill
))
162 (when (or $numer flag
)
163 ;; Return the values in the same order as the args!
166 ;;; Test for numerical evaluation in any precision, real or complex.
167 (defun numerical-eval-p (&rest args
)
168 (or (apply 'float-numerical-eval-p args
)
169 (apply 'complex-float-numerical-eval-p args
)
170 (apply 'bigfloat-numerical-eval-p args
)
171 (apply 'complex-bigfloat-numerical-eval-p args
)))
173 ;;; Check for an integer or a float or bigfloat representation. When we
174 ;;; have a float or bigfloat representation return the integer value.
176 (defun integer-representation-p (x)
178 (cond ((integerp x
) x
)
179 ((and (floatp x
) (= 0 (nth-value 1 (truncate x
))))
180 (nth-value 0 (truncate x
)))
182 (eq ($sign
(sub (setq val
($truncate x
)) x
)) '$zero
))
186 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
188 ;;; The changes to the parser to connect the operator !! to double_factorial(z)
190 ;(def-mheader |$!!| (%double_factorial))
192 ;(def-led (|$!!| 160.) (op left)
195 ; (convert left '$expr)))
197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
199 ;;; The implementation of the function Double factorial
201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
203 ;;; Double factorial distributes over bags
205 (defprop %double_factorial
(mlist $matrix mequal
) distribute_over
)
207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209 ;;; Double factorial has mirror symmetry
211 (defprop %double_factorial t commutes-with-conjugate
)
213 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
215 ;;; Differentiation of Double factorial
217 (defprop %double_factorial
221 ((%double_factorial
) z
)
226 ((mplus) 1 ((mtimes) ((rat) 1 2) z
)))
229 ((%log
) ((mtimes) 2 ((mexpt) $%pi -
1)))
230 ((%sin
) ((mtimes) $%pi z
))))))
233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
235 ;;; Double factorial is a simplifying function
237 (def-simplifier double_factorial
(z)
239 ((and (fixnump z
) (> z -
1) (or (minusp $factlim
) (< z $factlim
)))
240 ;; Positive Integer less then $factlim or $factlim is -1. Call gfact.
241 (gfact z
(floor (/ z
2)) 2))
245 (zerop1 (sub (simplify (list '(%truncate
) (div z
2))) (div z
2))))
246 ;; Even negative integer or real representation. Not defined.
249 "double_factorial: double_factorial(~:M) is undefined.") z
))
251 ((or (integerp z
) ; at this point odd negative integer. Evaluate.
252 (complex-float-numerical-eval-p z
))
254 ((and (integerp z
) (= z -
1)) 1) ; Special cases -1 and -3
255 ((and (integerp z
) (= z -
3)) -
1)
257 ;; Odd negative integer, float or complex float.
260 (complex ($float
($realpart z
)) ($float
($imagpart z
))))))))
262 ((and (not (ratnump z
))
263 (complex-bigfloat-numerical-eval-p z
))
264 ;; bigfloat or complex bigfloat.
265 (bfloat-double-factorial
266 (add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))
268 ;; double_factorial(inf) -> inf
271 ((and $factorial_expand
275 (n (simplify (cons '(mplus) (cddr z
)))))
278 ;; Special case double_factorial(n-1)
279 ;; Not sure if this simplification is useful.
280 (div (simplify (list '(mfactorial) n
))
281 (simplify (list '(%double_factorial
) n
))))
282 ((= k
(* 2 (truncate (/ k
2))))
283 ;; Special case double_factorial(2*k+n), k integer
285 ($factor
; we get more simple expression when factoring
288 (simplify (list '($pochhammer
) (add (div n
2) 1) k
))
289 (simplify (list '(%double_factorial
) n
)))))
296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
297 ;;; Double factorial for a complex float argument. The result is a CL complex.
298 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
300 (defun double-factorial (z)
301 (let ((pival (float pi
)))
305 (/ (- 1 (cos (* pival z
))) 4))
307 (gamma-lanczos (+ 1 (/ z
2))))))
309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
310 ;;; Double factorial for a bigfloat or complex bigfloat argument
311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
313 (defun bfloat-double-factorial (z)
314 (let* ((pival ($bfloat
'$%pi
))
315 (bigfloat1 ($bfloat bigfloatone
))
316 (bigfloat2 (add bigfloat1 bigfloat1
))
317 (bigfloat4 (add bigfloat2 bigfloat2
))
321 (cdiv bigfloat2 pival
)
323 (simplify (list '(%cos
) (cmul pival z
)))) bigfloat4
))
325 (cpower bigfloat2
(cdiv z bigfloat2
))
326 (simplify (list '(%gamma
) (add bigfloat1
(cdiv z bigfloat2
))))))))
328 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
330 ;;; The implementation of the Incomplete Gamma function
337 ;;; gamma_incomplete(a, z) = I t %e dt
342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
344 (defvar *debug-gamma
* nil
)
346 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
349 ;;; Incomplete Gamma distributes over bags
351 (defprop %gamma_incomplete
(mlist $matrix mequal
) distribute_over
)
353 ;;; Incomplete Gamma function has not mirror symmetry for z on the negative
354 ;;; real axis. We support a conjugate-function which test this case.
356 (defprop %gamma_incomplete conjugate-gamma-incomplete conjugate-function
)
358 (defun conjugate-gamma-incomplete (args)
359 (let ((a (first args
)) (z (second args
)))
360 (cond ((off-negative-real-axisp z
)
361 ;; Definitely not on the negative real axis for z. Mirror symmetry.
365 (simplify (list '($conjugate
) a
))
366 (simplify (list '($conjugate
) z
)))))
368 ;; On the negative real axis or no information. Unsimplified.
371 (simplify (list '(%gamma_incomplete
) a z
)))))))
373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
375 ;;; Derivative of the Incomplete Gamma function
377 (putprop '%gamma_incomplete
380 (cond ((member ($sign a
) '($pos $pz
))
381 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2
382 ;; function and the Generalized Incomplete Gamma function
383 ;; (functions.wolfram.com), only for a>0.
386 ((mexpt) ((%gamma
) ,a
) 2)
388 (($hypergeometric_regularized
)
390 ((mlist) ((mplus) 1 ,a
) ((mplus) 1 ,a
))
393 ((%gamma_incomplete_generalized
) ,a
0 ,z
)
397 ((mqapply) (($psi array
) 0) ,a
))))
399 ;; No derivative. Maxima generates a noun form.
401 ;; The derivative wrt z
403 ((mexpt) $%e
((mtimes) -
1 z
))
404 ((mexpt) z
((mplus) -
1 a
))))
407 ;;; Integral of the Incomplete Gamma function
409 (defprop %gamma_incomplete
413 ((mtimes) -
1 ((%gamma_incomplete
) ((mplus) 1 a
) z
))
414 ((mtimes) ((%gamma_incomplete
) a z
) z
)))
417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
419 ;;; We support a simplim%function. The function is looked up in simplimit and
420 ;;; handles specific values of the function.
422 (defprop %gamma_incomplete simplim%gamma_incomplete simplim%function
)
424 (defun simplim%gamma_incomplete
(expr var val
)
425 ;; Set preserve-direction to true and find the limit of each argument.
426 (let* ((preserve-direction t
)
427 (a (limit (cadr expr
) var val
'think
))
428 (z (limit (caddr expr
) var val
'think
)))
430 ;; z in {minf, inf, infinity}, use http://dlmf.nist.gov/8.11#i
431 ((or (eq z
'$infinity
)
434 ;; Revert a & z to the arguments of gamma_incomplete.
436 (setq z
(caddr expr
))
437 ;; Use gamma_incomplete(a,z) = z^(a-1)/exp(z) + ... for
438 ;; fixed a and |z| --> inf. Unfortunately, limit(x*exp(%i*x),x,inf) = und.
439 ;; And that makes limit(gamma_incomplete(2, -%i*x), x, inf) = und, not
440 ;; infinity (this is a test in rtest_limit) But this bug needs to be fixed
441 ;; elsewhere. When a isn't fixed, give up.
443 (limit (div (ftake 'mexpt z
(sub a
1)) (ftake 'mexpt
'$%e z
)) var val
'think
)
446 ((and (eql a
0) (eq t
(mgrp 0 z
)))
447 (let ((im (behavior (cdr (risplit (caddr expr
))) var val
)))
449 (sub (mul '$%i
'$%pi
) (ftake '%expintegral_ei
(mul -
1 z
))))
451 (sub (mul -
1 '$%i
'$%pi
) (ftake '%expintegral_ei
(mul -
1 z
))))
452 (t (throw 'limit nil
)))))
454 ;; z in {zerob, 0, zeroa}.
455 ((and (freeof var a
) (or (eql z
0) (eq z
'$zeroa
) (eq z
'$zerob
)))
456 ;; Two cases: (i) a <= 0 & integer (ii) a not a negative integer.
457 ;; Revert a & z to the arguments of gamma_incomplete.
459 (setq z
(caddr expr
))
460 (cond ((and ($featurep a
'$integer
) (eq t
(mgqp 0 a
)))
461 ;; gamma_incomplete(a,n) = - (-1)^(-a) log(z)/(-a)! + ...
463 (limit (div (mul -
1 (ftake 'mexpt -
1 a
) (ftake '%log z
))
464 (ftake 'mfactorial a
)) var val
'think
))
466 (limit (sub (ftake '%gamma a
) (div (ftake 'mexpt z a
) a
)) var val
'think
))))
467 ;; z is on the branch cut. We need to know if the imaginary part of
468 ;; (caddr exp) approaches zero from above or below. The incomplete
469 ;; gamma function is continuous from above its branch cut.
472 (let ((im (behavior (cdr (risplit (caddr expr
))) var val
)))
473 (cond ((eql im
1) ; use direct substitution
474 (ftake '%gamma_incomplete a z
))
478 (mul (ftake 'mexpt
'$%e
(mul -
2 '$%i
'$%pi a
))
479 (sub (ftake '%gamma a
) (ftake '%gamma_incomplete a z
)))))
481 (throw 'limit nil
)))))
483 ((or (eq a
'$ind
) (eq z
'$ind
))
484 ;; Revert a & z to the arguments of gamma_incomplete. When z is
485 ;; off the negative real axis or a is not a negative integer,
488 (setq z
(caddr expr
))
489 (if (or (off-negative-real-axisp z
)
490 (not (and ($featurep a
'$integer
) (eq t
(mgqp 0 a
))))) '$ind
492 ((or (eq a
'$und
) (eq z
'$und
)) '$und
)
499 ;; All other cases are handled by the simplifier of the function.
500 (ftake '%gamma_incomplete a z
)))))
502 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
506 ;;; Implementation of the Lower Incomplete gamma function:
513 ;;; gamma_incomplete_lower(a, z) = I t %e dt
517 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
518 ;;; distribute over bags (aggregates)
520 (defprop %gamma_incomplete_lower
(mlist $matrix mequal
) distribute_over
)
522 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
524 ;; (defprop %gamma_incomplete_lower ??? grad) WHAT TO PUT HERE ??
527 ;; Handles some special cases for the order a and simplifies it to an
528 ;; equivalent form, possibly involving erf and gamma_incomplete_lower
530 (def-simplifier gamma_incomplete_lower
(a z
)
533 (float-numerical-eval-p a z
)
534 (complex-float-numerical-eval-p a z
)
535 (bigfloat-numerical-eval-p a z
)
536 (complex-bigfloat-numerical-eval-p a z
))
537 (ftake '%gamma_incomplete_generalized a
0 z
))
538 ((gamma-incomplete-lower-expand a z
))
539 ($hypergeometric_representation
540 ;; We make use of the fact that gamma_incomplete_lower(a,z) +
541 ;; gamma_incomplete(a,z) = gamma(a). Thus,
542 ;; gamma_incomplete_lower(a,z) = gamma(a)-gamma_incomplete(a,z).
543 ;; And we know the hypergeometric form for gamma_incomplete.
544 (sub (ftake '%gamma a
)
545 (ftake '%gamma_incomplete a z
)))
549 ;; Try to express gamma_incomplete_lower(a,z) in simpler terms for
550 ;; special values of the order a. If we can't, return NIL to say so.
551 (defun gamma-incomplete-lower-expand (a z
)
552 (cond ((and $gamma_expand
(integerp a
) (eql a
1))
553 ;; gamma_incomplete_lower(0, x) = 1-exp(x)
554 (sub 1 (m^t
'$%e
(neg z
))))
555 ((and $gamma_expand
(integerp a
) (plusp a
))
556 ;; gamma_incomplete_lower(a,z) can be simplified if a is a
557 ;; positive integer. Since gamma_incomplete_lower(a,z) =
558 ;; gamma(a) - gamma_incomplete(a,z), use gamma_incomplete to
560 (sub (ftake* '%gamma a
)
561 (take '(%gamma_incomplete
) a z
)))
562 ((and $gamma_expand
(alike1 a
1//2))
565 ;; gamma_incomplete_lower(1/2,x^2) = sqrt(%pi)*erf(x)
567 ;; gamma_incomplete_lower(1/2,z) = sqrt(%pi)*erf(sqrt(x))
569 (mul (power '$%pi
'((rat simp
) 1 2))
570 (take '(%erf
) (power z
'((rat simp
) 1 2)))))
571 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
572 ;; gamma_incomplete_lower(a+n,z), where n is an integer
574 (a (simplify (cons '(mplus) (cddr a
)))))
577 ;; gamma_incomplete_lower(a+n,z). See DLMF 8.8.7:
579 ;; gamma_incomplete_lower(a+n,z)
580 ;; = pochhammer(a,n)*gamma_incomplete_lower(a,z)
581 ;; -z^a*exp(-z)*sum(gamma(a+n)gamma(a+k+1)*z^k,k,0,n-1)
584 (simplify (list '($pochhammer
) a n
))
585 (simplify (list '(%gamma_incomplete_lower
) a z
)))
588 (power '$%e
(mul -
1 z
))
589 (let ((gamma-a+n
(ftake* '%gamma
(add a n
)))
590 (index (gensumindex))
595 (ftake* '%gamma
(add a index
1)))
597 index
0 (add n -
1))))))
600 ;; See DLMF 8.8.8. For simplicity let g(a,z) = gamma_incomplete_lower(a,z).
602 ;; g(a,z) = gamma(a)/gamma(a-n)*g(a-n,z)
603 ;; - z^(a-1)*exp(z)*sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
606 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
607 ;; + gamma(a-n)/gamma(a)*z^(a-1)*exp(-z)
608 ;; * sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
610 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
612 ;; * sum(gamma(a-n)/gamma(a-k)*z^(-k),k,0,n-1)
613 (let ((gamma-a-n (ftake* '%gamma
(sub a n
)))
614 (index (gensumindex))
620 (simplify (list '(%gamma_incomplete_lower
) a z
)))
623 (power '$%e
(mul -
1 z
))
627 (ftake* '%gamma
(sub a index
)))
628 (power z
(mul -
1 index
)))
629 index
0 (add n -
1)))))))))
630 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
631 (integerp (second a
))
632 (integerp (third a
)))
633 ;; gamma_incomplete_lower of (numeric) rational order.
634 ;; Expand it out so that the resulting order is between 0 and
636 (multiple-value-bind (n order
)
637 (floor (/ (second a
) (third a
)))
638 ;; a = n + order where 0 <= order < 1.
639 (let ((rat-order (rat (numerator order
) (denominator order
))))
642 ;; Nothing to do if the order is already between 0 and 1
643 (list '(%gamma_incomplete_lower simp
) a z
))
645 ;; Use gamma_incomplete(a+n,z) above. and then substitute
646 ;; a=order. This works for n positive or negative.
647 (let* ((ord (gensym))
648 (g (simplify (list '(%gamma_incomplete_lower
) (add ord n
) z
))))
649 ($substitute rat-order ord g
)))))))
651 ;; No expansion so return nil to indicate that
654 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
656 ;;; Incomplete Gamma function is a simplifying function
658 (def-simplifier gamma_incomplete
(a z
)
663 ;; Check for specific values
666 ;; gamma_incomplete(v,0) is gamma(v) only if the realpart(v) >
667 ;; 0. If realpart(v) <= 0, gamma_incomplete is undefined. For
668 ;; all other cases, return the noun form.
669 (let ((sgn ($sign
($realpart a
))))
670 (cond ((member sgn
'($neg $zero
))
673 "gamma_incomplete: gamma_incomplete(~:M,~:M) is undefined.")
675 ((member sgn
'($pos $pz
)) ($gamma a
))
683 ;; Check for numerical evaluation in Float or Bigfloat precision
685 ((float-numerical-eval-p a z
)
687 (format t
"~&SIMP-GAMMA-INCOMPLETE in float-numerical-eval-p~%"))
688 ;; a and z are Maxima numbers, at least one has a float value
693 (and (= 0 (- a
(truncate a
)))
695 ;; a is zero or a negative float representing an integer.
696 ;; For these cases the numerical routines of gamma-incomplete
697 ;; do not work. Call the numerical routine for the Exponential
698 ;; Integral E(n,z). The routine is called with a positive integer!.
699 (setq a
(truncate a
))
700 (complexify (* (expt z a
) (expintegral-e (- 1 a
) z
))))
702 (complexify (gamma-incomplete a z
))))))
704 ((complex-float-numerical-eval-p a z
)
707 "~&SIMP-GAMMA-INCOMPLETE in complex-float-numerical-eval-p~%"))
708 ;; a and z are Maxima numbers, at least one is a complex value and
709 ;; we have at least one float part
710 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
711 (cz (complex ($float
($realpart z
)) ($float
($imagpart z
)))))
713 ((and (= (imagpart ca
) 0.0)
714 (or (= (realpart ca
) 0.0)
715 (and (= 0 (- (realpart ca
) (truncate (realpart ca
))))
716 (< (realpart ca
) 0.0))))
717 ;; Call expintegral-e. See comment above.
718 (setq ca
(truncate (realpart ca
)))
719 (complexify (* (expt cz ca
) (expintegral-e (- 1 ca
) cz
))))
721 (complexify (gamma-incomplete ca cz
))))))
723 ((bigfloat-numerical-eval-p a z
)
725 (format t
"~&SIMP-GAMMA-INCOMPLETE in bigfloat-numerical-eval-p~%"))
726 (let ((a ($bfloat a
))
729 ((or (eq ($sign a
) '$zero
)
730 (and (eq ($sign
(sub a
($truncate a
))) '$zero
)
731 (eq ($sign a
) '$neg
)))
732 ;; Call bfloat-expintegral-e. See comment above.
733 (setq a
($truncate a
))
734 ($rectform
(mul (power z a
) (bfloat-expintegral-e (- 1 a
) z
))))
736 (bfloat-gamma-incomplete a z
)))))
738 ((complex-bigfloat-numerical-eval-p a z
)
741 "~&SIMP-GAMMA-INCOMPLETE in complex-bigfloat-numerical-eval-p~%"))
742 (let ((ca (add ($bfloat
($realpart a
))
743 (mul '$%i
($bfloat
($imagpart a
)))))
744 (cz (add ($bfloat
($realpart z
))
745 (mul '$%i
($bfloat
($imagpart z
))))))
747 ((and (eq ($sign
($imagpart ca
)) '$zero
)
748 (or (eq ($sign
($realpart ca
)) '$zero
)
749 (and (eq ($sign
(sub ($realpart ca
)
750 ($truncate
($realpart ca
))))
752 (eq ($sign
($realpart ca
)) '$neg
))))
753 ;; Call bfloat-expintegral-e. See comment above.
756 "~& bigfloat-numerical-eval-p calls bfloat-expintegral-e~%"))
757 (setq a
($truncate
($realpart a
)))
758 ($rectform
(mul (power cz a
)
759 (bfloat-expintegral-e (- 1 a
) cz
))))
761 (complex-bfloat-gamma-incomplete ca cz
)))))
763 ;; Check for transformations and argument simplification
765 ((and $gamma_expand
(integerp a
))
766 ;; Integer or a symbol declared to be an integer. Expand in a series.
767 (let ((sgn ($sign a
)))
772 (simplify (list '(%expintegral_ei
) (mul -
1 z
))))
776 (simplify (list '(%log
) (mul -
1 z
)))
777 (simplify (list '(%log
) (div -
1 z
)))))
778 (mul -
1 (simplify (list '(%log
) z
)))))
779 ((member sgn
'($pos $pz
))
781 (simplify (list '(%gamma
) a
))
782 (power '$%e
(mul -
1 z
))
783 (let ((index (gensumindex)))
787 (let (($gamma_expand nil
))
788 ;; Simplify gamma, but do not expand to avoid division
790 (simplify (list '(%gamma
) (add index
1)))))
791 index
0 (sub a
1)))))
792 ((member sgn
'($neg $nz
))
796 (power -
1 (add (mul -
1 a
) -
1))
797 (simplify (list '(%gamma
) (add (mul -
1 a
) 1))))
799 (simplify (list '(%expintegral_ei
) (mul -
1 z
)))
803 (simplify (list '(%log
) (mul -
1 z
)))
804 (simplify (list '(%log
) (div -
1 z
)))))
805 (simplify (list '(%log
) z
))))
807 (power '$%e
(mul -
1 z
))
808 (let ((index (gensumindex)))
811 (power z
(add index a -
1))
812 (simplify (list '($pochhammer
) a index
)))
813 index
1 (mul -
1 a
))))))
816 ((and $gamma_expand
(setq ratorder
(max-numeric-ratio-p a
2)))
817 ;; We have a half integral order and $gamma_expand is not NIL.
818 ;; We expand in a series with the Erfc function
819 (setq ratorder
(- ratorder
(/ 1 2)))
823 (power '$%pi
'((rat simp
) 1 2))
824 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))))
828 (simplify (list '(%gamma
) a
))
829 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
831 (power -
1 (sub ratorder
1))
832 (power '$%e
(mul -
1 z
))
833 (power z
'((rat simp
) 1 2))
834 (let ((index (gensumindex)))
836 (mul -
1 ; we get more simple results
837 (simplify ; when multiplying with -1
840 (sub '((rat simp
) 1 2) ratorder
)
841 (sub ratorder
(add index
1))))
842 (power (mul -
1 z
) index
))
843 index
0 (sub ratorder
1))))))
845 (setq ratorder
(- ratorder
))
850 (power '$%pi
'((rat simp
) 1 2))
851 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
852 (simplify (list '($pochhammer
) '((rat simp
) 1 2) ratorder
)))
854 (power z
(sub '((rat simp
) 1 2) ratorder
))
855 (power '$%e
(mul -
1 z
))
856 (let ((index (gensumindex)))
863 (sub '((rat simp
) 1 2) ratorder
)
865 index
0 (sub ratorder
1))))))))
867 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
868 ;; Handle gamma_incomplete(a+n, z), where n is a numerical integer
870 (a (simplify (cons '(mplus) (cddr a
)))))
873 ;; See DLMF 8.8.9: https://dlmf.nist.gov/8.8.E9
875 ;; gamma_incomplete(a+n,z) = pochhammer(a,n)*gamma_incomplete(a,z)
876 ;; + z^a*exp(-z)*sum(gamma(a+n)/gamma(a+k+1)*z^k,k,0,n-1)
879 (simplify (list '($pochhammer
) a n
))
880 (simplify (list '(%gamma_incomplete
) a z
)))
882 (power '$%e
(mul -
1 z
))
884 (let ((gamma-a+n
(ftake* '%gamma
(add a n
)))
885 (index (gensumindex)))
889 (ftake* '%gamma
(add a index
1)))
891 index
0 (add n -
1))))))
894 ;; See http://functions.wolfram.com/06.06.17.0004.01
896 ;; gamma_incomplate(a,z) =
897 ;; (-1)^n*pochhammer(1-a,n)
898 ;; *[gamma_incomplete(a-n,z)
899 ;; + z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)]
901 ;; Rerarrange this in terms of gamma_incomplete(a-n,z):
903 ;; gamma_incomplete(a-n,z) =
904 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
905 ;; -z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)
907 ;; Change the summation index to go from k = 0 to n-1:
909 ;; z^(a-n-1)*sum(z^k/pochhammer(a-n,k),k,1,n)
910 ;; = z^(a-n-1)*sum(z^(k+1)/pochhammer(a-n,k+1),k,0,n-1)
911 ;; = z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
914 ;; gamma_incomplete(a-n,z) =
915 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
916 ;; -z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
918 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
922 (simplify (list '(%gamma_incomplete
) a z
)))
923 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
925 (power '$%e
(mul -
1 z
))
927 ;; sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
928 (let ((index (gensumindex)))
932 (simplify (list '($pochhammer
) (sub a n
) (add index
1))))
933 index
0 (sub n
1)))))))))
934 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
935 (integerp (second a
))
936 (integerp (third a
)))
937 ;; gamma_incomplete of (numeric) rational order. Expand it out
938 ;; so that the resulting order is between 0 and 1.
939 (multiple-value-bind (n order
)
940 (floor (/ (second a
) (third a
)))
941 ;; a = n + order where 0 <= order < 1.
942 (let ((rat-order (rat (numerator order
) (denominator order
))))
945 ;; Nothing to do if the order is already between 0 and 1
948 ;; Use gamma_incomplete(a+n,z) above. and then substitute
949 ;; a=order. This works for n positive or negative.
950 (let* ((ord (gensym))
951 (g (simplify (list '(%gamma_incomplete
) (add ord n
) z
))))
952 ($substitute rat-order ord g
)))))))
954 ($hypergeometric_representation
955 ;; See http://functions.wolfram.com/06.06.26.0002.01
957 ;; gamma_incomplete(a,z) = gamma(z) - z^a/a*%f[1,1]([a],[a+1},-z)
959 ;; However, hypergeomtric simplifies
960 ;; hypergeometric([a],[a+1],-z) to
961 ;; hypergeometric([1],[a+1],z)*exp(-z).
962 (sub (ftake '%gamma a
)
965 (ftake '%hypergeometric
967 (make-mlist (add 1 a
))
971 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
972 ;;; Numerical evaluation of the Incomplete Gamma function
974 ;;; gamma-incomplete (a,z) - real and complex double float
975 ;;; bfloat-gamma-incomplete (a z) - bigfloat
976 ;;; complex-bfloat-gamma-incomplete (a z) - complex bigfloat
978 ;;; Expansion in a power series for abs(x) < R, where R is
979 ;;; *gamma-radius* + real(a) if real(a) > 0 or *gamma-radius*
987 ;;; gamma(a,z) = exp(-x)*z^a * > ------------ * z^n
992 ;;; This expansion does not work for an integer a<=0, because the Gamma function
993 ;;; in the denominator is not defined for a=0 and negative integers. For this
994 ;;; case we use the Exponential Integral E for numerically evaluation. The
995 ;;; Incomplete Gamma function and the Exponential integral are connected by
997 ;;; gamma(a,z) = z^a * expintegral_e(1-a,z)
999 ;;; When the series is not used, two forms of the continued fraction
1000 ;;; are used. When z is not near the negative real axis use the
1001 ;;; continued fractions (A&S 6.5.31):
1004 ;;; gamma(a,z) = exp(-z) z^a *( -- --- --- --- --- ... )
1007 ;;; The accuracy is controlled by *gamma-incomplete-eps* for double float
1008 ;;; precision. For bigfloat precision epsilon is 10^(-$fpprec). The expansions
1009 ;;; in a power series or continued fractions stops if *gamma-incomplete-maxit*
1010 ;;; is exceeded and an Maxima error is thrown.
1012 ;;; The above fraction does not converge on the negative real axis and
1013 ;;; converges very slowly near the axis. In this case, use the
1016 ;;; gamma(a,z) = gamma(a) - gamma_lower(a,z)
1018 ;;; The continued fraction for gamma_incomplete_lower(a,z) is
1019 ;;; (http://functions.wolfram.com/06.06.10.0009.01):
1021 ;;; gamma_lower(a,z) = exp(-z) * z^a / cf(a,z)
1025 ;;; -a*z z (a+1)*z 2*z (a+2)*z
1026 ;;; cf(a,z) = a + ---- ---- ------- ---- -------
1027 ;;; a+1+ a+2- a+3+ a+4- a+5+
1029 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1031 (defvar *gamma-incomplete-maxit
* 10000)
1032 (defvar *gamma-incomplete-eps
* (* 2 +flonum-epsilon
+))
1033 (defvar *gamma-incomplete-min
* 1.0e-32)
1035 (defvar *gamma-radius
* 1.0
1036 "Controls the radius within a series expansion is done.")
1037 (defvar *gamma-imag
* 1.0)
1039 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1041 ;;; The numerical evaluation for CL float or complex values a and x
1042 ;;; When the flag regularized is T, the result is divided by gamma(a) and
1043 ;;; Maxima returns the numercial result for gamma_incomplete_regularized
1045 (defun gamma-incomplete (a x
&optional
(regularized nil
))
1046 (setq x
(+ x
(cond ((complexp x
) #C
(0.0
0.0)) ((realp x
) 0.0))))
1049 ;; Compute the factor needed to scale the series or continued
1050 ;; fraction. This is x^a*exp(-x) or x^a*exp(-x)/gamma(a)
1051 ;; depending on whether we want a non-regularized or
1052 ;; regularized form. We want to compute the factor carefully
1053 ;; to avoid unnecessary overflow if possible.
1055 (or (try-float-computation
1057 ;; gammafloat is more accurate for real
1060 (/ (* (expt x a
) (exp (- x
)))
1063 (/ (* (expt x a
) (exp (- x
)))
1065 ;; Easy way failed. Use logs to compute the
1066 ;; result. This loses some precision, especially
1067 ;; for large values of a and/or x because we use
1068 ;; many bits to hold the exponent part.
1069 (exp (- (* a
(log x
))
1071 (log-gamma-lanczos (if (complexp a
)
1075 (or (try-float-computation
1077 (* (expt x a
) (exp (- x
)))))
1078 ;; Easy way failed, so use the log form.
1079 (exp (- (* a
(log x
))
1081 (multiple-value-bind (result lower-incomplete-tail-p
)
1082 (%gamma-incomplete a x
)
1083 (cond (lower-incomplete-tail-p
1084 ;; %gamma-incomplete compute the lower incomplete gamma
1085 ;; function, so we need to subtract that from gamma(a),
1088 (- 1 (* result factor
)))
1090 (- (gamma-lanczos a
) (* result factor
)))
1092 (- (gammafloat a
) (* result factor
)))))
1094 ;; Continued fraction used. Just multiply by the factor
1095 ;; to get the final result.
1096 (* factor result
))))))
1098 ;; Compute the key part of the gamma incomplete function using either
1099 ;; a series expression or a continued fraction expression. Two values
1100 ;; are returned: the value itself and a boolean, indicating what the
1101 ;; computed value is. If the boolean non-NIL, then the computed value
1102 ;; is the lower incomplete gamma function.
1103 (defun %gamma-incomplete
(a x
)
1104 (let ((gm-maxit *gamma-incomplete-maxit
*)
1105 (gm-eps *gamma-incomplete-eps
*)
1106 (gm-min *gamma-incomplete-min
*))
1108 (format t
"~&GAMMA-INCOMPLETE with ~A and ~A~%" a x
))
1110 ;; The series expansion is done for x within a circle of radius
1111 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1112 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1113 ;; continued fraction is used.
1114 ((and (> (abs x
) (+ *gamma-radius
*
1115 (if (> (realpart a
) 0.0) (realpart a
) 0.0))))
1116 (cond ((and (< (realpart x
) 0)
1117 (< (abs (imagpart x
))
1118 (* *gamma-imag
* (abs (realpart x
)))))
1119 ;; For x near the negative real axis, use the
1120 ;; relationship gamma_incomplete(a,z) = gamma(a) -
1121 ;; gamma_incomplete_lower(a,z), where
1122 ;; gamma_incomplete_lower(a,z) is the lower poart of the
1123 ;; incomplete gamma function. We can evaluate that
1124 ;; using a continued fraction from
1125 ;; http://functions.wolfram.com/06.06.10.0009.01. (Note
1126 ;; that the alternative fraction,
1127 ;; http://functions.wolfram.com/06.06.10.0007.01,
1128 ;; appears to be less accurate.)
1130 ;; Also note that this appears to be valid for all
1131 ;; values of x (real or complex), but we don't want to
1132 ;; use this everywhere for gamma_incomplete. Consider
1133 ;; what happens for large real x. gamma_incomplete(a,x)
1134 ;; is small, but gamma_incomplete(a,x) = gamma(x) - cf
1135 ;; will have large roundoff errors.
1137 (format t
"~&GAMMA-INCOMPLETE in continued fractions for lower integral~%"))
1138 (let ((a (bigfloat:to a
))
1140 (bigfloat::*debug-cf-eval
* *debug-gamma
*)
1141 (bigfloat::*max-cf-iterations
* *gamma-incomplete-maxit
*))
1142 (values (/ (bigfloat::lentz
#'(lambda (n)
1147 (- (* (+ a
(ash n -
1)) x
))))))
1150 ;; Expansion in continued fractions for gamma_incomplete.
1152 (format t
"~&GAMMA-INCOMPLETE in continued fractions~%"))
1154 (an (- a
1.0) (* i
(- a i
)))
1155 (b (+ 3.0 x
(- a
)) (+ b
2.0))
1157 (d (/ 1.0 (- b
2.0)))
1161 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1162 (setq d
(+ (* an d
) b
))
1163 (when (< (abs d
) gm-min
) (setq d gm-min
))
1164 (setq c
(+ b
(/ an c
)))
1165 (when (< (abs c
) gm-min
) (setq c gm-min
))
1169 (when (< (abs (- del
1.0)) gm-eps
)
1170 ;; Return nil to indicate we used the continued fraction.
1171 (return (values h nil
)))))))
1173 ;; Expansion in a series
1175 (format t
"~&GAMMA-INCOMPLETE in series~%"))
1178 (del (/ 1.0 a
) (* del
(/ x ap
)))
1179 (sum del
(+ sum del
)))
1181 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1182 (when (< (abs del
) (* (abs sum
) gm-eps
))
1183 (when *debug-gamma
* (format t
"~&Series converged.~%"))
1184 ;; Return T to indicate we used the series and the series
1185 ;; is for the integral from 0 to x, not x to inf.
1186 (return (values sum t
))))))))
1188 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1190 ;;; This function is called for a and x real
1192 (defun bfloat-gamma-incomplete (a x
)
1193 (let* ((gm-maxit *gamma-incomplete-maxit
*)
1194 (gm-eps (power ($bfloat
10.0) (- $fpprec
)))
1195 (gm-min (mul gm-eps gm-eps
))
1198 ;; The series expansion is done for x within a circle of radius
1199 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1200 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1201 ;; continued fraction is used.
1202 ((eq ($sign
(sub (simplify (list '(mabs) x
))
1204 (if (eq ($sign a
) '$pos
) a
0.0))))
1207 ((and (eq ($sign x
) '$pos
))
1208 ;; Expansion in continued fractions of the Incomplete Gamma function
1210 (an (sub a
1.0) (mul i
(sub a i
)))
1211 (b (add 3.0 x
(mul -
1 a
)) (add b
2.0))
1212 (c (div 1.0 gm-min
))
1213 (d (div 1.0 (sub b
2.0)))
1217 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1219 (format t
"~&in continued fractions:~%")
1220 (mformat t
"~& : i = ~M~%" i
)
1221 (mformat t
"~& : h = ~M~%" h
))
1222 (setq d
(add (mul an d
) b
))
1223 (when (eq ($sign
(sub (simplify (list '(mabs) d
)) gm-min
)) '$neg
)
1225 (setq c
(add b
(div an c
)))
1226 (when (eq ($sign
(sub (simplify (list '(mabs) c
)) gm-min
)) '$neg
)
1228 (setq d
(div 1.0 d
))
1229 (setq del
(mul d c
))
1230 (setq h
(mul h del
))
1231 (when (eq ($sign
(sub (simplify (list '(mabs) (sub del
1.0))) gm-eps
))
1236 (power ($bfloat
'$%e
) (mul -
1 x
)))))))
1238 ;; Expand to multiply everything out.
1240 ;; Expansion in continued fraction for the lower incomplete gamma.
1241 (sub (simplify (list '(%gamma
) a
))
1242 ;; NOTE: We want (power x a) instead of bigfloat:expt
1243 ;; because this preserves how maxima computes x^a when
1244 ;; x is negative and a is rational. For, example
1245 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1248 (power ($bfloat
'$%e
) (mul -
1 x
))
1249 (let ((a (bigfloat:to a
))
1250 (x (bigfloat:to x
)))
1257 (bigfloat:* (ash n -
1) x
)
1258 (bigfloat:-
(bigfloat:* (bigfloat:+ a
(ash n -
1))
1262 ;; Series expansion of the Incomplete Gamma function
1265 (del (div 1.0 a
) (mul del
(div x ap
)))
1266 (sum del
(add sum del
)))
1268 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1270 (format t
"~&GAMMA-INCOMPLETE in series:~%")
1271 (mformat t
"~& : i = ~M~%" i
)
1272 (mformat t
"~& : ap = ~M~%" ap
)
1273 (mformat t
"~& : x/ap = ~M~%" (div x ap
))
1274 (mformat t
"~& : del = ~M~%" del
)
1275 (mformat t
"~& : sum = ~M~%" sum
))
1276 (when (eq ($sign
(sub (simplify (list '(mabs) del
))
1277 (mul (simplify (list '(mabs) sum
)) gm-eps
)))
1279 (when *debug-gamma
* (mformat t
"~&Series converged to ~M.~%" sum
))
1281 (sub (simplify (list '(%gamma
) a
))
1285 (power ($bfloat
'$%e
) (mul -
1 x
))))))))))))
1287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1289 (defun complex-bfloat-gamma-incomplete (a x
)
1290 (let* ((gm-maxit *gamma-incomplete-maxit
*)
1291 (gm-eps (power ($bfloat
10.0) (- $fpprec
)))
1292 (gm-min (mul gm-eps gm-eps
))
1295 (format t
"~&COMPLEX-BFLOAT-GAMMA-INCOMPLETE~%")
1296 (format t
" : a = ~A~%" a
)
1297 (format t
" : x = ~A~%" x
))
1299 ;; The series expansion is done for x within a circle of radius
1300 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1301 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1302 ;; continued fraction is used.
1303 ((and (eq ($sign
(sub (simplify (list '(mabs) x
))
1305 (if (eq ($sign
($realpart a
)) '$pos
)
1310 ((not (and (eq ($sign
($realpart x
)) '$neg
)
1311 (eq ($sign
(sub (simplify (list '(mabs) ($imagpart x
)))
1312 (simplify (list '(mabs) ($realpart x
)))))
1314 ;; Expansion in continued fractions of the Incomplete Gamma function
1316 (format t
"~&in continued fractions:~%"))
1318 (an (sub a
1.0) (mul i
(sub a i
)))
1319 (b (add 3.0 x
(mul -
1 a
)) (add b
2.0))
1320 (c (cdiv 1.0 gm-min
))
1321 (d (cdiv 1.0 (sub b
2.0)))
1325 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1326 (setq d
(add (cmul an d
) b
))
1327 (when (eq ($sign
(sub (simplify (list '(mabs) d
)) gm-min
)) '$neg
)
1329 (setq c
(add b
(cdiv an c
)))
1330 (when (eq ($sign
(sub (simplify (list '(mabs) c
)) gm-min
)) '$neg
)
1332 (setq d
(cdiv 1.0 d
))
1333 (setq del
(cmul d c
))
1334 (setq h
(cmul h del
))
1335 (when (eq ($sign
(sub (simplify (list '(mabs) (sub del
1.0)))
1339 ($bfloat
; force evaluation of expressions with sin or cos
1343 (cpower ($bfloat
'$%e
) ($bfloat
(mul -
1 x
))))))))))
1345 ;; Expand to multiply everything out.
1347 ;; Expansion in continued fraction for the lower incomplete gamma.
1348 (sub ($rectform
(simplify (list '(%gamma
) a
)))
1349 ;; NOTE: We want (power x a) instead of bigfloat:expt
1350 ;; because this preserves how maxima computes x^a when
1351 ;; x is negative and a is rational. For, example
1352 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1354 (mul ($rectform
(power x a
))
1355 ($rectform
(power ($bfloat
'$%e
) (mul -
1 x
)))
1356 (let ((a (bigfloat:to a
))
1357 (x (bigfloat:to x
)))
1364 (bigfloat:* (ash n -
1) x
)
1365 (bigfloat:-
(bigfloat:* (bigfloat:+ a
(ash n -
1))
1368 ;; Series expansion of the Incomplete Gamma function
1370 (format t
"~&GAMMA-INCOMPLETE in series:~%"))
1373 (del (cdiv 1.0 a
) (cmul del
(cdiv x ap
)))
1374 (sum del
(add sum del
)))
1376 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1377 (when (eq ($sign
(sub (simplify (list '(mabs) del
))
1378 (mul (simplify (list '(mabs) sum
)) gm-eps
)))
1380 (when *debug-gamma
* (format t
"~&Series converged.~%"))
1382 ($bfloat
; force evaluation of expressions with sin or cos
1383 (sub (simplify (list '(%gamma
) a
))
1387 (cpower ($bfloat
'$%e
) (mul -
1 x
)))))))))))))
1389 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1391 ;;; Implementation of the Generalized Incomplete Gamma function
1396 ;;; gamma_incomplete_generalized(a, z1, z2) = I t %e dt
1401 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1403 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1404 ;;; on the negative real axis.
1405 ;;; We support a conjugate-function which test this case.
1407 (defprop %gamma_incomplete_generalized
1408 conjugate-gamma-incomplete-generalized conjugate-function
)
1410 (defun conjugate-gamma-incomplete-generalized (args)
1411 (let ((a (first args
)) (z1 (second args
)) (z2 (third args
)))
1412 (cond ((and (off-negative-real-axisp z1
) (off-negative-real-axisp z2
))
1413 ;; z1 and z2 definitely not on the negative real axis.
1417 '(%gamma_incomplete_generalized
)
1418 (simplify (list '($conjugate
) a
))
1419 (simplify (list '($conjugate
) z1
))
1420 (simplify (list '($conjugate
) z2
)))))
1422 ;; On the negative real axis or no information. Unsimplified.
1425 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
)))))))
1427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1429 ;;; Generalized Incomplete Gamma distributes over bags
1431 (defprop %gamma_incomplete_generalized
(mlist $matrix mequal
) distribute_over
)
1433 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1435 ;;; Differentiation of Generalized Incomplete Gamma function
1437 (defprop %gamma_incomplete_generalized
1439 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1440 ;; and the Generalized Incomplete Gamma function (functions.wolfram.com)
1443 ((mexpt) ((%gamma
) a
) 2)
1445 (($hypergeometric_regularized
)
1447 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1450 ((mexpt) ((%gamma
) a
) 2)
1452 (($hypergeometric_regularized
)
1454 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1457 ((%gamma_incomplete_generalized
) a
0 z1
)
1460 ((%gamma_incomplete_generalized
) a
0 z2
)
1462 ;; The derivative wrt z1
1464 ((mexpt) $%e
((mtimes) -
1 z1
))
1465 ((mexpt) z1
((mplus) -
1 a
)))
1466 ;; The derivative wrt z2
1468 ((mexpt) $%e
((mtimes) -
1 z2
))
1469 ((mexpt) z2
((mplus) -
1 a
))))
1472 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1474 ;;; Generalized Incomplete Gamma function is a simplifying function
1476 (def-simplifier gamma_incomplete_generalized
(a z1 z2
)
1480 ;; Check for specific values
1483 (let ((sgn ($sign
($realpart a
))))
1485 ((member sgn
'($pos $pz
))
1487 (simplify (list '(%gamma_incomplete
) a z1
))
1488 (simplify (list '(%gamma
) a
))))
1493 (let ((sgn ($sign
($realpart a
))))
1495 ((member sgn
'($pos $pz
))
1497 (simplify (list '(%gamma
) a
))
1498 (simplify (list '(%gamma_incomplete
) a z2
))))
1502 ((zerop1 (sub z1 z2
)) 0)
1504 ((eq z2
'$inf
) (simplify (list '(%gamma_incomplete
) a z1
)))
1505 ((eq z1
'$inf
) (mul -
1 (simplify (list '(%gamma_incomplete
) a z2
))))
1507 ;; Check for numerical evaluation in Float or Bigfloat precision
1508 ;; Use the numerical routines of the Incomplete Gamma function
1510 ((float-numerical-eval-p a z1 z2
)
1512 (- (gamma-incomplete ($float a
) ($float z1
))
1513 (gamma-incomplete ($float a
) ($float z2
)))))
1515 ((complex-float-numerical-eval-p a z1 z2
)
1516 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
1517 (cz1 (complex ($float
($realpart z1
)) ($float
($imagpart z1
))))
1518 (cz2 (complex ($float
($realpart z2
)) ($float
($imagpart z2
)))))
1519 (complexify (- (gamma-incomplete ca cz1
) (gamma-incomplete ca cz2
)))))
1521 ((bigfloat-numerical-eval-p a z1 z2
)
1522 (sub (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z1
))
1523 (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z2
))))
1525 ((complex-bigfloat-numerical-eval-p a z1 z2
)
1526 (let ((ca (add ($bfloat
($realpart a
))
1527 (mul '$%i
($bfloat
($imagpart a
)))))
1528 (cz1 (add ($bfloat
($realpart z1
))
1529 (mul '$%i
($bfloat
($imagpart z1
)))))
1530 (cz2 (add ($bfloat
($realpart z2
))
1531 (mul '$%i
($bfloat
($imagpart z2
))))))
1532 (sub (complex-bfloat-gamma-incomplete ca cz1
)
1533 (complex-bfloat-gamma-incomplete ca cz2
))))
1535 ;; Check for transformations and argument simplification
1537 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
1538 ;; Expand gamma_incomplete_generalized(a+n,z1,z2) with n an integer
1540 (a (simplify (cons '(mplus) (cddr a
)))))
1544 (simplify (list '($pochhammer
) a n
))
1546 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
))
1548 (power '$%e
(mul -
1 z1
))
1549 (let ((index (gensumindex)))
1552 (power z1
(add a index -
1))
1553 (simplify (list '($pochhammer
) a index
)))
1556 (power '$%e
(mul -
1 z2
))
1557 (let ((index (gensumindex)))
1560 (power z2
(add a index -
1))
1561 (simplify (list '($pochhammer
) a index
)))
1570 ($factor
(simplify (list '($pochhammer
) (sub 1 a
) n
))))
1571 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
)))
1573 (power '$%e
(mul -
1 z2
))
1574 (let ((index (gensumindex)))
1577 (power z1
(add a index
(- n
) -
1))
1578 (simplify (list '($pochhammer
) (sub a n
) index
)))
1581 (power '$%e
(mul -
1 z2
))
1582 (let ((index (gensumindex)))
1585 (power z2
(add a index
(- n
) -
1))
1586 (simplify (list '($pochhammer
) (sub a n
) index
)))
1588 ($hypergeometric_representation
1589 ;; Use the fact that gamma_incomplete_generalized(a,z1,z2) =
1590 ;; gamma_incomplete(a,z1) - gamma_incomplete(a,z2).
1591 (sub (ftake '%gamma_incomplete a z1
)
1592 (ftake '%gamma_incomplete a z2
)))
1595 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1597 ;;; Implementation of the Regularized Incomplete Gamma function
1601 ;;; gamma_incomplete(a, z)
1602 ;;; gamma_incomplete_regularized(a, z) = ----------------------
1605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1607 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1609 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1610 ;;; on the negative real axis.
1611 ;;; We support a conjugate-function which test this case.
1613 (defprop %gamma_incomplete_regularized
1614 conjugate-gamma-incomplete-regularized conjugate-function
)
1616 (defun conjugate-gamma-incomplete-regularized (args)
1617 (let ((a (first args
)) (z (second args
)))
1618 (cond ((off-negative-real-axisp z
)
1619 ;; z definitely not on the negative real axis. Mirror symmetry.
1622 '(%gamma_incomplete_regularized
)
1623 (simplify (list '($conjugate
) a
))
1624 (simplify (list '($conjugate
) z
)))))
1626 ;; On the negative real axis or no information. Unsimplified.
1629 (simplify (list '(%gamma_incomplete_regularized
) a z
)))))))
1631 ;;; Regularized Incomplete Gamma distributes over bags
1633 (defprop %gamma_incomplete_regularized
(mlist $matrix mequal
) distribute_over
)
1635 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1637 ;;; Differentiation of Regularized Incomplete Gamma function
1639 (defprop %gamma_incomplete_regularized
1641 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1642 ;; and the Regularized Generalized Incomplete Gamma function
1643 ;; (functions.wolfram.com)
1648 (($hypergeometric_regularized
)
1650 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1653 ((%gamma_incomplete_generalized_regularized
) a z
0)
1656 ((mtimes) -
1 ((mqapply) (($psi array
) 0) a
)))))
1657 ;; The derivative wrt z
1660 ((mexpt) $%e
((mtimes) -
1 z
))
1661 ((mexpt) z
((mplus) -
1 a
))
1662 ((mexpt) ((%gamma
) a
) -
1)))
1665 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1667 ;;; Regularized Incomplete Gamma function is a simplifying function
1669 (def-simplifier gamma_incomplete_regularized
(a z
)
1675 ;; Check for specific values
1678 (let ((sgn ($sign
($realpart a
))))
1679 (cond ((member sgn
'($neg $zero
))
1682 "gamma_incomplete_regularized: gamma_incomplete_regularized(~:M,~:M) is undefined.")
1684 ((member sgn
'($pos $pz
)) 1)
1690 ;; Check for numerical evaluation in Float or Bigfloat precision
1692 ((float-numerical-eval-p a z
)
1694 ;; gamma_incomplete returns a regularized result
1695 (gamma-incomplete ($float a
) ($float z
) t
)))
1697 ((complex-float-numerical-eval-p a z
)
1698 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
1699 (cz (complex ($float
($realpart z
)) ($float
($imagpart z
)))))
1700 ;; gamma_incomplete returns a regularized result
1701 (complexify (gamma-incomplete ca cz t
))))
1703 ((bigfloat-numerical-eval-p a z
)
1704 (div (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z
))
1705 (simplify (list '(%gamma
) ($bfloat a
)))))
1707 ((complex-bigfloat-numerical-eval-p a z
)
1708 (let ((ca (add ($bfloat
($realpart a
))
1709 (mul '$%i
($bfloat
($imagpart a
)))))
1710 (cz (add ($bfloat
($realpart z
))
1711 (mul '$%i
($bfloat
($imagpart z
))))))
1714 (complex-bfloat-gamma-incomplete ca cz
)
1715 (simplify (list '(%gamma
) ca
))))))
1717 ;; Check for transformations and argument simplification
1719 ((and $gamma_expand
(integerp a
))
1720 ;; An integer. Expand the expression.
1721 (let ((sgn ($sign a
)))
1723 ((member sgn
'($pos $pz
))
1725 (power '$%e
(mul -
1 z
))
1726 (let ((index (gensumindex)))
1730 (let (($gamma_expand nil
))
1731 (simplify (list '(%gamma
) (add index
1)))))
1732 index
0 (sub a
1)))))
1733 ((member sgn
'($neg $nz
)) 0)
1736 ((and $gamma_expand
(setq ratorder
(max-numeric-ratio-p a
2)))
1737 ;; We have a half integral order and $gamma_expand is not NIL.
1738 ;; We expand in a series with the Erfc function
1739 (setq ratorder
(- ratorder
(/ 1 2)))
1741 (format t
"~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in RATORDER~%")
1742 (format t
"~& : a = ~A~%" a
)
1743 (format t
"~& : ratorder = ~A~%" ratorder
))
1746 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
1750 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))
1752 (power -
1 (sub ratorder
1))
1753 (power '$%e
(mul -
1 z
))
1754 (power z
'((rat simp
) 1 2))
1755 (div 1 (simplify (list '(%gamma
) a
)))
1756 (let ((index (gensumindex)))
1759 (power (mul -
1 z
) index
)
1760 (simplify (list '($pochhammer
)
1761 (sub '((rat simp
) 1 2) ratorder
)
1762 (sub ratorder
(add index
1)))))
1763 index
0 (sub ratorder
1))))))
1766 (setq ratorder
(- ratorder
))
1768 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))
1770 (power '$%e
(mul -
1 z
))
1771 (power z
(sub '((rat simp
) 1 2) ratorder
))
1772 (inv (simplify (list '(%gamma
) (sub '((rat simp
) 1 2) ratorder
))))
1773 (let ((index (gensumindex)))
1777 (simplify (list '($pochhammer
)
1778 (sub '((rat simp
) 1 2) ratorder
)
1780 index
0 (sub ratorder
1))))))))
1782 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
1784 (format t
"~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in COND (mplusp)~%"))
1786 (a (simplify (cons '(mplus) (cddr a
)))))
1790 (simplify (list '(%gamma_incomplete_regularized
) a z
))
1791 ;; We factor the second summand.
1792 ;; Some factors vanish and the result is more readable.
1795 (power '$%e
(mul -
1 z
))
1796 (power z
(add a -
1))
1797 (div 1 (simplify (list '(%gamma
) a
)))
1798 (let ((index (gensumindex)))
1802 (simplify (list '($pochhammer
) a index
)))
1807 (simplify (list '(%gamma_incomplete_regularized
) a z
))
1808 ;; We factor the second summand.
1811 (power '$%e
(mul -
1 z
))
1812 (power z
(sub a
(add n
1)))
1813 (div 1 (simplify (list '(%gamma
) (add a
(- n
)))))
1814 (let ((index (gensumindex)))
1818 (simplify (list '($pochhammer
) (add a
(- n
)) index
)))
1820 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
1821 (integerp (second a
))
1822 (integerp (third a
)))
1823 ;; gamma_incomplete_regularized of numeric rational order.
1824 ;; Expand it out so that the resulting order is between 0 and
1825 ;; 1. Use gamma_incomplete_regularized(a+n,z) to do the dirty
1827 (multiple-value-bind (n order
)
1828 (floor (/ (second a
) (third a
)))
1829 ;; a = n + order where 0 <= order < 1.
1830 (let ((rat-order (rat (numerator order
) (denominator order
))))
1833 ;; Nothing to do if the order is already between 0 and 1
1836 ;; Use gamma_incomplete_regularized(a+n,z) above. and
1837 ;; then substitute a=order. This works for n positive or
1839 (let* ((ord (gensym))
1840 (g (simplify (list '(%gamma_incomplete_regularized
) (add ord n
) z
))))
1841 ($substitute rat-order ord g
)))))))
1843 ($hypergeometric_representation
1844 ;; gamma_incomplete_regularized(a,z)
1845 ;; = gamma_incomplete(a,z)/gamma(a)
1846 ;; = (gamma(a) - gamma_incomplete_lower(a,z))/gamma(a)
1847 ;; = 1 - gamma_incomplete_lower(a,z)/gamma(a)
1849 (div (ftake '%gamma_incomplete_lower a z
)
1850 (ftake '%gamma a
))))
1853 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1855 ;;; Implementation of the Logarithm of the Gamma function
1857 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1859 (defmfun $log_gamma
(z)
1860 (simplify (list '(%log_gamma
) z
)))
1862 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1864 (defprop $log_gamma %log_gamma alias
)
1865 (defprop $log_gamma %log_gamma verb
)
1867 (defprop %log_gamma $log_gamma reversealias
)
1868 (defprop %log_gamma $log_gamma noun
)
1870 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1872 (defprop %log_gamma simp-log-gamma operators
)
1874 ;;; Logarithm of the Gamma function distributes over bags
1876 (defprop %log_gamma
(mlist $matrix mequal
) distribute_over
)
1878 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1882 ((mqapply) (($psi array
) 0) z
))
1885 ;; integrate(log_gamma(x),x) = psi[-2](x)
1886 (defun log-gamma-integral (x)
1887 (take '(mqapply) (take '($psi
) -
2) x
))
1889 (putprop '%log_gamma
(list (list 'x
) 'log-gamma-integral
) 'integral
)
1891 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1893 (defun simp-log-gamma (expr z simpflag
)
1895 (setq z
(simpcheck (cadr expr
) simpflag
))
1898 ;; Check for specific values
1902 (and (eq ($sign z
) '$neg
)
1903 (zerop1 (sub z
($truncate z
))))))
1904 ;; We have zero, a negative integer or a float or bigfloat representation.
1906 (intl:gettext
"log_gamma: log_gamma(~:M) is undefined.") z
))
1908 ((eq z
'$inf
) '$inf
)
1910 ;; Check for numerical evaluation
1912 ((float-numerical-eval-p z
)
1913 (complexify (log-gamma-lanczos (complex ($float z
) 0))))
1915 ((complex-float-numerical-eval-p z
)
1918 (complex ($float
($realpart z
)) ($float
($imagpart z
))))))
1920 ((bigfloat-numerical-eval-p z
)
1921 (bfloat-log-gamma ($bfloat z
)))
1923 ((complex-bigfloat-numerical-eval-p z
)
1924 (complex-bfloat-log-gamma
1925 (add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))
1927 ;; Transform to Logarithm of Factorial for integer values
1928 ;; At this point the integer value is positive and not zero.
1931 (simplify (list '(%log
) (simplify (list '(mfactorial) (- z
1))))))
1933 (t (eqtest (list '(%log_gamma
) z
) expr
))))
1935 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1936 ;;; The functions log-gamma-lanczos, bfloat-log-gamma and
1937 ;;; complex-bfloat-log-gamma are modified versions of the related functions
1938 ;;; gamma-lanczos, bffac and cbffac. The functions return the Logarithm of
1939 ;;; the Gamma function. If we have to calculate the quotient of Gamma functions,
1940 ;;; e. g. for the Beta function, it is much more appropriate to use the
1941 ;;; logarithmic versions to avoid overflow.
1943 ;;; Be careful log(gamma(z)) is only for realpart(z) positive equal to
1944 ;;; log_gamma(z). For a negative realpart(z) log_gamma differ by multiple of
1945 ;;; %pi from log(gamma(z)). But we always have exp(log_gamma(z))= gamma(z).
1946 ;;; The terms to get the transformation for log_gamma(-z) are taken from
1947 ;;; functions.wolfram.com.
1948 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1950 (defun log-gamma-lanczos (z)
1951 (declare (type (complex flonum
) z
)
1952 (optimize (safety 3)))
1953 (let ((c (make-array 15 :element-type
'flonum
1955 '(0.99999999999999709182
1956 57.156235665862923517
1957 -
59.597960355475491248
1958 14.136097974741747174
1959 -
0.49191381609762019978
1960 .33994649984811888699e-4
1961 .46523628927048575665e-4
1962 -
.98374475304879564677e-4
1963 .15808870322491248884e-3
1964 -
.21026444172410488319e-3
1965 .21743961811521264320e-3
1966 -
.16431810653676389022e-3
1967 .84418223983852743293e-4
1968 -
.26190838401581408670e-4
1969 .36899182659531622704e-5))))
1970 (declare (type (simple-array flonum
(15)) c
))
1971 (if (minusp (realpart z
))
1978 (abs (floor (realpart z
)))
1979 (- 1 (abs (signum (imagpart z
)))))
1982 (- (log (sin (* (float pi
) (- z
(floor (realpart z
)))))))
1986 (floor (realpart z
))
1987 (signum (imagpart z
))))
1988 (log-gamma-lanczos z
)))
1991 (zgh (+ zh
607/128))
1992 (lnzp (* (/ zh
2) (log zgh
)))
1995 (pp (1- (length c
)) (1- pp
)))
1998 (incf sum
(/ (aref c pp
) (+ z pp
))))))
1999 (+ (log (sqrt (float (* 2 pi
))))
2000 (log (+ ss
(aref c
0)))
2001 (+ (- zgh
) (* 2 lnzp
)))))))
2003 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2005 (defun bfloat-log-gamma (z)
2006 (let (($ratprint nil
)
2007 (bigfloat%pi
($bfloat
'$%pi
)))
2009 ((eq ($sign z
) '$neg
)
2010 (let ((z (mul -
1 z
)))
2013 (mul -
1 bigfloat%pi
'$%i
2014 (simplify (list '(mabs) (simplify (list '($floor
) ($realpart z
)))))
2017 (list '(mabs) (simplify (list '(%signum
) ($imagpart z
)))))))
2018 (simplify (list '(%log
) bigfloat%pi
))
2019 (mul -
1 (simplify (list '(%log
) (mul -
1 z
))))
2021 (simplify (list '(%log
)
2022 (simplify (list '(%sin
)
2025 (sub z
(simplify (list '($floor
) ($realpart z
))))))))))
2028 (simplify (list '($floor
) ($realpart z
)))
2029 (simplify (list '(%signum
) ($imagpart z
)))))
2030 (bfloat-log-gamma z
))))
2032 (let* ((k (* 2 (+ 1 ($entier
(* 0.41 $fpprec
)))))
2033 (m ($bfloat bigfloatone
))
2036 (x ($bfloat bigfloatzero
))
2038 (dotimes (i (/ k
2))
2039 (setq ii
(* 2 (+ i
1)))
2040 (setq m
(mul m
(add z ii -
2) (add z ii -
1)))
2043 (div (ftake '%bern
(+ k
(- ii
) 2))
2044 (* (+ k
(- ii
) 1) (+ k
(- ii
) 2))))
2047 (div (simplify (list '(%log
) (mul 2 bigfloat%pi z
+k
))) 2)
2048 (mul z
+k
(add (simplify (list '(%log
) z
+k
)) x -
1))
2049 (mul -
1 (simplify (list '(%log
) m
)))))))))
2051 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2053 (defun complex-bfloat-log-gamma (z)
2054 (let (($ratprint nil
)
2055 (bigfloat%pi
($bfloat
'$%pi
)))
2057 ((eq ($sign
($realpart z
)) '$neg
)
2058 (let ((z (mul -
1 z
)))
2061 (mul -
1 bigfloat%pi
'$%i
2062 (simplify (list '(mabs) (simplify (list '($floor
) ($realpart z
)))))
2065 (list '(mabs) (simplify (list '(%signum
) ($imagpart z
)))))))
2066 (simplify (list '(%log
) bigfloat%pi
))
2067 (mul -
1 (simplify (list '(%log
) (mul -
1 z
))))
2069 (simplify (list '(%log
)
2070 (simplify (list '(%sin
)
2073 (sub z
(simplify (list '($floor
) ($realpart z
))))))))))
2076 (simplify (list '($floor
) ($realpart z
)))
2077 (simplify (list '(%signum
) ($imagpart z
)))))
2078 (complex-bfloat-log-gamma z
))))
2080 (let* ((k (* 2 (+ 1 ($entier
(* 0.41 $fpprec
)))))
2081 (m ($bfloat bigfloatone
))
2083 (y ($rectform
(power z
+k
2)))
2084 (x ($bfloat bigfloatzero
))
2086 (dotimes (i (/ k
2))
2087 (setq ii
(* 2 (+ i
1)))
2088 (setq m
($rectform
(mul m
(add z ii -
2) (add z ii -
1))))
2092 (div (ftake '%bern
(+ k
(- ii
) 2))
2093 (* (+ k
(- ii
) 1) (+ k
(- ii
) 2))))
2097 (div (simplify (list '(%log
) (mul 2 bigfloat%pi z
+k
))) 2)
2098 (mul z
+k
(add (simplify (list '(%log
) z
+k
)) x -
1))
2099 (mul -
1 (simplify (list '(%log
) m
))))))))))
2101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2103 ;;; Implementation of the Error function Erf(z)
2105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2107 ;;; erf has mirror symmetry
2109 (defprop %erf t commutes-with-conjugate
)
2111 ;;; erf is an odd function
2113 (defprop %erf odd-function-reflect reflection-rule
)
2115 ;;; erf distributes over bags
2117 (defprop %erf
(mlist $matrix mequal
) distribute_over
)
2119 ;;; Derivative of the Error function erf
2124 ((mexpt) $%pi
((rat) -
1 2))
2125 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2)))))
2128 ;;; Integral of the Error function erf
2134 ((mexpt) $%pi
((rat) -
1 2))
2135 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2))))
2136 ((mtimes) z
((%erf
) z
))))
2139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2141 (defun erf-hypergeometric (z)
2142 ; See A&S 7.1.21 or http://functions.wolfram.com/06.25.26.0001.01
2145 (power '$%pi
'((rat simp
) -
1 2))
2146 (ftake '%hypergeometric
2149 (mul -
1 (power z
2)))))
2151 ;;; erf is a simplifying function
2153 (def-simplifier erf
(z)
2156 ;; Check for specific values
2162 ;; Check for numerical evaluation
2164 ((float-numerical-eval-p z
)
2165 (bigfloat::bf-erf
($float z
)))
2166 ((complex-float-numerical-eval-p z
)
2168 (bigfloat::bf-erf
(complex ($float
($realpart z
)) ($float
($imagpart z
))))))
2169 ((bigfloat-numerical-eval-p z
)
2170 (to (bigfloat::bf-erf
(bigfloat:to
($bfloat z
)))))
2171 ((complex-bigfloat-numerical-eval-p z
)
2172 (to (bigfloat::bf-erf
2173 (bigfloat:to
(add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))))
2175 ;; Argument simplification
2177 ((taylorize (mop form
) (second form
)))
2179 (not $erf_representation
)
2181 (mul '$%i
(simplify (list '(%erfi
) (coeff z
'$%i
1)))))
2182 ((apply-reflection-simp (mop form
) z $trigsign
))
2184 ;; Representation through more general functions
2186 ($hypergeometric_representation
2187 (erf-hypergeometric z
))
2189 ;; Transformation to Erfc or Erfi
2191 ((and $erf_representation
2192 (not (eq $erf_representation
'$erf
)))
2193 (case $erf_representation
2195 (sub 1 (take '(%erfc
) z
)))
2197 (mul -
1 '$%i
(take '(%erfi
) (mul '$%i z
))))
2204 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2207 ;; We use the slatec routine for float values.
2208 (slatec:derf
(float z
)))
2210 ;; Compute erf(z) using the relationship
2212 ;; erf(z) = sqrt(z^2)/z*(1 - gamma_incomplete(1/2,z^2)/sqrt(%pi))
2214 ;; When z is real sqrt(z^2)/z is signum(z). For complex z,
2215 ;; sqrt(z^2)/z = 1 if -%pi/2 < arg(z) <= %pi/2 and -1 otherwise.
2217 ;; This relationship has serious round-off issues when z is small
2218 ;; because gamma_incomplete(1/2,z^2)/sqrt(%pi) is near 1.
2220 ;; complex-erf is for (lisp) complex numbers; bfloat-erf is for real
2221 ;; bfloats, and complex-bfloat-erf is for complex bfloats. Care is
2222 ;; taken to return real results for real arguments and imaginary
2223 ;; results for imaginary arguments
2224 (defun complex-erf (z)
2227 (if (or (< (realpart z
) 0.0) (and (= (realpart z
) 0.0) (< (imagpart z
) 0.0)))
2231 (* (/ (sqrt (float pi
))) (gamma-incomplete 0.5 (* z z
)))))))
2233 ((= (imagpart z
) 0.0)
2234 ;; Pure real argument, the result is real
2235 (complex (realpart result
) 0.0))
2236 ((= (realpart z
) 0.0)
2237 ;; Pure imaginary argument, the result is pure imaginary
2238 (complex 0.0 (imagpart result
)))
2242 (defun bfloat-erf (z)
2243 ;; Warning! This has round-off problems when abs(z) is very small.
2244 (let ((1//2 ($bfloat
'((rat simp
) 1 2))))
2245 ;; The argument is real, the result is real too
2248 (simplify (list '(%signum
) z
))
2251 (div 1 (power ($bfloat
'$%pi
) 1//2))
2252 (bfloat-gamma-incomplete 1//2 ($bfloat
(power z
2)))))))))
2254 (defun complex-bfloat-erf (z)
2255 ;; Warning! This has round-off problems when abs(z) is very small.
2256 (let* (($ratprint nil
)
2257 (1//2 ($bfloat
'((rat simp
) 1 2)))
2260 (cdiv (cpower (cpower z
2) 1//2) z
)
2263 (div 1 (power ($bfloat
'$%pi
) 1//2))
2264 (complex-bfloat-gamma-incomplete
2266 ($bfloat
(cpower z
2))))))))
2268 ((zerop1 ($imagpart z
))
2269 ;; Pure real argument, the result is real
2271 ((zerop1 ($realpart z
))
2272 ;; Pure imaginary argument, the result is pure imaginary
2273 (mul '$%i
($imagpart result
)))
2275 ;; A general complex result
2278 (in-package :bigfloat
)
2280 ;; Erf(z) for all z. Z must be a CL real or complex number or a
2281 ;; BIGFLOAT or COMPLEX-BIGFLOAT object. The result will be of the
2284 (cond ((typep z
'cl
:real
)
2285 ;; Use Slatec derf, which should be faster than the series.
2287 ((<= (abs z
) 0.476936)
2288 ;; Use the series A&S 7.1.5 for small x:
2290 ;; erf(z) = 2*z/sqrt(%pi) * sum((-1)^n*z^(2*n)/n!/(2*n+1), n, 0, inf)
2292 ;; The threshold is approximately erf(x) = 0.5. (Doesn't
2293 ;; have to be super accurate.) This gives max accuracy when
2294 ;; using the identity erf(x) = 1 - erfc(x).
2295 (let ((z^
2 (* z z
)))
2296 (/ (* 2 z
(sum-power-series z^
2
2304 ;; The general case.
2306 (cl:real
(maxima::erf z
))
2307 (cl:complex
(maxima::complex-erf z
))
2309 (bigfloat (maxima::$bfloat
(maxima::$expand
(maxima::bfloat-erf
(maxima::to z
))))))
2311 (bigfloat (maxima::$bfloat
(maxima::$expand
(maxima::complex-bfloat-erf
(maxima::to z
))))))))))
2314 ;; Compute erfc(z) via 1 - erf(z) is not very accurate if erf(z) is
2315 ;; near 1. Wolfram says
2317 ;; erfc(z) = 1 - sqrt(z^2)/z * (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2, z^2))
2319 ;; For real(z) > 0, sqrt(z^2)/z is 1 so
2321 ;; erfc(z) = 1 - (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2322 ;; = 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2)
2324 ;; For real(z) < 0, sqrt(z^2)/z is -1 so
2326 ;; erfc(z) = 1 + (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2327 ;; = 2 - 1/sqrt(pi)*gamma_incomplete(1/2,z^2)
2328 (flet ((gamma-inc (z)
2331 (maxima::gamma-incomplete
0.5 z
))
2333 (bigfloat:to
(maxima::$bfloat
2334 (maxima::bfloat-gamma-incomplete
(maxima::$bfloat maxima
::1//2)
2337 (bigfloat:to
(maxima::$bfloat
2338 (maxima::complex-bfloat-gamma-incomplete
(maxima::$bfloat maxima
::1//2)
2339 (maxima::to z
))))))))
2340 (if (>= (realpart z
) 0)
2341 (/ (gamma-inc (* z z
))
2344 (/ (gamma-inc (* z z
))
2347 (in-package :maxima
)
2349 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2351 ;;; Implementation of the Generalized Error function Erf(z1,z2)
2353 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2355 ;;; Generalized Erf has mirror symmetry
2357 (defprop %erf_generalized t commutes-with-conjugate
)
2359 ;;; Generalized Erf distributes over bags
2361 (defprop %erf_generalized
(mlist $matrix mequal
) distribute_over
)
2363 ;;; Generalized Erf is antisymmetric Erf(z1,z2) = - Erf(z2,z1)
2366 (:load-toplevel
:execute
)
2367 (let (($context
'$global
) (context '$global
))
2368 (meval '(($declare
) %erf_generalized $antisymmetric
))
2369 ;; Let's remove built-in symbols from list for user-defined properties.
2370 (setq $props
(remove '%erf_generalized $props
))))
2372 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2374 (defprop %erf_generalized
2376 ;; derivative wrt z1
2378 ((mexpt) $%pi
((rat) -
1 2))
2379 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z1
2))))
2380 ;; derviative wrt z2
2382 ((mexpt) $%pi
((rat) -
1 2))
2383 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z2
2)))))
2386 ;;; ----------------------------------------------------------------------------
2388 (defprop %erf_generalized simplim%erf_generalized simplim%function
)
2390 (defun simplim%erf_generalized
(expr var val
)
2391 ;; Look for the limit of the arguments.
2392 (let ((z1 (limit (cadr expr
) var val
'think
))
2393 (z2 (limit (caddr expr
) var val
'think
)))
2395 ;; Handle infinities at this place.
2397 (alike1 z2
'((mtimes) -
1 $minf
)))
2398 (sub 1 (take '(%erf
) z1
)))
2400 (alike1 z2
'((mtimes) -
1 $inf
)))
2401 (sub (mul -
1 (take '(%erf
) z1
)) 1))
2403 (alike1 z1
'((mtimes) -
1 $minf
)))
2404 (sub (take '(%erf
) z2
) 1))
2406 (alike1 z1
'((mtimes) -
1 $inf
)))
2407 (add (take '(%erf
) z2
) 1))
2409 ;; All other cases are handled by the simplifier of the function.
2410 (simplify (list '(%erf_generalized
) z1 z2
))))))
2412 ;;; ----------------------------------------------------------------------------
2414 (def-simplifier erf_generalized
(z1 z2
)
2417 ;; Check for specific values
2419 ((and (zerop1 z1
) (zerop1 z2
)) 0)
2420 ((zerop1 z1
) (take '(%erf
) z2
))
2421 ((zerop1 z2
) (mul -
1 (take '(%erf
) z1
)))
2423 (alike1 z2
'((mtimes) -
1 $minf
)))
2424 (sub 1 (take '(%erf
) z1
)))
2426 (alike1 z2
'((mtimes) -
1 $inf
)))
2427 (sub (mul -
1 (take '(%erf
) z1
)) 1))
2429 (alike1 z1
'((mtimes) -
1 $minf
)))
2430 (sub (take '(%erf
) z2
) 1))
2432 (alike1 z1
'((mtimes) -
1 $inf
)))
2433 (add (take '(%erf
) z2
) 1))
2435 ;; Check for numerical evaluation. Use erf(z1,z2) = erf(z2)-erf(z1)
2437 ((float-numerical-eval-p z1 z2
)
2438 (- (bigfloat::bf-erf
($float z2
))
2439 (bigfloat::bf-erf
($float z1
))))
2440 ((complex-float-numerical-eval-p z1 z2
)
2444 (complex ($float
($realpart z2
)) ($float
($imagpart z2
))))
2446 (complex ($float
($realpart z1
)) ($float
($imagpart z1
)))))))
2447 ((bigfloat-numerical-eval-p z1 z2
)
2449 (bigfloat::bf-erf
(bigfloat:to
($bfloat z2
)))
2450 (bigfloat::bf-erf
(bigfloat:to
($bfloat z1
))))))
2451 ((complex-bigfloat-numerical-eval-p z1 z2
)
2454 (bigfloat:to
(add ($bfloat
($realpart z2
)) (mul '$%i
($bfloat
($imagpart z2
))))))
2456 (bigfloat:to
(add ($bfloat
($realpart z1
)) (mul '$%i
($bfloat
($imagpart z1
)))))))))
2458 ;; Argument simplification
2460 ((and $trigsign
(great (mul -
1 z1
) z1
) (great (mul -
1 z2
) z2
))
2461 (mul -
1 (simplify (list '(%erf_generalized
) (mul -
1 z1
) (mul -
1 z2
)))))
2463 ;; Representation through more general functions
2465 ($hypergeometric_representation
2466 (sub (erf-hypergeometric z2
) (erf-hypergeometric z1
)))
2468 ;; Transformation to Erf
2470 ($erf_representation
2471 (sub (simplify (list '(%erf
) z2
)) (simplify (list '(%erf
) z1
))))
2476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2478 ;;; Implementation of the Complementary Error function Erfc(z)
2480 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2482 (defprop %erfc t commutes-with-conjugate
)
2484 ;;; Complementary Error function distributes over bags
2486 (defprop %erfc
(mlist $matrix mequal
) distribute_over
)
2488 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2493 ((mexpt) $%pi
((rat) -
1 2))
2494 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2)))))
2497 ;;; Integral of the Error function erfc
2503 ((mexpt) $%pi
((rat) -
1 2))
2504 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2))))
2505 ((mtimes) z
((%erfc
) z
))))
2508 ;;; ----------------------------------------------------------------------------
2510 (defprop %erfc simplim%erfc simplim%function
)
2512 (defun simplim%erfc
(expr var val
)
2513 ;; Look for the limit of the arguments.
2514 (let ((z (limit (cadr expr
) var val
'think
)))
2516 ;; Handle infinities at this place.
2519 ((eq z
'$infinity
) ;; parallel to code in simplim%erf-%tanh
2520 (destructuring-let (((rpart . ipart
) (trisplit (cadr expr
)))
2522 (setq rlim
(limit rpart var val
'think
))
2524 (limit (m* rpart
(m^t ipart -
1)) var val
'think
))
2525 (setq ans
($asksign
(m+ `((mabs) ,ans
) -
1)))
2526 (cond ((or (eq ans
'$pos
) (eq ans
'$zero
))
2527 (cond ((eq rlim
'$inf
) 0)
2528 ((eq rlim
'$minf
) 2)
2531 ((eq z
'$ind
) '$ind
)
2533 ;; All other cases are handled by the simplifier of the function.
2534 (simplify (list '(%erfc
) z
))))))
2536 ;;; ----------------------------------------------------------------------------
2538 (def-simplifier erfc
(z)
2541 ;; Check for specific values
2547 ;; Check for numerical evaluation.
2549 ((numerical-eval-p z
)
2550 (to (bigfloat::bf-erfc
(bigfloat:to z
))))
2552 ;; Argument simplification
2554 ((taylorize (mop form
) (second form
)))
2555 ((and $trigsign
(great (mul -
1 z
) z
))
2556 (sub 2 (simplify (list '(%erfc
) (mul -
1 z
)))))
2558 ;; Representation through more general functions
2560 ($hypergeometric_representation
2561 (sub 1 (erf-hypergeometric z
)))
2563 ;; Transformation to Erf or Erfi
2565 ((and $erf_representation
2566 (not (eq $erf_representation
'$erfc
)))
2567 (case $erf_representation
2569 (sub 1 (take '(%erf
) z
)))
2571 (add 1 (mul '$%i
(take '(%erfi
) (mul '$%i z
)))))
2578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2580 ;;; Implementation of the Imaginary Error function Erfi(z)
2582 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2584 ;;; erfi has mirror symmetry
2586 (defprop %erfi t commutes-with-conjugate
)
2588 ;;; erfi is an odd function
2590 (defprop %erfi odd-function-reflect reflection-rule
)
2592 ;;; erfi distributes over bags
2594 (defprop %erfi
(mlist $matrix mequal
) distribute_over
)
2596 ;;; Derivative of the Error function erfi
2601 ((mexpt) $%pi
((rat) -
1 2))
2602 ((mexpt) $%e
((mexpt) z
2))))
2605 ;;; Integral of the Error function erfi
2611 ((mexpt) $%pi
((rat) -
1 2))
2612 ((mexpt) $%e
((mexpt) z
2)))
2613 ((mtimes) z
((%erfi
) z
))))
2616 ;;; ----------------------------------------------------------------------------
2618 (defprop %erfi simplim%erfi simplim%function
)
2620 (defun simplim%erfi
(expr var val
)
2621 ;; Look for the limit of the arguments.
2622 (let ((z (limit (cadr expr
) var val
'think
)))
2624 ;; Handle infinities at this place.
2625 ((eq z
'$inf
) '$inf
)
2626 ((eq z
'$minf
) '$minf
)
2628 ;; All other cases are handled by the simplifier of the function.
2629 (simplify (list '(%erfi
) z
))))))
2631 ;;; ----------------------------------------------------------------------------
2633 (in-package :bigfloat
)
2636 ;; Use the relationship erfi(z) = -%i*erf(%i*z)
2637 (let* ((iz (complex (- (imagpart z
)) (realpart z
))) ; %i*z
2638 (result (bf-erf iz
)))
2639 (complex (imagpart result
) (- (realpart result
))))))
2640 ;; Take care to return real results when the argument is real.
2644 (realpart (erfi z
)))
2647 (in-package :maxima
)
2649 ;;; erfi is an simplifying function
2651 (def-simplifier erfi
(z)
2654 ;; Check for specific values
2657 ((eq z
'$inf
) '$inf
)
2658 ((eq z
'$minf
) '$minf
)
2660 ;; Check for numerical evaluation. Use erfi(z) = -%i*erf(%i*z).
2662 ((numerical-eval-p z
)
2663 (to (bigfloat::bf-erfi
(bigfloat:to z
))))
2665 ;; Argument simplification
2667 ((taylorize (mop form
) (second form
)))
2670 (mul '$%i
(simplify (list '(%erf
) (coeff z
'$%i
1)))))
2671 ((apply-reflection-simp (mop form
) z $trigsign
))
2673 ;; Representation through more general functions
2675 ($hypergeometric_representation
2676 (mul -
1 '$%i
(erf-hypergeometric (mul '$%i z
))))
2678 ;; Transformation to Erf or Erfc
2680 ((and $erf_representation
2681 (not (eq $erf_representation
'$erfi
)))
2682 (case $erf_representation
2684 (mul -
1 '$%i
(take '(%erf
) (mul '$%i z
))))
2686 (sub (mul '$%i
(take '(%erfc
) (mul '$%i z
))) '$%i
))
2693 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2695 ;;; The implementation of the Inverse Error function
2697 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2699 ;;; The Inverse Error function distributes over bags
2701 (defprop %inverse_erf
(mlist $matrix mequal
) distribute_over
)
2703 ;;; inverse_erf is the inverse of the erf function
2705 (defprop %inverse_erf %erf $inverse
)
2706 (defprop %erf %inverse_erf $inverse
)
2708 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2710 ;;; Differentiation of the Inverse Error function
2712 (defprop %inverse_erf
2716 ((mexpt) $%pi
((rat) 1 2))
2717 ((mexpt) $%e
((mexpt) ((%inverse_erf
) z
) 2))))
2720 ;;; Integral of the Inverse Error function
2722 (defprop %inverse_erf
2725 ((mexpt) $%pi
((rat) -
1 2))
2726 ((mexpt) $%e
((mtimes) -
1 ((mexpt) ((%inverse_erf
) z
) 2)))))
2729 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2731 ;;; We support a simplim%function. The function is looked up in simplimit and
2732 ;;; handles specific values of the function.
2734 (defprop %inverse_erf simplim%inverse_erf simplim%function
)
2736 (defun simplim%inverse_erf
(expr var val
)
2737 ;; Look for the limit of the argument.
2738 (let ((z (limit (cadr expr
) var val
'think
)))
2740 ;; Handle an argument 1 at this place
2742 ((onep1 (mul -
1 z
)) '$minf
)
2744 ;; All other cases are handled by the simplifier of the function.
2745 (simplify (list '(%inverse_erf
) z
))))))
2747 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2749 ;;; The Inverse Error function is a simplifying function
2751 (def-simplifier inverse_erf
(z)
2756 (intl:gettext
"inverse_erf: inverse_erf(~:M) is undefined.") z
))
2758 ((numerical-eval-p z
)
2759 (to (bigfloat::bf-inverse-erf
(bigfloat:to z
))))
2760 ((taylorize (mop form
) (cadr form
)))
2764 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2766 ;;; The implementation of the Inverse Complementary Error function
2768 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2770 ;;; Inverse Complementary Error function distributes over bags
2772 (defprop %inverse_erfc
(mlist $matrix mequal
) distribute_over
)
2774 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2776 ;;; inverse_erfc is the inverse of the erfc function
2778 (defprop %inverse_erfc %erfc $inverse
)
2779 (defprop %erfc %inverse_erfc $inverse
)
2782 ;;; Differentiation of the Inverse Complementary Error function
2784 (defprop %inverse_erfc
2788 ((mexpt) $%pi
((rat) 1 2))
2789 ((mexpt) $%e
((mexpt) ((%inverse_erfc
) z
) 2))))
2792 ;;; Integral of the Inverse Complementary Error function
2794 (defprop %inverse_erfc
2797 ((mexpt) $%pi
((rat) -
1 2))
2799 ((mtimes) -
1 ((mexpt) ((%inverse_erfc
) z
) 2)))))
2802 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2804 ;;; We support a simplim%function. The function is looked up in simplimit and
2805 ;;; handles specific values of the function.
2807 (defprop %inverse_erfc simplim%inverse_erfc simplim%function
)
2809 (defun simplim%inverse_erfc
(expr var val
)
2810 ;; Look for the limit of the argument.
2811 (let ((z (limit (cadr expr
) var val
'think
)))
2813 ;; Handle an argument 0 at this place
2818 ((zerop1 (add z -
2)) '$minf
)
2820 ;; All other cases are handled by the simplifier of the function.
2821 (simplify (list '(%inverse_erfc
) z
))))))
2823 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2825 ;;; Inverse Complementary Error function is a simplifying function
2826 (def-simplifier inverse_erfc
(z)
2829 (zerop1 (add z -
2)))
2831 (intl:gettext
"inverse_erfc: inverse_erfc(~:M) is undefined.") z
))
2833 ((numerical-eval-p z
)
2834 (to (bigfloat::bf-inverse-erfc
(bigfloat:to z
))))
2835 ((taylorize (mop form
) (cadr form
)))
2839 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2841 ;;; Implementation of the Newton algorithm to calculate numerical values
2842 ;;; of the Inverse Error functions in float or bigfloat precision.
2843 ;;; The algorithm is a modified version of the routine in newton1.mac.
2845 (defvar *debug-newton
* nil
)
2846 (defvar *newton-maxcount
* 1000)
2847 (defvar *newton-epsilon-factor
* 50)
2848 (defvar *newton-epsilon-factor-float
* 10)
2850 (defun float-newton (expr var x0 eps
)
2851 (do ((s (sdiff expr var
))
2854 (count 0 (+ count
1)))
2855 ((> count
*newton-maxcount
*)
2857 (intl:gettext
"float-newton: Newton does not converge for ~:M") expr
))
2858 (setq sn
($float
(maxima-substitute xn var expr
)))
2859 (when (< (abs sn
) eps
) (return xn
))
2860 (when *debug-newton
* (format t
"~&xn = ~A~%" xn
))
2861 (setq xn
($float
(sub xn
(div sn
(maxima-substitute xn var s
)))))))
2863 (defun bfloat-newton (expr var x0 eps
)
2864 (do ((s (sdiff expr var
))
2867 (count 0 (+ count
1)))
2868 ((> count
*newton-maxcount
*)
2870 (intl:gettext
"bfloat-newton: Newton does not converge for ~:M") expr
))
2871 (setq sn
($bfloat
(maxima-substitute xn var expr
)))
2872 (when (eq ($sign
(sub (simplify (list '(mabs) sn
)) eps
)) '$neg
)
2874 (when *debug-newton
* (format t
"~&xn = ~A~%" xn
))
2875 (setq xn
($bfloat
(sub xn
(div sn
(maxima-substitute xn var s
)))))))
2878 (in-package :bigfloat
)
2880 ;; Compute inverse_erf(z) for z a real or complex number, including
2881 ;; bigfloat objects. The value is computing using a Newton iteration
2882 ;; to solve erf(x) = z.
2883 (defun bf-inverse-erf (z)
2888 (intl:gettext
"bf-inverse-erf: inverse_erf(~M) is undefined")
2890 ((minusp (realpart z
))
2891 ;; inverse_erf is odd because erf is.
2892 (- (bf-inverse-erf (- z
))))
2896 ;; Find an approximate solution for x = inverse_erf(z).
2898 (cond ((<= (abs z
) 1)
2899 ;; For small z, inverse_erf(z) = z*sqrt(%pi)/2
2900 ;; + O(z^3). Thus, x = z*sqrt(%pi)/2 is our
2901 ;; initial starting point.
2902 (* z
(sqrt (%pi z
)) 1/2))
2904 ;; For |z| > 1 and realpart(z) >= 0, we have
2905 ;; the asymptotic series z = erf(x) = 1 -
2906 ;; exp(-x^2)/x/sqrt(%pi).
2909 ;; x = sqrt(-log(x*sqrt(%pi)*(1-z))
2911 ;; We can use this as a fixed-point iteration
2912 ;; to find x, and we can start the iteration at
2913 ;; x = 1. Just do one more iteration. I (RLT)
2914 ;; think that's close enough to get the Newton
2915 ;; algorithm to converge.
2916 (let* ((sp (sqrt (%pi z
)))
2917 (a (sqrt (- (log (* sp
(- 1 z
)))))))
2918 (setf a
(sqrt (- (log (* a sp
(- 1 z
))))))
2919 (setf a
(sqrt (- (log (* a sp
(- 1 z
)))))))))))
2920 (when maxima
::*debug-newton
*
2921 (format t
"approx = ~S~%" result
))
2923 (let ((two/sqrt-pi
(/ 2 (sqrt (%pi z
))))
2925 ;; Try to pick a reasonable epsilon value for the
2926 ;; Newton iteration.
2927 (cond ((<= (abs z
) 1)
2929 (cl:real
(* maxima
::*newton-epsilon-factor-float
*
2930 maxima
::+flonum-epsilon
+))
2931 (t (* maxima
::*newton-epsilon-factor
* (epsilon z
)))))
2933 (* maxima
::*newton-epsilon-factor
* (epsilon z
))))))
2934 (when maxima
::*debug-newton
*
2935 (format t
"eps = ~S~%" eps
))
2937 ;; Derivative of erf(x)
2938 (* two
/sqrt-pi
(exp (- (* x x
))))))
2945 (defun bf-inverse-erfc (z)
2948 (intl:gettext
"bf-inverse-erfc: inverse_erfc(~M) is undefined")
2955 ;; Find an approximate solution for x =
2956 ;; inverse_erfc(z). We have inverse_erfc(z) =
2957 ;; inverse_erf(1-z), so that's a good starting point.
2958 ;; We don't need full precision, so a float value is
2959 ;; good enough. But if 1-z is 1, inverse_erf is
2960 ;; undefined, so we need to do something else.
2962 (let ((1-z (float (- 1 z
) 0.0)))
2964 (if (minusp (realpart z
))
2965 (bf-inverse-erf (+ 1 (* 5 maxima
::+flonum-epsilon
+)))
2966 (bf-inverse-erf (- 1 (* 5 maxima
::+flonum-epsilon
+)))))
2968 (bf-inverse-erf 1-z
))))))
2969 (when maxima
::*debug-newton
*
2970 (format t
"approx = ~S~%" result
))
2972 (let ((-two/sqrt-pi
(/ -
2 (sqrt (%pi z
))))
2973 (eps (* maxima
::*newton-epsilon-factor
* (epsilon z
))))
2974 (when maxima
::*debug-newton
*
2975 (format t
"eps = ~S~%" eps
))
2977 ;; Derivative of erfc(x)
2978 (* -two
/sqrt-pi
(exp (- (* x x
))))))
2979 (bf-newton #'bf-erfc
2985 ;; Newton iteration for solving f(x) = z, given f and the derivative
2987 (defun bf-newton (f df z start eps
)
2989 (delta (/ (- (funcall f start
) z
)
2991 (/ (- (funcall f x
) z
)
2993 (count 0 (1+ count
)))
2994 ((or (< (abs delta
) (* (abs x
) eps
))
2995 (> count maxima
::*newton-maxcount
*))
2996 (if (> count maxima
::*newton-maxcount
*)
2998 (intl:gettext
"bf-newton: failed to converge after ~M iterations: delta = ~S, x = ~S eps = ~S")
3001 (when maxima
::*debug-newton
*
3002 (format t
"x = ~S, abs(delta) = ~S relerr = ~S~%"
3003 x
(abs delta
) (/ (abs delta
) (abs x
))))
3004 (setf x
(- x delta
))))
3006 (in-package :maxima
)
3008 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3010 ;;; Implementation of the Fresnel Integral S(z)
3012 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3014 ;;; fresnel_s distributes over bags
3016 (defprop %fresnel_s
(mlist $matrix mequal
) distribute_over
)
3018 ;;; fresnel_s has mirror symmetry
3020 (defprop %fresnel_s t commutes-with-conjugate
)
3022 ;;; fresnel_s is an odd function
3024 ;;; Maxima has two mechanism to define a reflection property
3025 ;;; 1. Declare the feature oddfun or evenfun
3026 ;;; 2. Put a reflection rule on the property list
3028 ;;; The second way is used for the trig functions. We use it here too.
3030 ;;; This would be the first way to give the property of an odd function.
3032 ; (:load-toplevel :execute)
3033 ; (let (($context '$global) (context '$global))
3034 ; (meval '(($declare) %fresnel_s $oddfun))
3035 ; ;; Let's remove built-in symbols from list for user-defined properties.
3036 ; (setq $props (remove '%fresnel_s $props))))
3038 (defprop %fresnel_s odd-function-reflect reflection-rule
)
3040 ;;; Differentiation of the Fresnel Integral S
3044 ((%sin
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))
3047 ;;; Integration of the Fresnel Integral S
3052 ((mtimes) z
((%fresnel_s
) z
))
3055 ((%cos
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))))
3058 ;;; Limits of the Fresnel Integral S
3060 (defprop %fresnel_s simplim%fresnel_s simplim%function
)
3061 (defun simplim%fresnel_s
(exp var val
)
3062 (let ((arg (limit (cadr exp
) var val
'think
)))
3063 (cond ((eq arg
'$inf
)
3068 `((%fresnel_s
) ,arg
)))))
3070 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3072 (defvar *fresnel-maxit
* 1000)
3073 (defvar *fresnel-eps
* (* 2 +flonum-epsilon
+))
3074 (defvar *fresnel-min
* 1e-32)
3076 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3077 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3079 (in-package :bigfloat
)
3081 (defun bf-fresnel (z)
3082 (let* ((eps (epsilon z
))
3083 (maxit maxima
::*fresnel-maxit
*)
3086 ;; For very small x, we have
3087 ;; fresnel_s(x) = %pi/6*z^3
3089 (s (* (/ bf-pi
6) z z z
))
3091 (when (> (abs z
) eps
)
3094 (when maxima
::*debug-gamma
*
3095 (format t
"~& in FRESNEL series expansion.~%"))
3096 (let ((sums 0) (sumc z
))
3099 (fact (* (/ bf-pi
2) (* z z
)))
3106 (maxima::merror
(intl:gettext
"fresnel: series expansion failed for (COMPLEX-BFLOAT-FRESNEL ~:M).") z
))
3107 (setq term
(* term
(/ fact k
)))
3108 (setq sum
(+ sum
(/ (* sign term
) n
)))
3109 (setq test
(* (abs sum
) eps
))
3112 (setq sign
(- sign
))
3118 (if (< (abs term
) test
)
3123 (let* ((sqrt-pi (sqrt bf-pi
))
3124 (z+ (* (complex 1/2 1/2)
3127 (z- (* (complex 1/2 -
1/2)
3132 (setq s
(* (complex 1/4 1/4)
3133 (+ erf
+ (* (complex 0 -
1) erf-
))))
3134 (setq c
(* (complex 1/4 -
1/4)
3135 (+ erf
+ (* (complex 0 1) erf-
))))))))
3138 (defun bf-fresnel-s (z)
3139 (if (and (complexp z
) (zerop (realpart z
)))
3140 ;; A pure imaginary argument. Use fresnel_s(%i*x)=-%i*fresnel_s(x).
3142 (- (bf-fresnel-s (imagpart z
))))
3143 (let ((fs (bf-fresnel z
)))
3148 (defun bf-fresnel-c (z)
3149 (if (and (complexp z
) (zerop (realpart z
)))
3150 ;; A pure imaginary argument. Use fresnel_c(%i*x)=%i*fresnel_c(x).
3152 (bf-fresnel-c (imagpart z
)))
3153 (let ((fc (nth-value 1 (bf-fresnel z
))))
3158 (in-package :maxima
)
3160 ;;; fresnel_s is a simplifying function
3161 (def-simplifier fresnel_s
(z)
3164 ;; Check for specific values
3167 ((eq z
'$inf
) '((rat simp
) 1 2))
3168 ((eq z
'$minf
) '((rat simp
) -
1 2))
3170 ;; Check for numerical evaluation
3171 ((numerical-eval-p z
)
3172 (to (bigfloat::bf-fresnel-s
(bigfloat::to z
))))
3174 ;; Check for argument simplification
3176 ((taylorize (mop form
) (second form
)))
3177 ((and $%iargs
(multiplep z
'$%i
))
3178 (mul -
1 '$%i
(simplify (list '(%fresnel_s
) (coeff z
'$%i
1)))))
3179 ((apply-reflection-simp (mop form
) z $trigsign
))
3181 ;; Representation through equivalent functions
3183 ($erf_representation
3185 (div (add 1 '$%i
) 4)
3190 (mul (div (add 1 '$%i
) 2) (power '$%pi
'((rat simp
) 1 2)) z
)))
3195 (mul (div (sub 1 '$%i
) 2)
3196 (power '$%pi
'((rat simp
) 1 2)) z
)))))))
3198 ($hypergeometric_representation
3199 (mul (div (mul '$%pi
(power z
3)) 6)
3200 (ftake '%hypergeometric
3201 (list '(mlist) (div 3 4))
3202 (list '(mlist) (div 3 2) (div 7 4))
3203 (mul -
1 (div (mul (power '$%pi
2) (power z
4)) 16)))))
3207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3209 ;;; Implementation of the Fresnel Integral C(z)
3211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3213 ;;; fresnel_c distributes over bags
3215 (defprop %fresnel_c
(mlist $matrix mequal
) distribute_over
)
3217 ;;; fresnel_c has mirror symmetry
3219 (defprop %fresnel_c t commutes-with-conjugate
)
3221 ;;; fresnel_c is an odd function
3222 ;;; Maxima has two mechanism to define a reflection property
3223 ;;; 1. Declare the feature oddfun or evenfun
3224 ;;; 2. Put a reflection rule on the property list
3226 ;;; The second way is used for the trig functions. We use it here too.
3228 (defprop %fresnel_c odd-function-reflect reflection-rule
)
3230 ;;; Differentiation of the Fresnel Integral C
3234 ((%cos
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))
3237 ;;; Integration of the Fresnel Integral C
3242 ((mtimes) z
((%fresnel_c
) z
))
3245 ((%sin
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))))
3248 ;;; Limits of the Fresnel Integral C
3250 (defprop %fresnel_c simplim%fresnel_c simplim%function
)
3251 (defun simplim%fresnel_c
(exp var val
)
3252 (let ((arg (limit (cadr exp
) var val
'think
)))
3253 (cond ((eq arg
'$inf
)
3258 `((%fresnel_c
) ,arg
)))))
3260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3262 ;;; fresnel_c is a simplifying function
3263 (def-simplifier fresnel_c
(z)
3266 ;; Check for specific values
3269 ((eq z
'$inf
) '((rat simp
) 1 2))
3270 ((eq z
'$minf
) '((rat simp
) -
1 2))
3272 ;; Check for numerical evaluation
3273 ((numerical-eval-p z
)
3274 (to (bigfloat::bf-fresnel-c
(bigfloat::to z
))))
3277 ;; Check for argument simplification
3279 ((taylorize (mop form
) (second form
)))
3280 ((and $%iargs
(multiplep z
'$%i
))
3281 (mul '$%i
(simplify (list '(%fresnel_c
) (coeff z
'$%i
1)))))
3282 ((apply-reflection-simp (mop form
) z $trigsign
))
3284 ;; Representation through equivalent functions
3286 ($erf_representation
3288 (div (sub 1 '$%i
) 4)
3293 (mul (div (add 1 '$%i
) 2) (power '$%pi
'((rat simp
) 1 2)) z
)))
3298 (mul (div (sub 1 '$%i
) 2)
3299 (power '$%pi
'((rat simp
) 1 2)) z
)))))))
3301 ($hypergeometric_representation
3303 (ftake '%hypergeometric
3304 (list '(mlist) (div 1 4))
3305 (list '(mlist) (div 1 2) (div 5 4))
3306 (mul -
1 (div (mul (power '$%pi
2) (power z
4)) 16)))))
3310 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3312 ;;; Implementation of the Beta function
3314 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3316 ;;; The code for the implementation of the beta function is in the files
3317 ;;; csimp2.lisp, simp.lisp and mactex.lisp.
3318 ;;; At this place we only implement the operator property SYMMETRIC.
3320 ;;; Beta is symmetric beta(a,b) = beta(b,a)
3323 (:load-toplevel
:execute
)
3324 (let (($context
'$global
) (context '$global
))
3325 (meval '(($declare
) %beta $symmetric
))
3326 ;; Let's remove built-in symbols from list for user-defined properties.
3327 (setq $props
(remove '%beta $props
))))
3329 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3331 ;;; Implementation of the Incomplete Beta function
3333 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3335 (defvar *beta-incomplete-maxit
* 10000)
3336 (defvar *beta-incomplete-eps
* 1.0e-15)
3338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3340 ;;; beta_incomplete distributes over bags
3342 (defprop %beta_incomplete
(mlist $matrix mequal
) distribute_over
)
3344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3346 (defprop %beta_incomplete
3350 ((mtimes) ((%beta_incomplete
) a b z
) ((%log
) z
))
3352 ((mexpt) ((%gamma
) a
) 2)
3353 (($hypergeometric_regularized
)
3354 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3355 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3363 ((mqapply) (($psi array
) 0) b
)
3364 ((mtimes) -
1 ((mqapply) (($psi array
) 0) ((mplus) a b
)))))
3366 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z
)))
3367 ((%log
) ((mplus) 1 ((mtimes) -
1 z
))))
3369 ((mexpt) ((%gamma
) b
) 2)
3370 (($hypergeometric_regularized
)
3371 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3372 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3373 ((mplus) 1 ((mtimes) -
1 z
)))
3374 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) b
)))
3375 ;; The derivative wrt z
3377 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) ((mplus) -
1 b
))
3378 ((mexpt) z
((mplus) -
1 a
))))
3381 ;;; Integral of the Incomplete Beta function
3383 (defprop %beta_incomplete
3388 ((mtimes) -
1 ((%beta_incomplete
) ((mplus) 1 a
) b z
))
3389 ((mtimes) ((%beta_incomplete
) a b z
) z
)))
3392 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3394 (def-simplifier beta_incomplete
(a b z
)
3397 (format t
"~&SIMP-BETA-INCOMPLETE:~%")
3398 (format t
"~& : a = ~A~%" a
)
3399 (format t
"~& : b = ~A~%" b
)
3400 (format t
"~& : z = ~A~%" z
))
3403 ;; Check for specific values
3406 (let ((sgn ($sign
($realpart a
))))
3407 (cond ((member sgn
'($neg $zero
))
3410 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.")
3412 ((member sgn
'($pos $pz
))
3417 ((and (onep1 z
) (eq ($sign
($realpart b
)) '$pos
))
3418 ;; z=1 and realpart(b)>0. Simplify to a Beta function.
3419 ;; If we have to evaluate numerically preserve the type.
3421 ((complex-float-numerical-eval-p a b z
)
3422 (ftake* '%beta
($float a
) ($float b
)))
3423 ((complex-bigfloat-numerical-eval-p a b z
)
3424 (ftake* '%beta
($bfloat a
) ($bfloat b
)))
3426 (ftake* '%beta a b
))))
3429 (and (integer-representation-p a
)
3430 (eq ($sign a
) '$neg
)
3432 (not (integer-representation-p b
)))
3433 (eq ($sign
(add a b
)) '$pos
))))
3434 ;; The argument a is zero or a is negative and the argument b is
3435 ;; not in a valid range. Beta incomplete is undefined.
3436 ;; It would be more correct to return Complex infinity.
3439 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.") a b z
))
3441 ;; Check for numerical evaluation in Float or Bigfloat precision
3443 ((complex-float-numerical-eval-p a b z
)
3445 ((not (and (integer-representation-p a
) (< a
0.0)))
3446 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0))))
3447 (beta-incomplete ($float a
) ($float b
) ($float z
))))
3449 ;; Negative integer a and b is in a valid range. Expand.
3451 (beta-incomplete-expand-negative-integer
3452 (truncate a
) ($float b
) ($float z
))))))
3454 ((complex-bigfloat-numerical-eval-p a b z
)
3456 ((not (and (integer-representation-p a
) (eq ($sign a
) '$neg
)))
3457 (let ((*beta-incomplete-eps
*
3458 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
3459 (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z
))))
3461 ;; Negative integer a and b is in a valid range. Expand.
3463 (beta-incomplete-expand-negative-integer
3464 ($truncate a
) ($bfloat b
) ($bfloat z
))))))
3466 ;; Argument simplifications and transformations
3470 (or (not (integerp a
))
3472 ;; Expand for b a positive integer and a not a negative integer.
3476 (let ((index (gensumindex)))
3480 (simplify (list '($pochhammer
) a index
))
3481 (power (sub 1 z
) index
))
3482 (simplify (list '(mfactorial) index
)))
3483 index
0 (sub b
1)))))
3485 ((and (integerp a
) (plusp a
))
3486 ;; Expand for a a positive integer.
3492 (let ((index (gensumindex)))
3496 (simplify (list '($pochhammer
) b index
))
3498 (simplify (list '(mfactorial) index
)))
3499 index
0 (sub a
1)))))))
3501 ((and (integerp a
) (minusp a
) (integerp b
) (plusp b
) (<= b
(- a
)))
3502 ;; Expand for a a negative integer and b an integer with b <= -a.
3505 (let ((index (gensumindex)))
3508 (mul (simplify (list '($pochhammer
) (sub 1 b
) index
))
3511 (simplify (list '(mfactorial) index
))))
3512 index
0 (sub b
1)))))
3514 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
3516 (a (simplify (cons '(mplus) (cddr a
)))))
3520 (simplify (list '($pochhammer
) a n
))
3521 (simplify (list '($pochhammer
) (add a b
) n
)))
3522 (ftake '%beta_incomplete a b z
))
3524 (power (add a b n -
1) -
1)
3525 (let ((index (gensumindex)))
3529 (simplify (list '($pochhammer
)
3530 (add 1 (mul -
1 a
) (mul -
1 n
))
3532 (simplify (list '($pochhammer
)
3533 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
3535 (mul (power (sub 1 z
) b
)
3536 (power z
(add a n
(mul -
1 index
) -
1))))
3537 index
0 (sub n
1)))))))
3539 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
3540 (let ((n (- (cadr a
)))
3541 (a (simplify (cons '(mplus) (cddr a
)))))
3545 (simplify (list '($pochhammer
) (add 1 (mul -
1 a
) (mul -
1 b
)) n
))
3546 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3547 (ftake '%beta_incomplete a b z
))
3551 (list '($pochhammer
) (add 2 (mul -
1 a
) (mul -
1 b
)) (sub n
1)))
3552 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3553 (let ((index (gensumindex)))
3557 (simplify (list '($pochhammer
) (sub 1 a
) index
))
3558 (simplify (list '($pochhammer
)
3559 (add 2 (mul -
1 a
) (mul -
1 b
))
3561 (mul (power (sub 1 z
) b
)
3562 (power z
(add a
(mul -
1 index
) -
1))))
3563 index
0 (sub n
1)))))))
3565 ($hypergeometric_representation
3566 ;; There are several cases to consider.
3568 ;; For -a not an integer see
3569 ;; http://functions.wolfram.com/06.19.26.0005.01
3571 ;; beta_incomplete(a,b,z) = z^a/a*%f[2,1]([a,1-b],[a+1],z)
3573 ;; For -b not an integer see
3574 ;; http://functions.wolfram.com/06.19.26.0007.01
3576 ;; beta_incomplete(a,b,z) = beta(a,b) -
3577 ;; (1-z)^b*z^a/b*%f[2,1]([1,a+b],[b+1],1-z)
3579 ;; For a+b not a positive integer see
3580 ;; http://functions.wolfram.com/06.19.26.0008.01
3582 ;; beta_incomplete(a,b,z) =
3583 ;; z^a*(-z)^(b-1)/(a+b-1)*%f[2,1]([1-b,-a-b+1],[-a-b+2],1/z)
3584 ;; + z^a*beta(1-a-b,a)*(-z)^(-a)
3586 ;; We need to handle more cases here
3587 (mul (div (power z a
)
3589 (ftake '%hypergeometric
3590 (make-mlist a
(sub 1 b
))
3591 (make-mlist (add 1 a
))
3597 (defun beta-incomplete-expand-negative-integer (a b z
)
3600 (let ((index (gensumindex)) ($simpsum t
))
3603 (mul (simplify (list '($pochhammer
) (sub 1 b
) index
))
3605 (mul (add index a
) (simplify (list '(mfactorial) index
))))
3606 index
0 (sub b
1)))))
3608 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3610 (defun beta-incomplete (a b z
)
3612 ((eq ($sign
(sub (mul ($realpart z
) ($realpart
(add a b
2)))
3613 ($realpart
(add a
1))))
3618 (to (numeric-beta-incomplete b a
(sub 1.0 z
))))))
3620 (to (numeric-beta-incomplete a b z
)))))
3622 (defun numeric-beta-incomplete (a b z
)
3624 (format t
"~&NUMERIC-BETA-INCOMPLETE enters continued fractions~%"))
3625 (let ((a (bigfloat:to a
))
3627 (z (bigfloat:to z
)))
3628 (do* ((beta-maxit *beta-incomplete-maxit
*)
3629 (beta-eps *beta-incomplete-eps
*)
3630 (beta-min (bigfloat:* beta-eps beta-eps
))
3631 (ab (bigfloat:+ a b
))
3632 (ap (bigfloat:+ a
1.0))
3633 (am (bigfloat:- a
1.0))
3635 (d (bigfloat:-
1.0 (bigfloat:/ (bigfloat:* z ab
) ap
)))
3636 (d (if (bigfloat:< (bigfloat:abs d
) beta-min
) beta-min d
))
3637 (d (bigfloat:/ 1.0 d
))
3644 (merror (intl:gettext
"beta_incomplete: continued fractions failed for beta_incomplete(~:M, ~:M, ~:M).") a b z
))
3646 (setq aa
(bigfloat:/ (bigfloat:* m z
(bigfloat:- b m
))
3647 (bigfloat:* (bigfloat:+ am m2
)
3648 (bigfloat:+ a m2
))))
3649 (setq d
(bigfloat:+ 1.0 (bigfloat:* aa d
)))
3650 (when (bigfloat:< (bigfloat:abs d
) beta-min
) (setq d beta-min
))
3651 (setq c
(bigfloat:+ 1.0 (bigfloat:/ aa c
)))
3652 (when (bigfloat:< (bigfloat:abs c
) beta-min
) (setq c beta-min
))
3653 (setq d
(bigfloat:/ 1.0 d
))
3654 (setq h
(bigfloat:* h d c
))
3655 (setq aa
(bigfloat:/ (bigfloat:* -
1
3657 (bigfloat:+ ab m
) z
)
3658 (bigfloat:* (bigfloat:+ a m2
)
3659 (bigfloat:+ ap m2
))))
3660 (setq d
(bigfloat:+ 1.0 (bigfloat:* aa d
)))
3661 (when (bigfloat:< (bigfloat:abs d
) beta-min
) (setq d beta-min
))
3662 (setq c
(bigfloat:+ 1.0 (bigfloat:/ aa c
)))
3663 (when (bigfloat:< (bigfloat:abs c
) beta-min
) (setq c beta-min
))
3664 (setq d
(bigfloat:/ 1.0 d
))
3665 (setq de
(bigfloat:* d c
))
3666 (setq h
(bigfloat:* h de
))
3667 (when (bigfloat:< (bigfloat:abs
(bigfloat:- de
1.0)) beta-eps
)
3669 (format t
"~&Continued fractions finished.~%")
3670 (format t
"~& z = ~A~%" z
)
3671 (format t
"~& a = ~A~%" a
)
3672 (format t
"~& b = ~A~%" b
)
3673 (format t
"~& h = ~A~%" h
))
3679 (bigfloat:expt
(bigfloat:-
1.0 z
) b
)) a
)))
3681 (format t
"~& result = ~A~%" result
))
3684 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3686 ;;; Implementation of the Generalized Incomplete Beta function
3688 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3690 ;;; beta_incomplete_generalized distributes over bags
3692 (defprop %beta_incomplete_generalized
(mlist $matrix mequal
) distribute_over
)
3694 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3696 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
3697 ;;; but not on the negative real axis and for z1 or z2 real and > 1.
3698 ;;; We support a conjugate-function which test these cases.
3700 (defprop %beta_incomplete_generalized
3701 conjugate-beta-incomplete-generalized conjugate-function
)
3703 (defun conjugate-beta-incomplete-generalized (args)
3704 (let ((a (first args
))
3708 (cond ((and (off-negative-real-axisp z1
)
3709 (not (and (zerop1 ($imagpart z1
))
3710 (eq ($sign
(sub ($realpart z1
) 1)) '$pos
)))
3711 (off-negative-real-axisp z2
)
3712 (not (and (zerop1 ($imagpart z2
))
3713 (eq ($sign
(sub ($realpart z2
) 1)) '$pos
))))
3716 '(%beta_incomplete_generalized
)
3717 (simplify (list '($conjugate
) a
))
3718 (simplify (list '($conjugate
) b
))
3719 (simplify (list '($conjugate
) z1
))
3720 (simplify (list '($conjugate
) z2
)))))
3724 (simplify (list '(%beta_incomplete_generalized
)
3727 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3729 (defprop %beta_incomplete_generalized
3734 ((%beta_incomplete
) a b z1
)
3737 ((mexpt) ((%gamma
) a
) 2)
3740 (($hypergeometric_regularized
)
3741 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3742 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3746 (($hypergeometric_regularized
)
3747 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3748 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3751 ((mtimes) ((%beta_incomplete
) a b z2
) ((%log
) z2
)))
3755 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z1
)))
3756 ((%log
) ((mplus) 1 ((mtimes) -
1 z1
))))
3758 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z2
)))
3759 ((%log
) ((mplus) 1 ((mtimes) -
1 z2
))))
3761 ((mexpt) ((%gamma
) b
) 2)
3764 (($hypergeometric_regularized
)
3765 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3766 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3767 ((mplus) 1 ((mtimes) -
1 z1
)))
3768 ((mexpt) ((mplus) 1 ((mtimes) -
1 z1
)) b
))
3770 (($hypergeometric_regularized
)
3771 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3772 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3773 ((mplus) 1 ((mtimes) -
1 z2
)))
3774 ((mexpt) ((mplus) 1 ((mtimes) -
1 z2
)) b
)))))
3775 ;; The derivative wrt z1
3778 ((mplus) 1 ((mtimes) -
1 z1
))
3780 ((mexpt) z1
((mplus) -
1 a
)))
3781 ;; The derivative wrt z2
3784 ((mplus) 1 ((mtimes) -
1 z2
))
3786 ((mexpt) z2
((mplus) -
1 a
))))
3789 ;;; Integral of the Incomplete Beta function
3791 (defprop %beta_incomplete_generalized
3797 ((%beta_incomplete
) ((mplus) 1 a
) b z1
)
3798 ((mtimes) ((%beta_incomplete_generalized
) a b z1 z2
) z1
))
3802 ((%beta_incomplete
) ((mplus) 1 a
) b z2
))
3803 ((mtimes) ((%beta_incomplete_generalized
) a b z1 z2
) z2
)))
3806 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3808 (def-simplifier beta_incomplete_generalized
(a b z1 z2
)
3812 ;; Check for specific values
3815 (let ((sgn ($sign
($realpart a
))))
3816 (cond ((eq sgn
'$neg
)
3819 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3821 ((member sgn
'($pos $pz
))
3822 (mul -
1 (ftake '%beta_incomplete a b z1
)))
3827 (let ((sgn ($sign
($realpart a
))))
3828 (cond ((eq sgn
'$neg
)
3831 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
3833 ((member sgn
'($pos $pz
))
3834 (mul -
1 (ftake '%beta_incomplete a b z2
)))
3838 ((and (onep1 z2
) (or (not (mnump a
)) (not (mnump b
)) (not (mnump z1
))))
3839 (let ((sgn ($sign
($realpart b
))))
3840 (cond ((member sgn
'($pos $pz
))
3841 (sub (ftake* '%beta a b
)
3842 (ftake '%beta_incomplete a b z1
)))
3846 ((and (onep1 z1
) (or (not (mnump a
)) (not (mnump b
)) (not (mnump z2
))))
3847 (let ((sgn ($sign
($realpart b
))))
3848 (cond ((member sgn
'($pos $pz
))
3849 (sub (ftake '%beta_incomplete a b z2
)
3850 (ftake* '%beta a b
)))
3854 ;; Check for numerical evaluation in Float or Bigfloat precision
3856 ((complex-float-numerical-eval-p a b z1 z2
)
3857 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0))))
3858 (sub (beta-incomplete ($float a
) ($float b
) ($float z2
))
3859 (beta-incomplete ($float a
) ($float b
) ($float z1
)))))
3861 ((complex-bigfloat-numerical-eval-p a b z1 z2
)
3862 (let ((*beta-incomplete-eps
*
3863 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
3864 (sub (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z2
))
3865 (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z1
)))))
3867 ;; Check for argument simplifications and transformations
3869 ((and (integerp a
) (plusp a
))
3874 (power (sub 1 z1
) b
)
3875 (let ((index (gensumindex)))
3879 (simplify (list '($pochhammer
) b index
))
3881 (simplify (list '(mfactorial) index
)))
3882 index
0 (sub a
1))))
3884 (power (sub 1 z2
) b
)
3885 (let ((index (gensumindex)))
3889 (simplify (list '($pochhammer
) b index
))
3891 (simplify (list '(mfactorial) index
)))
3892 index
0 (sub a
1)))))))
3894 ((and (integerp b
) (plusp b
))
3900 (let ((index (gensumindex)))
3904 (simplify (list '($pochhammer
) a index
))
3905 (power (sub 1 z2
) index
))
3906 (simplify (list '(mfactorial) index
)))
3907 index
0 (sub b
1))))
3910 (let ((index (gensumindex)))
3914 (simplify (list '($pochhammer
) a index
))
3915 (power (sub 1 z1
) index
))
3916 (simplify (list '(mfactorial) index
)))
3917 index
0 (sub b
1)))))))
3919 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
3921 (a (simplify (cons '(mplus) (cddr a
)))))
3925 (simplify (list '($pochhammer
) a n
))
3926 (simplify (list '($pochhammer
) (add a b
) n
)))
3927 (take '(%beta_incomplete_generalized
) a b z1 z2
))
3929 (power (add a b n -
1) -
1)
3930 (let ((index (gensumindex)))
3934 (simplify (list '($pochhammer
)
3935 (add 1 (mul -
1 a
) (mul -
1 n
))
3937 (simplify (list '($pochhammer
)
3938 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
3941 (mul (power (sub 1 z1
) b
)
3942 (power z1
(add a n
(mul -
1 index
) -
1)))
3943 (mul (power (sub 1 z2
) b
)
3944 (power z2
(add a n
(mul -
1 index
) -
1)))))
3945 index
0 (sub n
1)))))))
3947 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
3948 (let ((n (- (cadr a
)))
3949 (a (simplify (cons '(mplus) (cddr a
)))))
3953 (simplify (list '($pochhammer
) (add 1 (mul -
1 a
) (mul -
1 b
)) n
))
3954 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3955 (take '(%beta_incomplete_generalized
) a b z1 z2
))
3959 (list '($pochhammer
) (add 2 (mul -
1 a
) (mul -
1 b
)) (sub n
1)))
3960 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3961 (let ((index (gensumindex)))
3965 (simplify (list '($pochhammer
) (sub 1 a
) index
))
3966 (simplify (list '($pochhammer
)
3967 (add 2 (mul -
1 a
) (mul -
1 b
))
3970 (mul (power (sub 1 z2
) b
)
3971 (power z2
(add a
(mul -
1 index
) -
1)))
3972 (mul (power (sub 1 z1
) b
)
3973 (power z1
(add a
(mul -
1 index
) -
1)))))
3974 index
0 (sub n
1)))))))
3979 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3981 ;;; Implementation of the Regularized Incomplete Beta function
3983 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3985 ;;; beta_incomplete_regularized distributes over bags
3987 (defprop %beta_incomplete_regularized
(mlist $matrix mequal
) distribute_over
)
3989 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3991 (defprop %beta_incomplete_regularized
3997 (($hypergeometric_regularized
)
3998 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3999 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
)) z
)
4000 ((mexpt) ((%gamma
) b
) -
1)
4001 ((%gamma
) ((mplus) a b
))
4004 ((%beta_incomplete_regularized
) a b z
)
4006 ((mtimes) -
1 ((mqapply) (($psi array
) 0) a
))
4007 ((mqapply) (($psi array
) 0) ((mplus) a b
))
4012 ((%beta_incomplete_regularized
) b a
((mplus) 1 ((mtimes) -
1 z
)))
4014 ((mqapply) (($psi array
) 0) b
)
4015 ((mtimes) -
1 ((mqapply) (($psi array
) 0) ((mplus) a b
)))
4016 ((mtimes) -
1 ((%log
) ((mplus) 1 ((mtimes) -
1 z
))))))
4018 ((mexpt) ((%gamma
) a
) -
1)
4020 ((%gamma
) ((mplus) a b
))
4021 (($hypergeometric_regularized
)
4022 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
4023 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
4024 ((mplus) 1 ((mtimes) -
1 z
)))
4025 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) b
)))
4026 ;; The derivative wrt z
4028 ((mexpt) ((%beta
) a b
) -
1)
4029 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) ((mplus) -
1 b
))
4030 ((mexpt) z
((mplus) -
1 a
))))
4033 ;;; Integral of the Generalized Incomplete Beta function
4035 (defprop %beta_incomplete_regularized
4042 ((%beta_incomplete_regularized
) ((mplus) 1 a
) b z
)
4043 ((mexpt) ((mplus) a b
) -
1))
4044 ((mtimes) ((%beta_incomplete_regularized
) a b z
) z
)))
4047 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4049 (def-simplifier beta_incomplete_regularized
(a b z
)
4053 ;; Check for specific values
4056 (let ((sgn ($sign
($realpart a
))))
4057 (cond ((eq sgn
'$neg
)
4060 "beta_incomplete_regularized: beta_incomplete_regularized(~:M,~:M,~:M) is undefined.")
4062 ((member sgn
'($pos $pz
))
4071 (let ((sgn ($sign
($realpart b
))))
4072 (cond ((member sgn
'($pos $pz
))
4077 ((and (integer-representation-p b
)
4078 (if ($bfloatp b
) (minusp (cadr b
)) (minusp b
)) )
4079 ;; Problem: for b a negative integer the Regularized Incomplete
4080 ;; Beta function is defined to be zero. BUT: When we calculate
4081 ;; e.g. beta_incomplete(1.0,-2.0,1/2)/beta(1.0,-2.0) we get the
4082 ;; result -3.0, because beta_incomplete and beta are defined for
4083 ;; for this case. How do we get a consistent behaviour?
4086 ((and (integer-representation-p a
)
4087 (if ($bfloatp a
) (minusp (cadr a
)) (minusp a
)) )
4089 ;; TODO: The following line does not work for bigfloats.
4090 ((and (integer-representation-p b
) (<= b
(- a
)))
4091 ;; Does $beta_incomplete or simpbeta underflow in this case?
4092 (div (ftake '%beta_incomplete a b z
)
4093 (ftake* '%beta a b
)))
4097 ;; Check for numerical evaluation in Float or Bigfloat precision
4099 ((complex-float-numerical-eval-p a b z
)
4100 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0)))
4102 (setq a
($float a
) b
($float b
))
4103 (if (or (< ($abs
(setq beta
(ftake* '%beta a b
))) 1e-307)
4104 (< ($abs
(setq ibeta
(beta-incomplete a b
($float z
)))) 1e-307) )
4105 ;; In case of underflow (see bug #2999) or precision loss use bigfloats
4106 ;; and emporarily give some extra precision but avoid fpprec dependency.
4107 ;; Is this workaround correct for complex values?
4109 ($float
(take '(%beta_incomplete_regularized
) ($bfloat a
) ($bfloat b
) z
)) )
4110 ($rectform
(div ibeta beta
)) )))
4112 ((complex-bigfloat-numerical-eval-p a b z
)
4113 (let ((*beta-incomplete-eps
*
4114 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
4115 (setq a
($bfloat a
) b
($bfloat b
))
4117 (div (beta-incomplete a b
($bfloat z
))
4118 (ftake* '%beta a b
)))))
4120 ;; Check for argument simplifications and transformations
4122 ((and (integerp b
) (plusp b
))
4123 (div (ftake '%beta_incomplete a b z
)
4124 (ftake* '%beta a b
)))
4126 ((and (integerp a
) (plusp a
))
4127 (div (ftake '%beta_incomplete a b z
)
4128 (ftake* '%beta a b
)))
4130 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
4132 (a (simplify (cons '(mplus) (cddr a
)))))
4134 (take '(%beta_incomplete_regularized
) a b z
)
4136 (power (add a b n -
1) -
1)
4137 (power (ftake* '%beta
(add a n
) b
) -
1)
4138 (let ((index (gensumindex)))
4142 (simplify (list '($pochhammer
)
4143 (add 1 (mul -
1 a
) (mul -
1 n
))
4145 (simplify (list '($pochhammer
)
4146 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
4149 (power z
(add a n
(mul -
1 index
) -
1)))
4150 index
0 (sub n
1)))))))
4152 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
4153 (let ((n (- (cadr a
)))
4154 (a (simplify (cons '(mplus) (cddr a
)))))
4156 (take '(%beta_incomplete_regularized
) a b z
)
4158 (power (add a b -
1) -
1)
4159 (power (ftake* '%beta a b
) -
1)
4160 (let ((index (gensumindex)))
4164 (simplify (list '($pochhammer
) (sub 1 a
) index
))
4165 (simplify (list '($pochhammer
)
4166 (add 2 (mul -
1 a
) (mul -
1 b
))
4169 (power z
(add a
(mul -
1 index
) -
1)))
4170 index
0 (sub n
1)))))))
4175 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;