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., 675 Mass Ave, Cambridge, MA 02139, USA.
71 ;;; Copyright (C) 2008 Dieter Kaiser
72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
76 (declare-top (special $factlim $gamma_expand
))
78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80 (defmvar $factorial_expand nil
)
81 (defmvar $beta_expand nil
)
83 (defmvar $erf_representation nil
84 "When T erfc, erfi and erf_generalized are transformed to erf.")
86 (defmvar $erf_%iargs nil
87 "When T erf and erfi simplifies for an imaginary argument.")
89 (defmvar $hypergeometric_representation nil
90 "When T a transformation to a hypergeometric representation is done.")
92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
93 ;;; The following functions test if numerical evaluation has to be done.
94 ;;; The functions should help to test for numerical evaluation more consitent
95 ;;; and without complicated conditional tests including more than one or two
98 ;;; The functions take a list of arguments. All arguments have to be a CL or
99 ;;; Maxima number. If all arguments are numbers we have two cases:
100 ;;; 1. $numer is T we return T. The function has to be evaluated numerically.
101 ;;; 2. One of the args is a float or a bigfloat. Evaluate numerically.
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104 ;;; Test for numerically evaluation in float precision
106 (defun float-numerical-eval-p (&rest args
)
109 (when (not (float-or-rational-p ll
))
110 (return-from float-numerical-eval-p nil
))
111 (when (floatp ll
) (setq flag t
)))
112 (if (or $numer flag
) t nil
)))
114 ;;; Test for numerically evaluation in complex float precision
116 (defun complex-float-numerical-eval-p (&rest args
)
117 "Determine if ARGS consists of numerical values by determining if
118 the real and imaginary parts of each arg are nuemrical (but not
119 bigfloats). A non-NIL result is returned if at least one of args is
120 a floating-point value or if numer is true. If the result is
121 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P"
124 (multiple-value-bind (bool rll ill
)
125 (complex-number-p ll
'float-or-rational-p
)
127 (return-from complex-float-numerical-eval-p nil
))
128 ;; Always save the result from complex-number-p. But for backward
129 ;; compatibility, only set the flag if any item is a float.
130 (push (add rll
(mul ill
'$%i
)) values
)
131 (setf flag
(or flag
(or (floatp rll
) (floatp ill
))))))
132 (when (or $numer flag
)
133 ;; Return the values in the same order as the args!
136 ;;; Test for numerically evaluation in bigfloat precision
138 (defun bigfloat-numerical-eval-p (&rest args
)
141 (when (not (bigfloat-or-number-p ll
))
142 (return-from bigfloat-numerical-eval-p nil
))
145 (if (or $numer flag
) t nil
)))
147 ;;; Test for numerically evaluation in complex bigfloat precision
149 (defun complex-bigfloat-numerical-eval-p (&rest args
)
150 "Determine if ARGS consists of numerical values by determining if
151 the real and imaginary parts of each arg are nuemrical (including
152 bigfloats). A non-NIL result is returned if at least one of args is
153 a floating-point value or if numer is true. If the result is
154 non-NIL, it is a list of the arguments reduced via COMPLEX-NUMBER-P."
158 (multiple-value-bind (bool rll ill
)
159 (complex-number-p ll
'bigfloat-or-number-p
)
161 (return-from complex-bigfloat-numerical-eval-p nil
))
162 ;; Always save the result from complex-number-p. But for backward
163 ;; compatibility, only set the flag if any item is a bfloat.
164 (push (add rll
(mul ill
'$%i
)) values
)
165 (when (or ($bfloatp rll
) ($bfloatp ill
))
167 (when (or $numer flag
)
168 ;; Return the values in the same order as the args!
171 ;;; Test for numerical evaluation in any precision, real or complex.
172 (defun numerical-eval-p (&rest args
)
173 (or (apply 'float-numerical-eval-p args
)
174 (apply 'complex-float-numerical-eval-p args
)
175 (apply 'bigfloat-numerical-eval-p args
)
176 (apply 'complex-bigfloat-numerical-eval-p args
)))
178 ;;; Check for an integer or a float or bigfloat representation. When we
179 ;;; have a float or bigfloat representation return the integer value.
181 (defun integer-representation-p (x)
183 (cond ((integerp x
) x
)
184 ((and (floatp x
) (= 0 (nth-value 1 (truncate x
))))
185 (nth-value 0 (truncate x
)))
187 (eq ($sign
(sub (setq val
($truncate x
)) x
)) '$zero
))
191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
193 ;;; The changes to the parser to connect the operator !! to double_factorial(z)
195 ;(def-mheader |$!!| (%double_factorial))
197 ;(def-led (|$!!| 160.) (op left)
200 ; (convert left '$expr)))
202 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
204 ;;; The implementation of the function Double factorial
206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
208 (defmfun $double_factorial
(z)
209 (simplify (list '(%double_factorial
) z
)))
211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
213 ;;; Set properties to give full support to the parser and display
215 (defprop $double_factorial %double_factorial alias
)
216 (defprop $double_factorial %double_factorial verb
)
218 (defprop %double_factorial $double_factorial reversealias
)
219 (defprop %double_factorial $double_factorial noun
)
221 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
223 ;;; Double factorial is a simplifying function
225 (defprop %double_factorial simp-double-factorial operators
)
227 ;;; Double factorial distributes over bags
229 (defprop %double_factorial
(mlist $matrix mequal
) distribute_over
)
231 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
233 ;;; Double factorial has mirror symmetry
235 (defprop %double_factorial t commutes-with-conjugate
)
237 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
239 ;;; Differentiation of Double factorial
241 (defprop %double_factorial
245 ((%double_factorial
) z
)
250 ((mplus) 1 ((mtimes) ((rat) 1 2) z
)))
253 ((%log
) ((mtimes) 2 ((mexpt) $%pi -
1)))
254 ((%sin
) ((mtimes) $%pi z
))))))
257 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
259 (defun simp-double-factorial (expr z simpflag
)
261 (setq z
(simpcheck (cadr expr
) simpflag
))
263 ((and (fixnump z
) (> z -
1) (or (minusp $factlim
) (< z $factlim
)))
264 ;; Positive Integer less then $factlim or $factlim is -1. Call gfact.
265 (gfact z
(floor (/ z
2)) 2))
269 (zerop1 (sub (simplify (list '(%truncate
) (div z
2))) (div z
2))))
270 ;; Even negative integer or real representation. Not defined.
273 "double_factorial: double_factorial(~:M) is undefined.") z
))
275 ((or (integerp z
) ; at this point odd negative integer. Evaluate.
276 (complex-float-numerical-eval-p z
))
278 ((and (integerp z
) (= z -
1)) 1) ; Special cases -1 and -3
279 ((and (integerp z
) (= z -
3)) -
1)
281 ;; Odd negative integer, float or complex float.
284 (complex ($float
($realpart z
)) ($float
($imagpart z
))))))))
286 ((and (not (ratnump z
))
287 (complex-bigfloat-numerical-eval-p z
))
288 ;; bigfloat or complex bigfloat.
289 (bfloat-double-factorial
290 (add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))
292 ;; double_factorial(inf) -> inf
295 ((and $factorial_expand
299 (n (simplify (cons '(mplus) (cddr z
)))))
302 ;; Special case double_factorial(n-1)
303 ;; Not sure if this simplification is useful.
304 (div (simplify (list '(mfactorial) n
))
305 (simplify (list '(%double_factorial
) n
))))
306 ((= k
(* 2 (truncate (/ k
2))))
307 ;; Special case double_factorial(2*k+n), k integer
309 ($factor
; we get more simple expression when factoring
312 (simplify (list '($pochhammer
) (add (div n
2) 1) k
))
313 (simplify (list '(%double_factorial
) n
)))))
315 (eqtest (list '(%double_factorial
) z
) expr
)))))
318 (eqtest (list '(%double_factorial
) z
) expr
))))
320 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
321 ;;; Double factorial for a complex float argument. The result is a CL complex.
322 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
324 (defun double-factorial (z)
325 (let ((pival (float pi
)))
329 (/ (- 1 (cos (* pival z
))) 4))
331 (gamma-lanczos (+ 1 (/ z
2))))))
333 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
334 ;;; Double factorial for a bigfloat or complex bigfloat argument
335 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
337 (defun bfloat-double-factorial (z)
338 (let* ((pival ($bfloat
'$%pi
))
339 (bigfloat1 ($bfloat bigfloatone
))
340 (bigfloat2 (add bigfloat1 bigfloat1
))
341 (bigfloat4 (add bigfloat2 bigfloat2
))
345 (cdiv bigfloat2 pival
)
347 (simplify (list '(%cos
) (cmul pival z
)))) bigfloat4
))
349 (cpower bigfloat2
(cdiv z bigfloat2
))
350 (simplify (list '(%gamma
) (add bigfloat1
(cdiv z bigfloat2
))))))))
352 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
354 ;;; The implementation of the Incomplete Gamma function
361 ;;; gamma_incomplete(a, z) = I t %e dt
366 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
368 (defvar *debug-gamma
* nil
)
370 (defmfun $gamma_incomplete
(a z
)
371 (simplify (list '(%gamma_incomplete
) a z
)))
373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
375 ;;; Set properties to give full support to the parser and display
377 (defprop $gamma_incomplete %gamma_incomplete alias
)
378 (defprop $gamma_incomplete %gamma_incomplete verb
)
380 (defprop %gamma_incomplete $gamma_incomplete reversealias
)
381 (defprop %gamma_incomplete $gamma_incomplete noun
)
383 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
385 ;;; Incomplete Gamma function is a simplifying function
387 (defprop %gamma_incomplete simp-gamma-incomplete operators
)
389 ;;; Incomplete Gamma distributes over bags
391 (defprop %gamma_incomplete
(mlist $matrix mequal
) distribute_over
)
393 ;;; Incomplete Gamma function has not mirror symmetry for z on the negative
394 ;;; real axis. We support a conjugate-function which test this case.
396 (defprop %gamma_incomplete conjugate-gamma-incomplete conjugate-function
)
398 (defun conjugate-gamma-incomplete (args)
399 (let ((a (first args
)) (z (second args
)))
400 (cond ((off-negative-real-axisp z
)
401 ;; Definitely not on the negative real axis for z. Mirror symmetry.
405 (simplify (list '($conjugate
) a
))
406 (simplify (list '($conjugate
) z
)))))
408 ;; On the negative real axis or no information. Unsimplified.
411 (simplify (list '(%gamma_incomplete
) a z
)))))))
413 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
415 ;;; Derivative of the Incomplete Gamma function
417 (putprop '%gamma_incomplete
420 (cond ((member ($sign a
) '($pos $pz
))
421 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2
422 ;; function and the Generalized Incomplete Gamma function
423 ;; (functions.wolfram.com), only for a>0.
426 ((mexpt) ((%gamma
) ,a
) 2)
428 (($hypergeometric_regularized
)
430 ((mlist) ((mplus) 1 ,a
) ((mplus) 1 ,a
))
433 ((%gamma_incomplete_generalized
) ,a
0 ,z
)
437 ((mqapply) (($psi array
) 0) ,a
))))
439 ;; No derivative. Maxima generates a noun form.
441 ;; The derivative wrt z
443 ((mexpt) $%e
((mtimes) -
1 z
))
444 ((mexpt) z
((mplus) -
1 a
))))
447 ;;; Integral of the Incomplete Gamma function
449 (defprop %gamma_incomplete
453 ((mtimes) -
1 ((%gamma_incomplete
) ((mplus) 1 a
) z
))
454 ((mtimes) ((%gamma_incomplete
) a z
) z
)))
457 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
459 ;;; We support a simplim%function. The function is looked up in simplimit and
460 ;;; handles specific values of the function.
462 (defprop %gamma_incomplete simplim%gamma_incomplete simplim%function
)
464 (defun simplim%gamma_incomplete
(expr var val
)
465 ;; Look for the limit of the arguments.
466 (let ((a (limit (cadr expr
) var val
'think
))
467 (z (limit (caddr expr
) var val
'think
)))
470 ((eq z
'$infinity
) ;; http://dlmf.nist.gov/8.11#i
471 (cond ((and (zerop1 ($realpart
(caddr expr
)))
472 (eq ($csign
(m+ -
1 (cadr expr
))) '$neg
))
474 (t (throw 'limit t
))))
476 ;; Handle an argument 0 at this place.
480 (let ((sgn ($sign
($realpart a
))))
481 (cond ((zerop1 a
) '$inf
)
482 ((member sgn
'($neg $nz
)) '$infinity
)
483 ;; Call the simplifier of the function.
484 (t (simplify (list '(%gamma_incomplete
) a z
))))))
486 ;; All other cases are handled by the simplifier of the function.
487 (simplify (list '(%gamma_incomplete
) a z
))))))
489 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
491 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
493 ;;; Implementation of the Lower Incomplete gamma function:
500 ;;; gamma_incomplete_lower(a, z) = I t %e dt
504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
505 (defmfun $gamma_incomplete_lower
(a z
)
506 (simplify (list '(%gamma_incomplete_lower
) a z
)))
508 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
510 (defprop $gamma_incomplete_lower %gamma_incomplete_lower alias
)
511 (defprop $gamma_incomplete_lower %gamma_incomplete_lower verb
)
513 (defprop %gamma_incomplete_lower $gamma_incomplete_lower reversealias
)
514 (defprop %gamma_incomplete_lower $gamma_incomplete_lower noun
)
516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
518 (defprop %gamma_incomplete_lower simp-gamma-incomplete-lower operators
)
520 ;;; distribute over bags (aggregates)
522 (defprop %gamma_incomplete_lower
(mlist $matrix mequal
) distribute_over
)
524 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
526 ;; (defprop %gamma_incomplete_lower ??? grad) WHAT TO PUT HERE ??
529 ;; Handles some special cases for the order a and simplifies it to an
530 ;; equivalent form, possibly involving erf and gamma_incomplete_lower
532 (defun simp-gamma-incomplete-lower (expr ignored simpflag
)
533 (declare (ignore ignored
))
535 (let ((a (simpcheck (cadr expr
) simpflag
))
536 (z (simpcheck (caddr expr
) simpflag
)))
539 (float-numerical-eval-p a z
)
540 (complex-float-numerical-eval-p a z
)
541 (bigfloat-numerical-eval-p a z
)
542 (complex-bigfloat-numerical-eval-p a z
))
543 (take '(%gamma_incomplete_generalized
) a
0 z
))
544 ((gamma-incomplete-lower-expand a z
))
546 (eqtest (list '(%gamma_incomplete_lower
) a z
) expr
)))))
548 ;; Try to express gamma_incomplete_lower(a,z) in simpler terms for
549 ;; special values of the order a. If we can't, return NIL to say so.
550 (defun gamma-incomplete-lower-expand (a z
)
551 (cond ((and $gamma_expand
(integerp a
) (eql a
1))
552 ;; gamma_incomplete_lower(0, x) = 1-exp(x)
553 (sub 1 (m^t
'$%e
(neg z
))))
554 ((and $gamma_expand
(integerp a
) (plusp a
))
555 ;; gamma_incomplete_lower(a,z) can be simplified if a is a
556 ;; positive integer. Since gamma_incomplete_lower(a,z) =
557 ;; gamma(a) - gamma_incomplete(a,z), use gamma_incomplete to
559 (sub (simpgamma (list '(%gamma
) a
) 1 nil
)
560 (take '(%gamma_incomplete
) a z
)))
561 ((and $gamma_expand
(alike1 a
1//2))
564 ;; gamma_incomplete_lower(1/2,x^2) = sqrt(%pi)*erf(x)
566 ;; gamma_incomplete_lower(1/2,z) = sqrt(%pi)*erf(sqrt(x))
568 (mul (power '$%pi
'((rat simp
) 1 2))
569 (take '(%erf
) (power z
'((rat simp
) 1 2)))))
570 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
571 ;; gamma_incomplete_lower(a+n,z), where n is an integer
573 (a (simplify (cons '(mplus) (cddr a
)))))
576 ;; gamma_incomplete_lower(a+n,z). See DLMF 8.8.7:
578 ;; gamma_incomplete_lower(a+n,z)
579 ;; = pochhammer(a,n)*gamma_incomplete_lower(a,z)
580 ;; -z^a*exp(-z)*sum(gamma(a+n)gamma(a+k+1)*z^k,k,0,n-1)
583 (simplify (list '($pochhammer
) a n
))
584 (simplify (list '(%gamma_incomplete_lower
) a z
)))
587 (power '$%e
(mul -
1 z
))
588 (let ((gamma-a+n
(simpgamma (list '(%gamma
) (add a n
)) 1 nil
))
589 (index (gensumindex))
594 (simpgamma (list '(%gamma
) (add a index
1)) 1 nil
))
596 index
0 (add n -
1))))))
599 ;; See DLMF 8.8.8. For simplicity let g(a,z) = gamma_incomplete_lower(a,z).
601 ;; g(a,z) = gamma(a)/gamma(a-n)*g(a-n,z)
602 ;; - z^(a-1)*exp(z)*sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
605 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
606 ;; + gamma(a-n)/gamma(a)*z^(a-1)*exp(-z)
607 ;; * sum(gamma(a)/gamma(a-k)*z^(-k),k,0,n-1)
609 ;; g(a-n,z) = gamma(a-n)/gamma(a)*g(a,z)
611 ;; * sum(gamma(a-n)/gamma(a-k)*z^(-k),k,0,n-1)
612 (let ((gamma-a-n (simpgamma (list '(%gamma
) (sub a n
)) 1 nil
))
613 (index (gensumindex))
619 (simplify (list '(%gamma_incomplete_lower
) a z
)))
622 (power '$%e
(mul -
1 z
))
626 (simpgamma (list '(%gamma
) (sub a index
)) 1 nil
))
627 (power z
(mul -
1 index
)))
628 index
0 (add n -
1)))))))))
629 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
630 (integerp (second a
))
631 (integerp (third a
)))
632 ;; gamma_incomplete_lower of (numeric) rational order.
633 ;; Expand it out so that the resulting order is between 0 and
635 (multiple-value-bind (n order
)
636 (floor (/ (second a
) (third a
)))
637 ;; a = n + order where 0 <= order < 1.
638 (let ((rat-order (rat (numerator order
) (denominator order
))))
641 ;; Nothing to do if the order is already between 0 and 1
642 (list '(%gamma_incomplete_lower simp
) a z
))
644 ;; Use gamma_incomplete(a+n,z) above. and then substitue
645 ;; a=order. This works for n positive or negative.
646 (let* ((ord (gensym))
647 (g (simplify (list '(%gamma_incomplete_lower
) (add ord n
) z
))))
648 ($substitute rat-order ord g
)))))))
650 ;; No expansion so return nil to indicate that
653 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
655 (defun simp-gamma-incomplete (expr ignored simpflag
)
656 (declare (ignore ignored
))
658 (let ((a (simpcheck (cadr expr
) simpflag
))
659 (z (simpcheck (caddr expr
) simpflag
))
664 ;; Check for specific values
667 ;; gamma_incomplete(v,0) is gamma(v) only if the realpart(v) >
668 ;; 0. If realpart(v) <= 0, gamma_incomplete is undefined. For
669 ;; all other cases, return the noun form.
670 (let ((sgn ($sign
($realpart a
))))
671 (cond ((member sgn
'($neg $zero
))
674 "gamma_incomplete: gamma_incomplete(~:M,~:M) is undefined.")
676 ((member sgn
'($pos $pz
)) ($gamma a
))
677 (t (eqtest (list '(%gamma_incomplete
) a z
) expr
)))))
684 ;; Check for numerical evaluation in Float or Bigfloat precision
686 ((float-numerical-eval-p a z
)
688 (format t
"~&SIMP-GAMMA-INCOMPLETE in float-numerical-eval-p~%"))
689 ;; a and z are Maxima numbers, at least one has a float value
694 (and (= 0 (- a
(truncate a
)))
696 ;; a is zero or a negative float representing an integer.
697 ;; For these cases the numerical routines of gamma-incomplete
698 ;; do not work. Call the numerical routine for the Exponential
699 ;; Integral E(n,z). The routine is called with a positive integer!.
700 (setq a
(truncate a
))
701 (complexify (* (expt z a
) (expintegral-e (- 1 a
) z
))))
703 (complexify (gamma-incomplete a z
))))))
705 ((complex-float-numerical-eval-p a z
)
708 "~&SIMP-GAMMA-INCOMPLETE in complex-float-numerical-eval-p~%"))
709 ;; a and z are Maxima numbers, at least one is a complex value and
710 ;; we have at least one float part
711 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
712 (cz (complex ($float
($realpart z
)) ($float
($imagpart z
)))))
714 ((and (= (imagpart ca
) 0.0)
715 (or (= (realpart ca
) 0.0)
716 (and (= 0 (- (realpart ca
) (truncate (realpart ca
))))
717 (< (realpart ca
) 0.0))))
718 ;; Call expintegral-e. See comment above.
719 (setq ca
(truncate (realpart ca
)))
720 (complexify (* (expt cz ca
) (expintegral-e (- 1 ca
) cz
))))
722 (complexify (gamma-incomplete ca cz
))))))
724 ((bigfloat-numerical-eval-p a z
)
726 (format t
"~&SIMP-GAMMA-INCOMPLETE in bigfloat-numerical-eval-p~%"))
727 (let ((a ($bfloat a
))
730 ((or (eq ($sign a
) '$zero
)
731 (and (eq ($sign
(sub a
($truncate a
))) '$zero
)
732 (eq ($sign a
) '$neg
)))
733 ;; Call bfloat-expintegral-e. See comment above.
734 (setq a
($truncate a
))
735 ($rectform
(mul (power z a
) (bfloat-expintegral-e (- 1 a
) z
))))
737 (bfloat-gamma-incomplete a z
)))))
739 ((complex-bigfloat-numerical-eval-p a z
)
742 "~&SIMP-GAMMA-INCOMPLETE in complex-bigfloat-numerical-eval-p~%"))
743 (let ((ca (add ($bfloat
($realpart a
))
744 (mul '$%i
($bfloat
($imagpart a
)))))
745 (cz (add ($bfloat
($realpart z
))
746 (mul '$%i
($bfloat
($imagpart z
))))))
748 ((and (eq ($sign
($imagpart ca
)) '$zero
)
749 (or (eq ($sign
($realpart ca
)) '$zero
)
750 (and (eq ($sign
(sub ($realpart ca
)
751 ($truncate
($realpart ca
))))
753 (eq ($sign
($realpart ca
)) '$neg
))))
754 ;; Call bfloat-expintegral-e. See comment above.
757 "~& bigfloat-numerical-eval-p calls bfloat-expintegral-e~%"))
758 (setq a
($truncate
($realpart a
)))
759 ($rectform
(mul (power cz a
)
760 (bfloat-expintegral-e (- 1 a
) cz
))))
762 (complex-bfloat-gamma-incomplete ca cz
)))))
764 ;; Check for transformations and argument simplification
766 ((and $gamma_expand
(integerp a
))
767 ;; Integer or a symbol declared to be an integer. Expand in a series.
768 (let ((sgn ($sign a
)))
773 (simplify (list '(%expintegral_ei
) (mul -
1 z
))))
777 (simplify (list '(%log
) (mul -
1 z
)))
778 (simplify (list '(%log
) (div -
1 z
)))))
779 (mul -
1 (simplify (list '(%log
) z
)))))
780 ((member sgn
'($pos $pz
))
782 (simplify (list '(%gamma
) a
))
783 (power '$%e
(mul -
1 z
))
784 (let ((index (gensumindex)))
788 (let (($gamma_expand nil
))
789 ;; Simplify gamma, but do not expand to avoid division
791 (simplify (list '(%gamma
) (add index
1)))))
792 index
0 (sub a
1)))))
793 ((member sgn
'($neg $nz
))
797 (power -
1 (add (mul -
1 a
) -
1))
798 (simplify (list '(%gamma
) (add (mul -
1 a
) 1))))
800 (simplify (list '(%expintegral_ei
) (mul -
1 z
)))
804 (simplify (list '(%log
) (mul -
1 z
)))
805 (simplify (list '(%log
) (div -
1 z
)))))
806 (simplify (list '(%log
) z
))))
808 (power '$%e
(mul -
1 z
))
809 (let ((index (gensumindex)))
812 (power z
(add index a -
1))
813 (simplify (list '($pochhammer
) a index
)))
814 index
1 (mul -
1 a
))))))
815 (t (eqtest (list '(%gamma_incomplete
) a z
) expr
)))))
817 ((and $gamma_expand
(setq ratorder
(max-numeric-ratio-p a
2)))
818 ;; We have a half integral order and $gamma_expand is not NIL.
819 ;; We expand in a series with the Erfc function
820 (setq ratorder
(- ratorder
(/ 1 2)))
824 (power '$%pi
'((rat simp
) 1 2))
825 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))))
829 (simplify (list '(%gamma
) a
))
830 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
832 (power -
1 (sub ratorder
1))
833 (power '$%e
(mul -
1 z
))
834 (power z
'((rat simp
) 1 2))
835 (let ((index (gensumindex)))
837 (mul -
1 ; we get more simple results
838 (simplify ; when multiplying with -1
841 (sub '((rat simp
) 1 2) ratorder
)
842 (sub ratorder
(add index
1))))
843 (power (mul -
1 z
) index
))
844 index
0 (sub ratorder
1))))))
846 (setq ratorder
(- ratorder
))
851 (power '$%pi
'((rat simp
) 1 2))
852 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
853 (simplify (list '($pochhammer
) '((rat simp
) 1 2) ratorder
)))
855 (power z
(sub '((rat simp
) 1 2) ratorder
))
856 (power '$%e
(mul -
1 z
))
857 (let ((index (gensumindex)))
864 (sub '((rat simp
) 1 2) ratorder
)
866 index
0 (sub ratorder
1))))))))
868 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
869 ;; Handle gamma_incomplete(a+n, z), where n is a numerical integer
871 (a (simplify (cons '(mplus) (cddr a
)))))
874 ;; See DLMF 8.8.9: https://dlmf.nist.gov/8.8.E9
876 ;; gamma_incomplete(a+n,z) = pochhammer(a,n)*gamma_incomplete(a,z)
877 ;; + z^a*exp(-z)*sum(gamma(a+n)/gamma(a+k+1)*z^k,k,0,n-1)
880 (simplify (list '($pochhammer
) a n
))
881 (simplify (list '(%gamma_incomplete
) a z
)))
883 (power '$%e
(mul -
1 z
))
885 (let ((gamma-a+n
(simpgamma (list '(%gamma
) (add a n
)) 1 nil
))
886 (index (gensumindex)))
890 (simpgamma (list '(%gamma
) (add a index
1)) 1 nil
))
892 index
0 (add n -
1))))))
895 ;; See http://functions.wolfram.com/06.06.17.0004.01
897 ;; gamma_incomplate(a,z) =
898 ;; (-1)^n*pochhammer(1-a,n)
899 ;; *[gamma_incomplete(a-n,z)
900 ;; + z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)]
902 ;; Rerarrange this in terms of gamma_incomplete(a-n,z):
904 ;; gamma_incomplete(a-n,z) =
905 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
906 ;; -z^(a-n-1)*exp(-z)*sum(z^k/pochhammer(a-n,k),k,1,n)
908 ;; Change the summation index to go from k = 0 to n-1:
910 ;; z^(a-n-1)*sum(z^k/pochhammer(a-n,k),k,1,n)
911 ;; = z^(a-n-1)*sum(z^(k+1)/pochhammer(a-n,k+1),k,0,n-1)
912 ;; = z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
915 ;; gamma_incomplete(a-n,z) =
916 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
917 ;; -z^(a-n)*sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
919 ;; (-1)^n*gamma_incomplete(a,z)/pochhammer(1-a,n)
923 (simplify (list '(%gamma_incomplete
) a z
)))
924 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
926 (power '$%e
(mul -
1 z
))
928 ;; sum(z^k/pochhammer(a-n,k+1),k,0,n-1)
929 (let ((index (gensumindex)))
933 (simplify (list '($pochhammer
) (sub a n
) (add index
1))))
934 index
0 (sub n
1)))))))))
935 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
936 (integerp (second a
))
937 (integerp (third a
)))
938 ;; gamma_incomplete of (numeric) rational order. Expand it out
939 ;; so that the resulting order is between 0 and 1.
940 (multiple-value-bind (n order
)
941 (floor (/ (second a
) (third a
)))
942 ;; a = n + order where 0 <= order < 1.
943 (let ((rat-order (rat (numerator order
) (denominator order
))))
946 ;; Nothing to do if the order is already between 0 and 1
947 (eqtest (list '(%gamma_incomplete
) a z
) expr
))
949 ;; Use gamma_incomplete(a+n,z) above. and then substitue
950 ;; a=order. This works for n positive or negative.
951 (let* ((ord (gensym))
952 (g (simplify (list '(%gamma_incomplete
) (add ord n
) z
))))
953 ($substitute rat-order ord g
)))))))
955 (t (eqtest (list '(%gamma_incomplete
) a z
) expr
)))))
957 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
958 ;;; Numerical evaluation of the Incomplete Gamma function
960 ;;; gamma-incomplete (a,z) - real and complex double float
961 ;;; bfloat-gamma-incomplete (a z) - bigfloat
962 ;;; complex-bfloat-gamma-incomplete (a z) - complex bigfloat
964 ;;; Expansion in a power series for abs(x) < R, where R is
965 ;;; *gamma-radius* + real(a) if real(a) > 0 or *gamma-radius*
973 ;;; gamma(a,z) = exp(-x)*z^a * > ------------ * z^n
978 ;;; This expansion does not work for an integer a<=0, because the Gamma function
979 ;;; in the denominator is not defined for a=0 and negative integers. For this
980 ;;; case we use the Exponential Integral E for numerically evaluation. The
981 ;;; Incomplete Gamma function and the Exponential integral are connected by
983 ;;; gamma(a,z) = z^a * expintegral_e(1-a,z)
985 ;;; When the series is not used, two forms of the continued fraction
986 ;;; are used. When z is not near the negative real axis use the
987 ;;; continued fractions (A&S 6.5.31):
990 ;;; gamma(a,z) = exp(-z) z^a *( -- --- --- --- --- ... )
993 ;;; The accuracy is controlled by *gamma-incomplete-eps* for double float
994 ;;; precision. For bigfloat precision epsilon is 10^(-$fpprec). The expansions
995 ;;; in a power series or continued fractions stops if *gamma-incomplete-maxit*
996 ;;; is exceeded and an Maxima error is thrown.
998 ;;; The above fraction does not converge on the negative real axis and
999 ;;; converges very slowly near the axis. In this case, use the
1002 ;;; gamma(a,z) = gamma(a) - gamma_lower(a,z)
1004 ;;; The continued fraction for gamma_incomplete_lower(a,z) is
1005 ;;; (http://functions.wolfram.com/06.06.10.0009.01):
1007 ;;; gamma_lower(a,z) = exp(-z) * z^a / cf(a,z)
1011 ;;; -a*z z (a+1)*z 2*z (a+2)*z
1012 ;;; cf(a,z) = a + ---- ---- ------- ---- -------
1013 ;;; a+1+ a+2- a+3+ a+4- a+5+
1015 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1017 (defvar *gamma-incomplete-maxit
* 10000)
1018 (defvar *gamma-incomplete-eps
* (* 2 flonum-epsilon
))
1019 (defvar *gamma-incomplete-min
* 1.0e-32)
1021 (defvar *gamma-radius
* 1.0
1022 "Controls the radius within a series expansion is done.")
1023 (defvar *gamma-imag
* 1.0)
1025 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1027 ;;; The numerical evaluation for CL float or complex values a and x
1028 ;;; When the flag regularized is T, the result is divided by gamma(a) and
1029 ;;; Maxima returns the numercial result for gamma_incomplete_regularized
1031 (defun gamma-incomplete (a x
&optional
(regularized nil
))
1032 (setq x
(+ x
(cond ((complexp x
) #C
(0.0
0.0)) ((realp x
) 0.0))))
1035 ;; Compute the factor needed to scale the series or continued
1036 ;; fraction. This is x^a*exp(-x) or x^a*exp(-x)/gamma(a)
1037 ;; depending on whether we want a non-regularized or
1038 ;; regularized form. We want to compute the factor carefully
1039 ;; to avoid unnecessary overflow if possible.
1041 (or (try-float-computation
1043 ;; gammafloat is more accurate for real
1046 (/ (* (expt x a
) (exp (- x
)))
1049 (/ (* (expt x a
) (exp (- x
)))
1051 ;; Easy way failed. Use logs to compute the
1052 ;; result. This loses some precision, especially
1053 ;; for large values of a and/or x because we use
1054 ;; many bits to hold the exponent part.
1055 (exp (- (* a
(log x
))
1057 (log-gamma-lanczos (if (complexp a
)
1061 (or (try-float-computation
1063 (* (expt x a
) (exp (- x
)))))
1064 ;; Easy way failed, so use the log form.
1065 (exp (- (* a
(log x
))
1067 (multiple-value-bind (result lower-incomplete-tail-p
)
1068 (%gamma-incomplete a x
)
1069 (cond (lower-incomplete-tail-p
1070 ;; %gamma-incomplete compute the lower incomplete gamma
1071 ;; function, so we need to subtract that from gamma(a),
1074 (- 1 (* result factor
)))
1076 (- (gamma-lanczos a
) (* result factor
)))
1078 (- (gammafloat a
) (* result factor
)))))
1080 ;; Continued fraction used. Just multiply by the factor
1081 ;; to get the final result.
1082 (* factor result
))))))
1084 ;; Compute the key part of the gamma incomplete function using either
1085 ;; a series expression or a continued fraction expression. Two values
1086 ;; are returned: the value itself and a boolean, indicating what the
1087 ;; computed value is. If the boolean non-NIL, then the computed value
1088 ;; is the lower incomplete gamma function.
1089 (defun %gamma-incomplete
(a x
)
1090 (let ((gm-maxit *gamma-incomplete-maxit
*)
1091 (gm-eps *gamma-incomplete-eps
*)
1092 (gm-min *gamma-incomplete-min
*))
1094 (format t
"~&GAMMA-INCOMPLETE with ~A and ~A~%" a x
))
1096 ;; The series expansion is done for x within a circle of radius
1097 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1098 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1099 ;; continued fraction is used.
1100 ((and (> (abs x
) (+ *gamma-radius
*
1101 (if (> (realpart a
) 0.0) (realpart a
) 0.0))))
1102 (cond ((and (< (realpart x
) 0)
1103 (< (abs (imagpart x
))
1104 (* *gamma-imag
* (abs (realpart x
)))))
1105 ;; For x near the negative real axis, use the
1106 ;; relationship gamma_incomplete(a,z) = gamma(a) -
1107 ;; gamma_incomplete_lower(a,z), where
1108 ;; gamma_incomplete_lower(a,z) is the lower poart of the
1109 ;; incomplete gamma function. We can evaluate that
1110 ;; using a continued fraction from
1111 ;; http://functions.wolfram.com/06.06.10.0009.01. (Note
1112 ;; that the alternative fraction,
1113 ;; http://functions.wolfram.com/06.06.10.0007.01,
1114 ;; appears to be less accurate.)
1116 ;; Also note that this appears to be valid for all
1117 ;; values of x (real or complex), but we don't want to
1118 ;; use this everywhere for gamma_incomplete. Consider
1119 ;; what happens for large real x. gamma_incomplete(a,x)
1120 ;; is small, but gamma_incomplete(a,x) = gamma(x) - cf
1121 ;; will have large roundoff errors.
1123 (format t
"~&GAMMA-INCOMPLETE in continued fractions for lower integral~%"))
1124 (let ((a (bigfloat:to a
))
1126 (bigfloat::*debug-cf-eval
* *debug-gamma
*)
1127 (bigfloat::*max-cf-iterations
* *gamma-incomplete-maxit
*))
1128 (values (/ (bigfloat::lentz
#'(lambda (n)
1133 (- (* (+ a
(ash n -
1)) x
))))))
1136 ;; Expansion in continued fractions for gamma_incomplete.
1138 (format t
"~&GAMMA-INCOMPLETE in continued fractions~%"))
1140 (an (- a
1.0) (* i
(- a i
)))
1141 (b (+ 3.0 x
(- a
)) (+ b
2.0))
1143 (d (/ 1.0 (- b
2.0)))
1147 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1148 (setq d
(+ (* an d
) b
))
1149 (when (< (abs d
) gm-min
) (setq d gm-min
))
1150 (setq c
(+ b
(/ an c
)))
1151 (when (< (abs c
) gm-min
) (setq c gm-min
))
1155 (when (< (abs (- del
1.0)) gm-eps
)
1156 ;; Return nil to indicate we used the continued fraction.
1157 (return (values h nil
)))))))
1159 ;; Expansion in a series
1161 (format t
"~&GAMMA-INCOMPLETE in series~%"))
1164 (del (/ 1.0 a
) (* del
(/ x ap
)))
1165 (sum del
(+ sum del
)))
1167 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1168 (when (< (abs del
) (* (abs sum
) gm-eps
))
1169 (when *debug-gamma
* (format t
"~&Series converged.~%"))
1170 ;; Return T to indicate we used the series and the series
1171 ;; is for the integral from 0 to x, not x to inf.
1172 (return (values sum t
))))))))
1174 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1176 ;;; This function is called for a and x real
1178 (defun bfloat-gamma-incomplete (a x
)
1179 (let* ((gm-maxit *gamma-incomplete-maxit
*)
1180 (gm-eps (power ($bfloat
10.0) (- $fpprec
)))
1181 (gm-min (mul gm-eps gm-eps
))
1184 ;; The series expansion is done for x within a circle of radius
1185 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1186 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1187 ;; continued fraction is used.
1188 ((eq ($sign
(sub (simplify (list '(mabs) x
))
1190 (if (eq ($sign a
) '$pos
) a
0.0))))
1193 ((and (eq ($sign x
) '$pos
))
1194 ;; Expansion in continued fractions of the Incomplete Gamma function
1196 (an (sub a
1.0) (mul i
(sub a i
)))
1197 (b (add 3.0 x
(mul -
1 a
)) (add b
2.0))
1198 (c (div 1.0 gm-min
))
1199 (d (div 1.0 (sub b
2.0)))
1203 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1205 (format t
"~&in continued fractions:~%")
1206 (mformat t
"~& : i = ~M~%" i
)
1207 (mformat t
"~& : h = ~M~%" h
))
1208 (setq d
(add (mul an d
) b
))
1209 (when (eq ($sign
(sub (simplify (list '(mabs) d
)) gm-min
)) '$neg
)
1211 (setq c
(add b
(div an c
)))
1212 (when (eq ($sign
(sub (simplify (list '(mabs) c
)) gm-min
)) '$neg
)
1214 (setq d
(div 1.0 d
))
1215 (setq del
(mul d c
))
1216 (setq h
(mul h del
))
1217 (when (eq ($sign
(sub (simplify (list '(mabs) (sub del
1.0))) gm-eps
))
1222 (power ($bfloat
'$%e
) (mul -
1 x
)))))))
1224 ;; Expand to multiply everything out.
1226 ;; Expansion in continued fraction for the lower incomplete gamma.
1227 (sub (simplify (list '(%gamma
) a
))
1228 ;; NOTE: We want (power x a) instead of bigfloat:expt
1229 ;; because this preserves how maxima computes x^a when
1230 ;; x is negative and a is rational. For, example
1231 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1234 (power ($bfloat
'$%e
) (mul -
1 x
))
1235 (let ((a (bigfloat:to a
))
1236 (x (bigfloat:to x
)))
1243 (bigfloat:* (ash n -
1) x
)
1244 (bigfloat:-
(bigfloat:* (bigfloat:+ a
(ash n -
1))
1248 ;; Series expansion of the Incomplete Gamma function
1251 (del (div 1.0 a
) (mul del
(div x ap
)))
1252 (sum del
(add sum del
)))
1254 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1256 (format t
"~&GAMMA-INCOMPLETE in series:~%")
1257 (mformat t
"~& : i = ~M~%" i
)
1258 (mformat t
"~& : ap = ~M~%" ap
)
1259 (mformat t
"~& : x/ap = ~M~%" (div x ap
))
1260 (mformat t
"~& : del = ~M~%" del
)
1261 (mformat t
"~& : sum = ~M~%" sum
))
1262 (when (eq ($sign
(sub (simplify (list '(mabs) del
))
1263 (mul (simplify (list '(mabs) sum
)) gm-eps
)))
1265 (when *debug-gamma
* (mformat t
"~&Series converged to ~M.~%" sum
))
1267 (sub (simplify (list '(%gamma
) a
))
1271 (power ($bfloat
'$%e
) (mul -
1 x
))))))))))))
1273 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1275 (defun complex-bfloat-gamma-incomplete (a x
)
1276 (let* ((gm-maxit *gamma-incomplete-maxit
*)
1277 (gm-eps (power ($bfloat
10.0) (- $fpprec
)))
1278 (gm-min (mul gm-eps gm-eps
))
1281 (format t
"~&COMPLEX-BFLOAT-GAMMA-INCOMPLETE~%")
1282 (format t
" : a = ~A~%" a
)
1283 (format t
" : x = ~A~%" x
))
1285 ;; The series expansion is done for x within a circle of radius
1286 ;; R, where R = *gamma-radius*+(realpart(a)) for realpart(a) > 0
1287 ;; and R = *gamma-radisu* for realpart(a) < 0. Otherwise a
1288 ;; continued fraction is used.
1289 ((and (eq ($sign
(sub (simplify (list '(mabs) x
))
1291 (if (eq ($sign
($realpart a
)) '$pos
)
1296 ((not (and (eq ($sign
($realpart x
)) '$neg
)
1297 (eq ($sign
(sub (simplify (list '(mabs) ($imagpart x
)))
1298 (simplify (list '(mabs) ($realpart x
)))))
1300 ;; Expansion in continued fractions of the Incomplete Gamma function
1302 (format t
"~&in continued fractions:~%"))
1304 (an (sub a
1.0) (mul i
(sub a i
)))
1305 (b (add 3.0 x
(mul -
1 a
)) (add b
2.0))
1306 (c (cdiv 1.0 gm-min
))
1307 (d (cdiv 1.0 (sub b
2.0)))
1311 (merror (intl:gettext
"gamma_incomplete: continued fractions failed for gamma_incomplete(~:M, ~:M).") a x
))
1312 (setq d
(add (cmul an d
) b
))
1313 (when (eq ($sign
(sub (simplify (list '(mabs) d
)) gm-min
)) '$neg
)
1315 (setq c
(add b
(cdiv an c
)))
1316 (when (eq ($sign
(sub (simplify (list '(mabs) c
)) gm-min
)) '$neg
)
1318 (setq d
(cdiv 1.0 d
))
1319 (setq del
(cmul d c
))
1320 (setq h
(cmul h del
))
1321 (when (eq ($sign
(sub (simplify (list '(mabs) (sub del
1.0)))
1325 ($bfloat
; force evaluation of expressions with sin or cos
1329 (cpower ($bfloat
'$%e
) ($bfloat
(mul -
1 x
))))))))))
1331 ;; Expand to multiply everything out.
1333 ;; Expansion in continued fraction for the lower incomplete gamma.
1334 (sub ($rectform
(simplify (list '(%gamma
) a
)))
1335 ;; NOTE: We want (power x a) instead of bigfloat:expt
1336 ;; because this preserves how maxima computes x^a when
1337 ;; x is negative and a is rational. For, example
1338 ;; (-8)^(1/2) is -2. bigfloat:expt returns the
1340 (mul ($rectform
(power x a
))
1341 ($rectform
(power ($bfloat
'$%e
) (mul -
1 x
)))
1342 (let ((a (bigfloat:to a
))
1343 (x (bigfloat:to x
)))
1350 (bigfloat:* (ash n -
1) x
)
1351 (bigfloat:-
(bigfloat:* (bigfloat:+ a
(ash n -
1))
1354 ;; Series expansion of the Incomplete Gamma function
1356 (format t
"~&GAMMA-INCOMPLETE in series:~%"))
1359 (del (cdiv 1.0 a
) (cmul del
(cdiv x ap
)))
1360 (sum del
(add sum del
)))
1362 (merror (intl:gettext
"gamma_incomplete: series expansion failed for gamma_incomplete(~:M, ~:M).") a x
))
1363 (when (eq ($sign
(sub (simplify (list '(mabs) del
))
1364 (mul (simplify (list '(mabs) sum
)) gm-eps
)))
1366 (when *debug-gamma
* (format t
"~&Series converged.~%"))
1368 ($bfloat
; force evaluation of expressions with sin or cos
1369 (sub (simplify (list '(%gamma
) a
))
1373 (cpower ($bfloat
'$%e
) (mul -
1 x
)))))))))))))
1375 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1377 ;;; Implementation of the Generalized Incomplete Gamma function
1382 ;;; gamma_incomplete_generalized(a, z1, z2) = I t %e dt
1387 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1389 (defmfun $gamma_incomplete_generalized
(a z1 z2
)
1390 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
)))
1392 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1394 ;;; Set the properties alias, reversealias, noun and verb
1396 (defprop $gamma_incomplete_generalized %gamma_incomplete_generalized alias
)
1397 (defprop $gamma_incomplete_generalized %gamma_incomplete_generalized verb
)
1399 (defprop %gamma_incomplete_generalized
1400 $gamma_incomplete_generalized reversealias
)
1401 (defprop %gamma_incomplete_generalized
1402 $gamma_incomplete_generalized noun
)
1404 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1405 ;;; on the negative real axis.
1406 ;;; We support a conjugate-function which test this case.
1408 (defprop %gamma_incomplete_generalized
1409 conjugate-gamma-incomplete-generalized conjugate-function
)
1411 (defun conjugate-gamma-incomplete-generalized (args)
1412 (let ((a (first args
)) (z1 (second args
)) (z2 (third args
)))
1413 (cond ((and (off-negative-real-axisp z1
) (off-negative-real-axisp z2
))
1414 ;; z1 and z2 definitely not on the negative real axis.
1418 '(%gamma_incomplete_generalized
)
1419 (simplify (list '($conjugate
) a
))
1420 (simplify (list '($conjugate
) z1
))
1421 (simplify (list '($conjugate
) z2
)))))
1423 ;; On the negative real axis or no information. Unsimplified.
1426 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
)))))))
1428 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1430 ;;; Generalized Incomplete Gamma function is a simplifying function
1432 (defprop %gamma_incomplete_generalized
1433 simp-gamma-incomplete-generalized operators
)
1435 ;;; Generalized Incomplete Gamma distributes over bags
1437 (defprop %gamma_incomplete_generalized
(mlist $matrix mequal
) distribute_over
)
1439 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1441 ;;; Differentiation of Generalized Incomplete Gamma function
1443 (defprop %gamma_incomplete_generalized
1445 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1446 ;; and the Generalized Incomplete Gamma function (functions.wolfram.com)
1449 ((mexpt) ((%gamma
) a
) 2)
1451 (($hypergeometric_regularized
)
1453 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1456 ((mexpt) ((%gamma
) a
) 2)
1458 (($hypergeometric_regularized
)
1460 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1463 ((%gamma_incomplete_generalized
) a
0 z1
)
1466 ((%gamma_incomplete_generalized
) a
0 z2
)
1468 ;; The derivative wrt z1
1470 ((mexpt) $%e
((mtimes) -
1 z1
))
1471 ((mexpt) z1
((mplus) -
1 a
)))
1472 ;; The derivative wrt z2
1474 ((mexpt) $%e
((mtimes) -
1 z2
))
1475 ((mexpt) z2
((mplus) -
1 a
))))
1478 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1480 (defun simp-gamma-incomplete-generalized (expr ignored simpflag
)
1481 (declare (ignore ignored
))
1482 (arg-count-check 3 expr
)
1483 (let ((a (simpcheck (cadr expr
) simpflag
))
1484 (z1 (simpcheck (caddr expr
) simpflag
))
1485 (z2 (simpcheck (cadddr expr
) simpflag
))
1490 ;; Check for specific values
1493 (let ((sgn ($sign
($realpart a
))))
1495 ((member sgn
'($pos $pz
))
1497 (simplify (list '(%gamma_incomplete
) a z1
))
1498 (simplify (list '(%gamma
) a
))))
1500 (eqtest (list '(%gamma_incomplete_generalized
) a z1 z2
) expr
)))))
1503 (let ((sgn ($sign
($realpart a
))))
1505 ((member sgn
'($pos $pz
))
1507 (simplify (list '(%gamma
) a
))
1508 (simplify (list '(%gamma_incomplete
) a z2
))))
1510 (eqtest (list '(%gamma_incomplete_generalized
) a z1 z2
) expr
)))))
1512 ((zerop1 (sub z1 z2
)) 0)
1514 ((eq z2
'$inf
) (simplify (list '(%gamma_incomplete
) a z1
)))
1515 ((eq z1
'$inf
) (mul -
1 (simplify (list '(%gamma_incomplete
) a z2
))))
1517 ;; Check for numerical evaluation in Float or Bigfloat precision
1518 ;; Use the numerical routines of the Incomplete Gamma function
1520 ((float-numerical-eval-p a z1 z2
)
1522 (- (gamma-incomplete ($float a
) ($float z1
))
1523 (gamma-incomplete ($float a
) ($float z2
)))))
1525 ((complex-float-numerical-eval-p a z1 z2
)
1526 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
1527 (cz1 (complex ($float
($realpart z1
)) ($float
($imagpart z1
))))
1528 (cz2 (complex ($float
($realpart z2
)) ($float
($imagpart z2
)))))
1529 (complexify (- (gamma-incomplete ca cz1
) (gamma-incomplete ca cz2
)))))
1531 ((bigfloat-numerical-eval-p a z1 z2
)
1532 (sub (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z1
))
1533 (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z2
))))
1535 ((complex-bigfloat-numerical-eval-p a z1 z2
)
1536 (let ((ca (add ($bfloat
($realpart a
))
1537 (mul '$%i
($bfloat
($imagpart a
)))))
1538 (cz1 (add ($bfloat
($realpart z1
))
1539 (mul '$%i
($bfloat
($imagpart z1
)))))
1540 (cz2 (add ($bfloat
($realpart z2
))
1541 (mul '$%i
($bfloat
($imagpart z2
))))))
1542 (sub (complex-bfloat-gamma-incomplete ca cz1
)
1543 (complex-bfloat-gamma-incomplete ca cz2
))))
1545 ;; Check for transformations and argument simplification
1547 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
1548 ;; Expand gamma_incomplete_generalized(a+n,z1,z2) with n an integer
1550 (a (simplify (cons '(mplus) (cddr a
)))))
1554 (simplify (list '($pochhammer
) a n
))
1556 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
))
1558 (power '$%e
(mul -
1 z1
))
1559 (let ((index (gensumindex)))
1562 (power z1
(add a index -
1))
1563 (simplify (list '($pochhammer
) a index
)))
1566 (power '$%e
(mul -
1 z2
))
1567 (let ((index (gensumindex)))
1570 (power z2
(add a index -
1))
1571 (simplify (list '($pochhammer
) a index
)))
1580 ($factor
(simplify (list '($pochhammer
) (sub 1 a
) n
))))
1581 (simplify (list '(%gamma_incomplete_generalized
) a z1 z2
)))
1583 (power '$%e
(mul -
1 z2
))
1584 (let ((index (gensumindex)))
1587 (power z1
(add a index
(- n
) -
1))
1588 (simplify (list '($pochhammer
) (sub a n
) index
)))
1591 (power '$%e
(mul -
1 z2
))
1592 (let ((index (gensumindex)))
1595 (power z2
(add a index
(- n
) -
1))
1596 (simplify (list '($pochhammer
) (sub a n
) index
)))
1599 (t (eqtest (list '(%gamma_incomplete_generalized
) a z1 z2
) expr
)))))
1601 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1603 ;;; Implementation of the Regularized Incomplete Gamma function
1607 ;;; gamma_incomplete(a, z)
1608 ;;; gamma_incomplete_regularized(a, z) = ----------------------
1611 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1613 (defmfun $gamma_incomplete_regularized
(a z
)
1614 (simplify (list '(%gamma_incomplete_regularized
) a z
)))
1616 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1618 (defprop $gamma_incomplete_regularized %gamma_incomplete_regularized alias
)
1619 (defprop $gamma_incomplete_regularized %gamma_incomplete_regularized verb
)
1621 (defprop %gamma_incomplete_regularized
1622 $gamma_incomplete_regularized reversealias
)
1623 (defprop %gamma_incomplete_regularized
1624 $gamma_incomplete_regularized noun
)
1626 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1628 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
1629 ;;; on the negative real axis.
1630 ;;; We support a conjugate-function which test this case.
1632 (defprop %gamma_incomplete_regularized
1633 conjugate-gamma-incomplete-regularized conjugate-function
)
1635 (defun conjugate-gamma-incomplete-regularized (args)
1636 (let ((a (first args
)) (z (second args
)))
1637 (cond ((off-negative-real-axisp z
)
1638 ;; z definitely not on the negative real axis. Mirror symmetry.
1641 '(%gamma_incomplete_regularized
)
1642 (simplify (list '($conjugate
) a
))
1643 (simplify (list '($conjugate
) z
)))))
1645 ;; On the negative real axis or no information. Unsimplified.
1648 (simplify (list '(%gamma_incomplete_regularized
) a z
)))))))
1650 ;;; Regularized Incomplete Gamma function is a simplifying function
1652 (defprop %gamma_incomplete_regularized
1653 simp-gamma-incomplete-regularized operators
)
1655 ;;; Regularized Incomplete Gamma distributes over bags
1657 (defprop %gamma_incomplete_regularized
(mlist $matrix mequal
) distribute_over
)
1659 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1661 ;;; Differentiation of Regularized Incomplete Gamma function
1663 (defprop %gamma_incomplete_regularized
1665 ;; The derivative wrt a in terms of hypergeometric_regularized 2F2 function
1666 ;; and the Regularized Generalized Incomplete Gamma function
1667 ;; (functions.wolfram.com)
1672 (($hypergeometric_regularized
)
1674 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
1677 ((%gamma_incomplete_generalized_regularized
) a z
0)
1680 ((mtimes) -
1 ((mqapply) (($psi array
) 0) a
)))))
1681 ;; The derivative wrt z
1684 ((mexpt) $%e
((mtimes) -
1 z
))
1685 ((mexpt) z
((mplus) -
1 a
))
1686 ((mexpt) ((%gamma
) a
) -
1)))
1689 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1691 (defun simp-gamma-incomplete-regularized (expr ignored simpflag
)
1692 (declare (ignore ignored
))
1694 (let ((a (simpcheck (cadr expr
) simpflag
))
1695 (z (simpcheck (caddr expr
) simpflag
))
1701 ;; Check for specific values
1704 (let ((sgn ($sign
($realpart a
))))
1705 (cond ((member sgn
'($neg $zero
))
1708 "gamma_incomplete_regularized: gamma_incomplete_regularized(~:M,~:M) is undefined.")
1710 ((member sgn
'($pos $pz
)) 1)
1711 (t (eqtest (list '(%gamma_incomplete_regularized
) a z
) expr
)))))
1716 ;; Check for numerical evaluation in Float or Bigfloat precision
1718 ((float-numerical-eval-p a z
)
1720 ;; gamma_incomplete returns a regularized result
1721 (gamma-incomplete ($float a
) ($float z
) t
)))
1723 ((complex-float-numerical-eval-p a z
)
1724 (let ((ca (complex ($float
($realpart a
)) ($float
($imagpart a
))))
1725 (cz (complex ($float
($realpart z
)) ($float
($imagpart z
)))))
1726 ;; gamma_incomplete returns a regularized result
1727 (complexify (gamma-incomplete ca cz t
))))
1729 ((bigfloat-numerical-eval-p a z
)
1730 (div (bfloat-gamma-incomplete ($bfloat a
) ($bfloat z
))
1731 (simplify (list '(%gamma
) ($bfloat a
)))))
1733 ((complex-bigfloat-numerical-eval-p a z
)
1734 (let ((ca (add ($bfloat
($realpart a
))
1735 (mul '$%i
($bfloat
($imagpart a
)))))
1736 (cz (add ($bfloat
($realpart z
))
1737 (mul '$%i
($bfloat
($imagpart z
))))))
1740 (complex-bfloat-gamma-incomplete ca cz
)
1741 (simplify (list '(%gamma
) ca
))))))
1743 ;; Check for transformations and argument simplification
1745 ((and $gamma_expand
(integerp a
))
1746 ;; An integer. Expand the expression.
1747 (let ((sgn ($sign a
)))
1749 ((member sgn
'($pos $pz
))
1751 (power '$%e
(mul -
1 z
))
1752 (let ((index (gensumindex)))
1756 (let (($gamma_expand nil
))
1757 (simplify (list '(%gamma
) (add index
1)))))
1758 index
0 (sub a
1)))))
1759 ((member sgn
'($neg $nz
)) 0)
1760 (t (eqtest (list '(%gamma_incomplete_regularized
) a z
) expr
)))))
1762 ((and $gamma_expand
(setq ratorder
(max-numeric-ratio-p a
2)))
1763 ;; We have a half integral order and $gamma_expand is not NIL.
1764 ;; We expand in a series with the Erfc function
1765 (setq ratorder
(- ratorder
(/ 1 2)))
1767 (format t
"~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in RATORDER~%")
1768 (format t
"~& : a = ~A~%" a
)
1769 (format t
"~& : ratorder = ~A~%" ratorder
))
1772 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2)))))
1776 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))
1778 (power -
1 (sub ratorder
1))
1779 (power '$%e
(mul -
1 z
))
1780 (power z
'((rat simp
) 1 2))
1781 (div 1 (simplify (list '(%gamma
) a
)))
1782 (let ((index (gensumindex)))
1785 (power (mul -
1 z
) index
)
1786 (simplify (list '($pochhammer
)
1787 (sub '((rat simp
) 1 2) ratorder
)
1788 (sub ratorder
(add index
1)))))
1789 index
0 (sub ratorder
1))))))
1792 (setq ratorder
(- ratorder
))
1794 (simplify (list '(%erfc
) (power z
'((rat simp
) 1 2))))
1796 (power '$%e
(mul -
1 z
))
1797 (power z
(sub '((rat simp
) 1 2) ratorder
))
1798 (inv (simplify (list '(%gamma
) (sub '((rat simp
) 1 2) ratorder
))))
1799 (let ((index (gensumindex)))
1803 (simplify (list '($pochhammer
)
1804 (sub '((rat simp
) 1 2) ratorder
)
1806 index
0 (sub ratorder
1))))))))
1808 ((and $gamma_expand
(mplusp a
) (integerp (cadr a
)))
1810 (format t
"~&SIMP-GAMMA-INCOMPLETE-REGULARIZED in COND (mplusp)~%"))
1812 (a (simplify (cons '(mplus) (cddr a
)))))
1816 (simplify (list '(%gamma_incomplete_regularized
) a z
))
1817 ;; We factor the second summand.
1818 ;; Some factors vanish and the result is more readable.
1821 (power '$%e
(mul -
1 z
))
1822 (power z
(add a -
1))
1823 (div 1 (simplify (list '(%gamma
) a
)))
1824 (let ((index (gensumindex)))
1828 (simplify (list '($pochhammer
) a index
)))
1833 (simplify (list '(%gamma_incomplete_regularized
) a z
))
1834 ;; We factor the second summand.
1837 (power '$%e
(mul -
1 z
))
1838 (power z
(sub a
(add n
1)))
1839 (div 1 (simplify (list '(%gamma
) (add a
(- n
)))))
1840 (let ((index (gensumindex)))
1844 (simplify (list '($pochhammer
) (add a
(- n
)) index
)))
1846 ((and $gamma_expand
(consp a
) (eq 'rat
(caar a
))
1847 (integerp (second a
))
1848 (integerp (third a
)))
1849 ;; gamma_incomplete_regularized of numeric rational order.
1850 ;; Expand it out so that the resulting order is between 0 and
1851 ;; 1. Use gamma_incomplete_regularized(a+n,z) to do the dirty
1853 (multiple-value-bind (n order
)
1854 (floor (/ (second a
) (third a
)))
1855 ;; a = n + order where 0 <= order < 1.
1856 (let ((rat-order (rat (numerator order
) (denominator order
))))
1859 ;; Nothing to do if the order is already between 0 and 1
1860 (eqtest (list '(%gamma_incomplete_regularized
) a z
) expr
))
1862 ;; Use gamma_incomplete_regularized(a+n,z) above. and
1863 ;; then substitue a=order. This works for n positive or
1865 (let* ((ord (gensym))
1866 (g (simplify (list '(%gamma_incomplete_regularized
) (add ord n
) z
))))
1867 ($substitute rat-order ord g
)))))))
1869 (t (eqtest (list '(%gamma_incomplete_regularized
) a z
) expr
)))))
1871 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1873 ;;; Implementation of the Logarithm of the Gamma function
1875 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1877 (defmfun $log_gamma
(z)
1878 (simplify (list '(%log_gamma
) z
)))
1880 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1882 (defprop $log_gamma %log_gamma alias
)
1883 (defprop $log_gamma %log_gamma verb
)
1885 (defprop %log_gamma $log_gamma reversealias
)
1886 (defprop %log_gamma $log_gamma noun
)
1888 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1890 (defprop %log_gamma simp-log-gamma operators
)
1892 ;;; Logarithm of the Gamma function distributes over bags
1894 (defprop %log_gamma
(mlist $matrix mequal
) distribute_over
)
1896 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1900 ((mqapply) (($psi array
) 0) z
))
1903 ;; integrate(log_gamma(x),x) = psi[-2](x)
1904 (defun log-gamma-integral (x)
1905 (take '(mqapply) (take '($psi
) -
2) x
))
1907 (putprop '%log_gamma
(list (list 'x
) #'log-gamma-integral
) 'integral
)
1909 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1911 (defun simp-log-gamma (expr z simpflag
)
1913 (setq z
(simpcheck (cadr expr
) simpflag
))
1916 ;; Check for specific values
1920 (and (eq ($sign z
) '$neg
)
1921 (zerop1 (sub z
($truncate z
))))))
1922 ;; We have zero, a negative integer or a float or bigfloat representation.
1924 (intl:gettext
"log_gamma: log_gamma(~:M) is undefined.") z
))
1926 ((eq z
'$inf
) '$inf
)
1928 ;; Check for numerical evaluation
1930 ((float-numerical-eval-p z
)
1931 (complexify (log-gamma-lanczos (complex ($float z
) 0))))
1933 ((complex-float-numerical-eval-p z
)
1936 (complex ($float
($realpart z
)) ($float
($imagpart z
))))))
1938 ((bigfloat-numerical-eval-p z
)
1939 (bfloat-log-gamma ($bfloat z
)))
1941 ((complex-bigfloat-numerical-eval-p z
)
1942 (complex-bfloat-log-gamma
1943 (add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))
1945 ;; Transform to Logarithm of Factorial for integer values
1946 ;; At this point the integer value is positive and not zero.
1949 (simplify (list '(%log
) (simplify (list '(mfactorial) (- z
1))))))
1951 (t (eqtest (list '(%log_gamma
) z
) expr
))))
1953 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1954 ;;; The functions log-gamma-lanczos, bfloat-log-gamma and
1955 ;;; complex-bfloat-log-gamma are modified versions of the related functions
1956 ;;; gamma-lanczos, bffac and cbffac. The functions return the Logarithm of
1957 ;;; the Gamma function. If we have to calculate the quotient of Gamma functions,
1958 ;;; e. g. for the Beta function, it is much more appropriate to use the
1959 ;;; logarithmic versions to avoid overflow.
1961 ;;; Be careful log(gamma(z)) is only for realpart(z) positive equal to
1962 ;;; log_gamma(z). For a negative realpart(z) log_gamma differ by multiple of
1963 ;;; %pi from log(gamma(z)). But we always have exp(log_gamma(z))= gamma(z).
1964 ;;; The terms to get the transformation for log_gamma(-z) are taken from
1965 ;;; functions.wolfram.com.
1966 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1968 (defun log-gamma-lanczos (z)
1969 (declare (type (complex flonum
) z
)
1970 (optimize (safety 3)))
1971 (let ((c (make-array 15 :element-type
'flonum
1973 '(0.99999999999999709182
1974 57.156235665862923517
1975 -
59.597960355475491248
1976 14.136097974741747174
1977 -
0.49191381609762019978
1978 .33994649984811888699e-4
1979 .46523628927048575665e-4
1980 -
.98374475304879564677e-4
1981 .15808870322491248884e-3
1982 -
.21026444172410488319e-3
1983 .21743961811521264320e-3
1984 -
.16431810653676389022e-3
1985 .84418223983852743293e-4
1986 -
.26190838401581408670e-4
1987 .36899182659531622704e-5))))
1988 (declare (type (simple-array flonum
(15)) c
))
1989 (if (minusp (realpart z
))
1996 (abs (floor (realpart z
)))
1997 (- 1 (abs (signum (imagpart z
)))))
2000 (- (log (sin (* (float pi
) (- z
(floor (realpart z
)))))))
2004 (floor (realpart z
))
2005 (signum (imagpart z
))))
2006 (log-gamma-lanczos z
)))
2009 (zgh (+ zh
607/128))
2010 (lnzp (* (/ zh
2) (log zgh
)))
2013 (pp (1- (length c
)) (1- pp
)))
2016 (incf sum
(/ (aref c pp
) (+ z pp
))))))
2017 (+ (log (sqrt (float (* 2 pi
))))
2018 (log (+ ss
(aref c
0)))
2019 (+ (- zgh
) (* 2 lnzp
)))))))
2021 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2023 (defun bfloat-log-gamma (z)
2024 (let (($ratprint nil
)
2025 (bigfloat%pi
($bfloat
'$%pi
)))
2027 ((eq ($sign z
) '$neg
)
2028 (let ((z (mul -
1 z
)))
2031 (mul -
1 bigfloat%pi
'$%i
2032 (simplify (list '(mabs) (simplify (list '($floor
) ($realpart z
)))))
2035 (list '(mabs) (simplify (list '(%signum
) ($imagpart z
)))))))
2036 (simplify (list '(%log
) bigfloat%pi
))
2037 (mul -
1 (simplify (list '(%log
) (mul -
1 z
))))
2039 (simplify (list '(%log
)
2040 (simplify (list '(%sin
)
2043 (sub z
(simplify (list '($floor
) ($realpart z
))))))))))
2046 (simplify (list '($floor
) ($realpart z
)))
2047 (simplify (list '(%signum
) ($imagpart z
)))))
2048 (bfloat-log-gamma z
))))
2050 (let* ((k (* 2 (+ 1 ($entier
(* 0.41 $fpprec
)))))
2051 (m ($bfloat bigfloatone
))
2054 (x ($bfloat bigfloatzero
))
2056 (dotimes (i (/ k
2))
2057 (setq ii
(* 2 (+ i
1)))
2058 (setq m
(mul m
(add z ii -
2) (add z ii -
1)))
2061 (div ($bern
(+ k
(- ii
) 2))
2062 (* (+ k
(- ii
) 1) (+ k
(- ii
) 2))))
2065 (div (simplify (list '(%log
) (mul 2 bigfloat%pi z
+k
))) 2)
2066 (mul z
+k
(add (simplify (list '(%log
) z
+k
)) x -
1))
2067 (mul -
1 (simplify (list '(%log
) m
)))))))))
2069 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2071 (defun complex-bfloat-log-gamma (z)
2072 (let (($ratprint nil
)
2073 (bigfloat%pi
($bfloat
'$%pi
)))
2075 ((eq ($sign
($realpart z
)) '$neg
)
2076 (let ((z (mul -
1 z
)))
2079 (mul -
1 bigfloat%pi
'$%i
2080 (simplify (list '(mabs) (simplify (list '($floor
) ($realpart z
)))))
2083 (list '(mabs) (simplify (list '(%signum
) ($imagpart z
)))))))
2084 (simplify (list '(%log
) bigfloat%pi
))
2085 (mul -
1 (simplify (list '(%log
) (mul -
1 z
))))
2087 (simplify (list '(%log
)
2088 (simplify (list '(%sin
)
2091 (sub z
(simplify (list '($floor
) ($realpart z
))))))))))
2094 (simplify (list '($floor
) ($realpart z
)))
2095 (simplify (list '(%signum
) ($imagpart z
)))))
2096 (complex-bfloat-log-gamma z
))))
2098 (let* ((k (* 2 (+ 1 ($entier
(* 0.41 $fpprec
)))))
2099 (m ($bfloat bigfloatone
))
2101 (y ($rectform
(power z
+k
2)))
2102 (x ($bfloat bigfloatzero
))
2104 (dotimes (i (/ k
2))
2105 (setq ii
(* 2 (+ i
1)))
2106 (setq m
($rectform
(mul m
(add z ii -
2) (add z ii -
1))))
2110 (div ($bern
(+ k
(- ii
) 2))
2111 (* (+ k
(- ii
) 1) (+ k
(- ii
) 2))))
2115 (div (simplify (list '(%log
) (mul 2 bigfloat%pi z
+k
))) 2)
2116 (mul z
+k
(add (simplify (list '(%log
) z
+k
)) x -
1))
2117 (mul -
1 (simplify (list '(%log
) m
))))))))))
2119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2121 ;;; Implementation of the Error function Erf(z)
2123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2126 (simplify (list '(%erf
) z
)))
2128 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2130 (defprop $erf %erf alias
)
2131 (defprop $erf %erf verb
)
2133 (defprop %erf $erf reversealias
)
2134 (defprop %erf $erf noun
)
2136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2138 ;;; erf has mirror symmetry
2140 (defprop %erf t commutes-with-conjugate
)
2142 ;;; erf is an odd function
2144 (defprop %erf odd-function-reflect reflection-rule
)
2146 ;;; erf is a simplifying function
2148 (defprop %erf simp-erf operators
)
2150 ;;; erf distributes over bags
2152 (defprop %erf
(mlist $matrix mequal
) distribute_over
)
2154 ;;; Derivative of the Error function erf
2159 ((mexpt) $%pi
((rat) -
1 2))
2160 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2)))))
2163 ;;; Integral of the Error function erf
2169 ((mexpt) $%pi
((rat) -
1 2))
2170 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2))))
2171 ((mtimes) z
((%erf
) z
))))
2174 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2176 (defun erf-hypergeometric (z)
2177 ; See A&S 7.1.21 or http://functions.wolfram.com/06.25.26.0001.01
2180 (power '$%pi
'((rat simp
) -
1 2))
2181 (list '(%hypergeometric simp
)
2182 (list '(mlist simp
) '((rat simp
) 1 2))
2183 (list '(mlist simp
) '((rat simp
) 3 2))
2184 (mul -
1 (power z
2)))))
2186 (defun simp-erf (expr z simpflag
)
2188 (setq z
(simpcheck (cadr expr
) simpflag
))
2191 ;; Check for specific values
2197 ;; Check for numerical evaluation
2199 ((float-numerical-eval-p z
)
2200 (bigfloat::bf-erf
($float z
)))
2201 ((complex-float-numerical-eval-p z
)
2203 (bigfloat::bf-erf
(complex ($float
($realpart z
)) ($float
($imagpart z
))))))
2204 ((bigfloat-numerical-eval-p z
)
2205 (to (bigfloat::bf-erf
(bigfloat:to
($bfloat z
)))))
2206 ((complex-bigfloat-numerical-eval-p z
)
2207 (to (bigfloat::bf-erf
2208 (bigfloat:to
(add ($bfloat
($realpart z
)) (mul '$%i
($bfloat
($imagpart z
))))))))
2210 ;; Argument simplification
2212 ((taylorize (mop expr
) (second expr
)))
2214 (not $erf_representation
)
2216 (mul '$%i
(simplify (list '(%erfi
) (coeff z
'$%i
1)))))
2217 ((apply-reflection-simp (mop expr
) z $trigsign
))
2219 ;; Representation through more general functions
2221 ($hypergeometric_representation
2222 (erf-hypergeometric z
))
2224 ;; Transformation to Erfc or Erfi
2226 ((and $erf_representation
2227 (not (eq $erf_representation
'$erf
)))
2228 (case $erf_representation
2230 (sub 1 (take '(%erfc
) z
)))
2232 (mul -
1 '$%i
(take '(%erfi
) (mul '$%i z
))))
2234 (eqtest (list '(%erf
) z
) expr
))))
2237 (eqtest (list '(%erf
) z
) expr
))))
2239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2242 ;; We use the slatec routine for float values.
2243 (slatec:derf
(float z
)))
2245 ;; Compute erf(z) using the relationship
2247 ;; erf(z) = sqrt(z^2)/z*(1 - gamma_incomplete(1/2,z^2)/sqrt(%pi))
2249 ;; When z is real sqrt(z^2)/z is signum(z). For complex z,
2250 ;; sqrt(z^2)/z = 1 if -%pi/2 < arg(z) <= %pi/2 and -1 otherwise.
2252 ;; This relationship has serious round-off issues when z is small
2253 ;; because gamma_incomplete(1/2,z^2)/sqrt(%pi) is near 1.
2255 ;; complex-erf is for (lisp) complex numbers; bfloat-erf is for real
2256 ;; bfloats, and complex-bfloat-erf is for complex bfloats. Care is
2257 ;; taken to return real results for real arguments and imaginary
2258 ;; results for imaginary arguments
2259 (defun complex-erf (z)
2262 (if (or (< (realpart z
) 0.0) (and (= (realpart z
) 0.0) (< (imagpart z
) 0.0)))
2266 (* (/ (sqrt (float pi
))) (gamma-incomplete 0.5 (* z z
)))))))
2268 ((= (imagpart z
) 0.0)
2269 ;; Pure real argument, the result is real
2270 (complex (realpart result
) 0.0))
2271 ((= (realpart z
) 0.0)
2272 ;; Pure imaginary argument, the result is pure imaginary
2273 (complex 0.0 (imagpart result
)))
2277 (defun bfloat-erf (z)
2278 ;; Warning! This has round-off problems when abs(z) is very small.
2279 (let ((1//2 ($bfloat
'((rat simp
) 1 2))))
2280 ;; The argument is real, the result is real too
2283 (simplify (list '(%signum
) z
))
2286 (div 1 (power ($bfloat
'$%pi
) 1//2))
2287 (bfloat-gamma-incomplete 1//2 ($bfloat
(power z
2)))))))))
2289 (defun complex-bfloat-erf (z)
2290 ;; Warning! This has round-off problems when abs(z) is very small.
2291 (let* (($ratprint nil
)
2292 (1//2 ($bfloat
'((rat simp
) 1 2)))
2295 (cdiv (cpower (cpower z
2) 1//2) z
)
2298 (div 1 (power ($bfloat
'$%pi
) 1//2))
2299 (complex-bfloat-gamma-incomplete
2301 ($bfloat
(cpower z
2))))))))
2303 ((zerop1 ($imagpart z
))
2304 ;; Pure real argument, the result is real
2306 ((zerop1 ($realpart z
))
2307 ;; Pure imaginary argument, the result is pure imaginary
2308 (mul '$%i
($imagpart result
)))
2310 ;; A general complex result
2313 (in-package :bigfloat
)
2315 ;; Erf(z) for all z. Z must be a CL real or complex number or a
2316 ;; BIGFLOAT or COMPLEX-BIGFLOAT object. The result will be of the
2319 (cond ((typep z
'cl
:real
)
2320 ;; Use Slatec derf, which should be faster than the series.
2322 ((<= (abs z
) 0.476936)
2323 ;; Use the series A&S 7.1.5 for small x:
2325 ;; erf(z) = 2*z/sqrt(%pi) * sum((-1)^n*z^(2*n)/n!/(2*n+1), n, 0, inf)
2327 ;; The threshold is approximately erf(x) = 0.5. (Doesn't
2328 ;; have to be super accurate.) This gives max accuracy when
2329 ;; using the identity erf(x) = 1 - erfc(x).
2330 (let ((z^
2 (* z z
)))
2331 (/ (* 2 z
(sum-power-series z^
2
2339 ;; The general case.
2341 (cl:real
(maxima::erf z
))
2342 (cl:complex
(maxima::complex-erf z
))
2344 (bigfloat (maxima::$bfloat
(maxima::$expand
(maxima::bfloat-erf
(maxima::to z
))))))
2346 (bigfloat (maxima::$bfloat
(maxima::$expand
(maxima::complex-bfloat-erf
(maxima::to z
))))))))))
2349 ;; Compute erfc(z) via 1 - erf(z) is not very accurate if erf(z) is
2350 ;; near 1. Wolfram says
2352 ;; erfc(z) = 1 - sqrt(z^2)/z * (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2, z^2))
2354 ;; For real(z) > 0, sqrt(z^2)/z is 1 so
2356 ;; erfc(z) = 1 - (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2357 ;; = 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2)
2359 ;; For real(z) < 0, sqrt(z^2)/z is -1 so
2361 ;; erfc(z) = 1 + (1 - 1/sqrt(pi)*gamma_incomplete_tail(1/2,z^2))
2362 ;; = 2 - 1/sqrt(pi)*gamma_incomplete(1/2,z^2)
2363 (flet ((gamma-inc (z)
2366 (maxima::gamma-incomplete
0.5 z
))
2368 (bigfloat:to
(maxima::$bfloat
2369 (maxima::bfloat-gamma-incomplete
(maxima::$bfloat maxima
::1//2)
2372 (bigfloat:to
(maxima::$bfloat
2373 (maxima::complex-bfloat-gamma-incomplete
(maxima::$bfloat maxima
::1//2)
2374 (maxima::to z
))))))))
2375 (if (>= (realpart z
) 0)
2376 (/ (gamma-inc (* z z
))
2379 (/ (gamma-inc (* z z
))
2382 (in-package :maxima
)
2384 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2386 ;;; Implementation of the Generalized Error function Erf(z1,z2)
2388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2390 (defmfun $erf_generalized
(z1 z2
)
2391 (simplify (list '(%erf_generalized
) z1 z2
)))
2393 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2395 (defprop $erf_generalized %erf_generalized alias
)
2396 (defprop $erf_generalized %erf_generalized verb
)
2398 (defprop %erf_generalized $erf_generalized reversealias
)
2399 (defprop %erf_generalized $erf_generalized noun
)
2401 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2403 ;;; Generalized Erf has mirror symmetry
2405 (defprop %erf_generalized t commutes-with-conjugate
)
2407 ;;; Generalized Erf distributes over bags
2409 (defprop %erf_generalized
(mlist $matrix mequal
) distribute_over
)
2411 ;;; Generalized Erf is antisymmetric Erf(z1,z2) = - Erf(z2,z1)
2415 #-gcl
(:load-toplevel
:execute
)
2416 (let (($context
'$global
) (context '$global
))
2417 (meval '(($declare
) %erf_generalized $antisymmetric
))
2418 ;; Let's remove built-in symbols from list for user-defined properties.
2419 (setq $props
(remove '%erf_generalized $props
))))
2421 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2423 (defprop %erf_generalized simp-erf-generalized operators
)
2425 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2427 (defprop %erf_generalized
2429 ;; derivative wrt z1
2431 ((mexpt) $%pi
((rat) -
1 2))
2432 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z1
2))))
2433 ;; derviative wrt z2
2435 ((mexpt) $%pi
((rat) -
1 2))
2436 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z2
2)))))
2439 ;;; ----------------------------------------------------------------------------
2441 (defprop %erf_generalized simplim%erf_generalized simplim%function
)
2443 (defun simplim%erf_generalized
(expr var val
)
2444 ;; Look for the limit of the arguments.
2445 (let ((z1 (limit (cadr expr
) var val
'think
))
2446 (z2 (limit (caddr expr
) var val
'think
)))
2448 ;; Handle infinities at this place.
2450 (alike1 z2
'((mtimes) -
1 $minf
)))
2451 (sub 1 (take '(%erf
) z1
)))
2453 (alike1 z2
'((mtimes) -
1 $inf
)))
2454 (sub (mul -
1 (take '(%erf
) z1
)) 1))
2456 (alike1 z1
'((mtimes) -
1 $minf
)))
2457 (sub (take '(%erf
) z2
) 1))
2459 (alike1 z1
'((mtimes) -
1 $inf
)))
2460 (add (take '(%erf
) z2
) 1))
2462 ;; All other cases are handled by the simplifier of the function.
2463 (simplify (list '(%erf_generalized
) z1 z2
))))))
2465 ;;; ----------------------------------------------------------------------------
2467 (defun simp-erf-generalized (expr ignored simpflag
)
2468 (declare (ignore ignored
))
2470 (let ((z1 (simpcheck (cadr expr
) simpflag
))
2471 (z2 (simpcheck (caddr expr
) simpflag
)))
2474 ;; Check for specific values
2476 ((and (zerop1 z1
) (zerop1 z2
)) 0)
2477 ((zerop1 z1
) (take '(%erf
) z2
))
2478 ((zerop1 z2
) (mul -
1 (take '(%erf
) z1
)))
2480 (alike1 z2
'((mtimes) -
1 $minf
)))
2481 (sub 1 (take '(%erf
) z1
)))
2483 (alike1 z2
'((mtimes) -
1 $inf
)))
2484 (sub (mul -
1 (take '(%erf
) z1
)) 1))
2486 (alike1 z1
'((mtimes) -
1 $minf
)))
2487 (sub (take '(%erf
) z2
) 1))
2489 (alike1 z1
'((mtimes) -
1 $inf
)))
2490 (add (take '(%erf
) z2
) 1))
2492 ;; Check for numerical evaluation. Use erf(z1,z2) = erf(z2)-erf(z1)
2494 ((float-numerical-eval-p z1 z2
)
2495 (- (bigfloat::bf-erf
($float z2
))
2496 (bigfloat::bf-erf
($float z1
))))
2497 ((complex-float-numerical-eval-p z1 z2
)
2501 (complex ($float
($realpart z2
)) ($float
($imagpart z2
))))
2503 (complex ($float
($realpart z1
)) ($float
($imagpart z1
)))))))
2504 ((bigfloat-numerical-eval-p z1 z2
)
2506 (bigfloat::bf-erf
(bigfloat:to
($bfloat z2
)))
2507 (bigfloat::bf-erf
(bigfloat:to
($bfloat z1
))))))
2508 ((complex-bigfloat-numerical-eval-p z1 z2
)
2511 (bigfloat:to
(add ($bfloat
($realpart z2
)) (mul '$%i
($bfloat
($imagpart z2
))))))
2513 (bigfloat:to
(add ($bfloat
($realpart z1
)) (mul '$%i
($bfloat
($imagpart z1
)))))))))
2515 ;; Argument simplification
2517 ((and $trigsign
(great (mul -
1 z1
) z1
) (great (mul -
1 z2
) z2
))
2518 (mul -
1 (simplify (list '(%erf_generalized
) (mul -
1 z1
) (mul -
1 z2
)))))
2520 ;; Representation through more general functions
2522 ($hypergeometric_representation
2523 (sub (erf-hypergeometric z2
) (erf-hypergeometric z1
)))
2525 ;; Transformation to Erf
2527 ($erf_representation
2528 (sub (simplify (list '(%erf
) z2
)) (simplify (list '(%erf
) z1
))))
2531 (eqtest (list '(%erf_generalized
) z1 z2
) expr
)))))
2533 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2535 ;;; Implementation of the Complementary Error function Erfc(z)
2537 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2540 (simplify (list '(%erfc
) z
)))
2542 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2544 (defprop $erfc %erfc alias
)
2545 (defprop $erfc %erfc verb
)
2547 (defprop %erfc $erfc reversealias
)
2548 (defprop %erfc $erfc noun
)
2550 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2552 (defprop %erfc t commutes-with-conjugate
)
2554 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2556 (defprop %erfc simp-erfc operators
)
2558 ;;; Complementary Error function distributes over bags
2560 (defprop %erfc
(mlist $matrix mequal
) distribute_over
)
2562 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2567 ((mexpt) $%pi
((rat) -
1 2))
2568 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2)))))
2571 ;;; Integral of the Error function erfc
2577 ((mexpt) $%pi
((rat) -
1 2))
2578 ((mexpt) $%e
((mtimes) -
1 ((mexpt) z
2))))
2579 ((mtimes) z
((%erfc
) z
))))
2582 ;;; ----------------------------------------------------------------------------
2584 (defprop %erfc simplim%erfc simplim%function
)
2586 (defun simplim%erfc
(expr var val
)
2587 ;; Look for the limit of the arguments.
2588 (let ((z (limit (cadr expr
) var val
'think
)))
2590 ;; Handle infinities at this place.
2593 ((eq z
'$infinity
) ;; parallel to code in simplim%erf-%tanh
2594 (destructuring-let (((rpart . ipart
) (trisplit (cadr expr
)))
2596 (setq rlim
(limit rpart var val
'think
))
2598 (limit (m* rpart
(m^t ipart -
1)) var val
'think
))
2599 (setq ans
($asksign
(m+ `((mabs) ,ans
) -
1)))
2600 (cond ((or (eq ans
'$pos
) (eq ans
'$zero
))
2601 (cond ((eq rlim
'$inf
) 0)
2602 ((eq rlim
'$minf
) 2)
2605 ((eq z
'$ind
) '$ind
)
2607 ;; All other cases are handled by the simplifier of the function.
2608 (simplify (list '(%erfc
) z
))))))
2610 ;;; ----------------------------------------------------------------------------
2612 (defun simp-erfc (expr z simpflag
)
2614 (setq z
(simpcheck (cadr expr
) simpflag
))
2617 ;; Check for specific values
2623 ;; Check for numerical evaluation.
2625 ((numerical-eval-p z
)
2626 (to (bigfloat::bf-erfc
(bigfloat:to z
))))
2628 ;; Argument simplification
2630 ((taylorize (mop expr
) (second expr
)))
2631 ((and $trigsign
(great (mul -
1 z
) z
))
2632 (sub 2 (simplify (list '(%erfc
) (mul -
1 z
)))))
2634 ;; Representation through more general functions
2636 ($hypergeometric_representation
2637 (sub 1 (erf-hypergeometric z
)))
2639 ;; Transformation to Erf or Erfi
2641 ((and $erf_representation
2642 (not (eq $erf_representation
'$erfc
)))
2643 (case $erf_representation
2645 (sub 1 (take '(%erf
) z
)))
2647 (add 1 (mul '$%i
(take '(%erfi
) (mul '$%i z
)))))
2649 (eqtest (list '(%erfc
) z
) expr
))))
2652 (eqtest (list '(%erfc
) z
) expr
))))
2654 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2656 ;;; Implementation of the Imaginary Error function Erfi(z)
2658 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2661 (simplify (list '(%erfi
) z
)))
2663 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2665 (defprop $erfi %erfi alias
)
2666 (defprop $erfi %erfi verb
)
2668 (defprop %erfi $erfi reversealias
)
2669 (defprop %erfi $erfi noun
)
2671 ;;; erfi has mirror symmetry
2673 (defprop %erfi t commutes-with-conjugate
)
2675 ;;; erfi is an odd function
2677 (defprop %erfi odd-function-reflect reflection-rule
)
2679 ;;; erfi is an simplifying function
2681 (defprop %erfi simp-erfi operators
)
2683 ;;; erfi distributes over bags
2685 (defprop %erfi
(mlist $matrix mequal
) distribute_over
)
2687 ;;; Derivative of the Error function erfi
2692 ((mexpt) $%pi
((rat) -
1 2))
2693 ((mexpt) $%e
((mexpt) z
2))))
2696 ;;; Integral of the Error function erfi
2702 ((mexpt) $%pi
((rat) -
1 2))
2703 ((mexpt) $%e
((mexpt) z
2)))
2704 ((mtimes) z
((%erfi
) z
))))
2707 ;;; ----------------------------------------------------------------------------
2709 (defprop %erfi simplim%erfi simplim%function
)
2711 (defun simplim%erfi
(expr var val
)
2712 ;; Look for the limit of the arguments.
2713 (let ((z (limit (cadr expr
) var val
'think
)))
2715 ;; Handle infinities at this place.
2716 ((eq z
'$inf
) '$inf
)
2717 ((eq z
'$minf
) '$minf
)
2719 ;; All other cases are handled by the simplifier of the function.
2720 (simplify (list '(%erfi
) z
))))))
2722 ;;; ----------------------------------------------------------------------------
2724 (in-package :bigfloat
)
2727 ;; Use the relationship erfi(z) = -%i*erf(%i*z)
2728 (let* ((iz (complex (- (imagpart z
)) (realpart z
))) ; %i*z
2729 (result (bf-erf iz
)))
2730 (complex (imagpart result
) (- (realpart result
))))))
2731 ;; Take care to return real results when the argument is real.
2735 (realpart (erfi z
)))
2738 (in-package :maxima
)
2740 (defun simp-erfi (expr z simpflag
)
2742 (setq z
(simpcheck (cadr expr
) simpflag
))
2745 ;; Check for specific values
2748 ((eq z
'$inf
) '$inf
)
2749 ((eq z
'$minf
) '$minf
)
2751 ;; Check for numerical evaluation. Use erfi(z) = -%i*erf(%i*z).
2753 ((numerical-eval-p z
)
2754 (to (bigfloat::bf-erfi
(bigfloat:to z
))))
2756 ;; Argument simplification
2758 ((taylorize (mop expr
) (second expr
)))
2761 (mul '$%i
(simplify (list '(%erf
) (coeff z
'$%i
1)))))
2762 ((apply-reflection-simp (mop expr
) z $trigsign
))
2764 ;; Representation through more general functions
2766 ($hypergeometric_representation
2767 (mul -
1 '$%i
(erf-hypergeometric (mul '$%i z
))))
2769 ;; Transformation to Erf or Erfc
2771 ((and $erf_representation
2772 (not (eq $erf_representation
'$erfi
)))
2773 (case $erf_representation
2775 (mul -
1 '$%i
(take '(%erf
) (mul '$%i z
))))
2777 (sub (mul '$%i
(take '(%erfc
) (mul '$%i z
))) '$%i
))
2779 (eqtest (list '(%erfi
) z
) expr
))))
2782 (eqtest (list '(%erfi
) z
) expr
))))
2784 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2786 ;;; The implementation of the Inverse Error function
2788 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2790 (defmfun $inverse_erf
(z)
2791 (simplify (list '(%inverse_erf
) z
)))
2793 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2795 ;;; Set properties to give full support to the parser and display
2797 (defprop $inverse_erf %inverse_erf alias
)
2798 (defprop $inverse_erf %inverse_erf verb
)
2800 (defprop %inverse_erf $inverse_erf reversealias
)
2801 (defprop %inverse_erf $inverse_erf noun
)
2803 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2805 ;;; The Inverse Error function is a simplifying function
2807 (defprop %inverse_erf simp-inverse-erf operators
)
2809 ;;; The Inverse Error function distributes over bags
2811 (defprop %inverse_erf
(mlist $matrix mequal
) distribute_over
)
2813 ;;; inverse_erf is the inverse of the erf function
2815 (defprop %inverse_erf %erf $inverse
)
2816 (defprop %erf %inverse_erf $inverse
)
2818 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2820 ;;; Differentiation of the Inverse Error function
2822 (defprop %inverse_erf
2826 ((mexpt) $%pi
((rat) 1 2))
2827 ((mexpt) $%e
((mexpt) ((%inverse_erf
) z
) 2))))
2830 ;;; Integral of the Inverse Error function
2832 (defprop %inverse_erf
2835 ((mexpt) $%pi
((rat) -
1 2))
2836 ((mexpt) $%e
((mtimes) -
1 ((mexpt) ((%inverse_erf
) z
) 2)))))
2839 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2841 ;;; We support a simplim%function. The function is looked up in simplimit and
2842 ;;; handles specific values of the function.
2844 (defprop %inverse_erf simplim%inverse_erf simplim%function
)
2846 (defun simplim%inverse_erf
(expr var val
)
2847 ;; Look for the limit of the argument.
2848 (let ((z (limit (cadr expr
) var val
'think
)))
2850 ;; Handle an argument 1 at this place
2852 ((onep1 (mul -
1 z
)) '$minf
)
2854 ;; All other cases are handled by the simplifier of the function.
2855 (simplify (list '(%inverse_erf
) z
))))))
2857 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2859 (defun simp-inverse-erf (expr z simpflag
)
2861 (setq z
(simpcheck (cadr expr
) simpflag
))
2866 (intl:gettext
"inverse_erf: inverse_erf(~:M) is undefined.") z
))
2868 ((numerical-eval-p z
)
2869 (to (bigfloat::bf-inverse-erf
(bigfloat:to z
))))
2870 ((taylorize (mop expr
) (cadr expr
)))
2872 (eqtest (list '(%inverse_erf
) z
) expr
))))
2874 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2876 ;;; The implementation of the Inverse Complementary Error function
2878 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2880 (defmfun $inverse_erfc
(z)
2881 (simplify (list '(%inverse_erfc
) z
)))
2883 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2885 ;;; Set properties to give full support to the parser and display
2887 (defprop $inverse_erfc %inverse_erfc alias
)
2888 (defprop $inverse_erfc %inverse_erfc verb
)
2890 (defprop %inverse_erfc $inverse_erfc reversealias
)
2891 (defprop %inverse_erfc $inverse_erfc noun
)
2893 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2895 ;;; Inverse Complementary Error function is a simplifying function
2897 (defprop %inverse_erfc simp-inverse-erfc operators
)
2899 ;;; Inverse Complementary Error function distributes over bags
2901 (defprop %inverse_erfc
(mlist $matrix mequal
) distribute_over
)
2903 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2905 ;;; inverse_erfc is the inverse of the erfc function
2907 (defprop %inverse_erfc %erfc $inverse
)
2908 (defprop %erfc %inverse_erfc $inverse
)
2911 ;;; Differentiation of the Inverse Complementary Error function
2913 (defprop %inverse_erfc
2917 ((mexpt) $%pi
((rat) 1 2))
2918 ((mexpt) $%e
((mexpt) ((%inverse_erfc
) z
) 2))))
2921 ;;; Integral of the Inverse Complementary Error function
2923 (defprop %inverse_erfc
2926 ((mexpt) $%pi
((rat) -
1 2))
2928 ((mtimes) -
1 ((mexpt) ((%inverse_erfc
) z
) 2)))))
2931 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2933 ;;; We support a simplim%function. The function is looked up in simplimit and
2934 ;;; handles specific values of the function.
2936 (defprop %inverse_erfc simplim%inverse_erfc simplim%function
)
2938 (defun simplim%inverse_erfc
(expr var val
)
2939 ;; Look for the limit of the argument.
2940 (let ((z (limit (cadr expr
) var val
'think
)))
2942 ;; Handle an argument 0 at this place
2947 ((zerop1 (add z -
2)) '$minf
)
2949 ;; All other cases are handled by the simplifier of the function.
2950 (simplify (list '(%inverse_erfc
) z
))))))
2952 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2954 (defun simp-inverse-erfc (expr z simpflag
)
2956 (setq z
(simpcheck (cadr expr
) simpflag
))
2959 (zerop1 (add z -
2)))
2961 (intl:gettext
"inverse_erfc: inverse_erfc(~:M) is undefined.") z
))
2963 ((numerical-eval-p z
)
2964 (to (bigfloat::bf-inverse-erfc
(bigfloat:to z
))))
2965 ((taylorize (mop expr
) (cadr expr
)))
2967 (eqtest (list '(%inverse_erfc
) z
) expr
))))
2969 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2971 ;;; Implementation of the Newton algorithm to calculate numerical values
2972 ;;; of the Inverse Error functions in float or bigfloat precision.
2973 ;;; The algorithm is a modified version of the routine in newton1.mac.
2975 (defvar *debug-newton
* nil
)
2976 (defvar *newton-maxcount
* 1000)
2977 (defvar *newton-epsilon-factor
* 50)
2978 (defvar *newton-epsilon-factor-float
* 10)
2980 (defun float-newton (expr var x0 eps
)
2981 (do ((s (sdiff expr var
))
2984 (count 0 (+ count
1)))
2985 ((> count
*newton-maxcount
*)
2987 (intl:gettext
"float-newton: Newton does not converge for ~:M") expr
))
2988 (setq sn
($float
(maxima-substitute xn var expr
)))
2989 (when (< (abs sn
) eps
) (return xn
))
2990 (when *debug-newton
* (format t
"~&xn = ~A~%" xn
))
2991 (setq xn
($float
(sub xn
(div sn
(maxima-substitute xn var s
)))))))
2993 (defun bfloat-newton (expr var x0 eps
)
2994 (do ((s (sdiff expr var
))
2997 (count 0 (+ count
1)))
2998 ((> count
*newton-maxcount
*)
3000 (intl:gettext
"bfloat-newton: Newton does not converge for ~:M") expr
))
3001 (setq sn
($bfloat
(maxima-substitute xn var expr
)))
3002 (when (eq ($sign
(sub (simplify (list '(mabs) sn
)) eps
)) '$neg
)
3004 (when *debug-newton
* (format t
"~&xn = ~A~%" xn
))
3005 (setq xn
($bfloat
(sub xn
(div sn
(maxima-substitute xn var s
)))))))
3008 (in-package :bigfloat
)
3010 ;; Compute inverse_erf(z) for z a real or complex number, including
3011 ;; bigfloat objects. The value is computing using a Newton iteration
3012 ;; to solve erf(x) = z.
3013 (defun bf-inverse-erf (z)
3018 (intl:gettext
"bf-inverse-erf: inverse_erf(~M) is undefined")
3020 ((minusp (realpart z
))
3021 ;; inverse_erf is odd because erf is.
3022 (- (bf-inverse-erf (- z
))))
3026 ;; Find an approximate solution for x = inverse_erf(z).
3028 (cond ((<= (abs z
) 1)
3029 ;; For small z, inverse_erf(z) = z*sqrt(%pi)/2
3030 ;; + O(z^3). Thus, x = z*sqrt(%pi)/2 is our
3031 ;; initial starting point.
3032 (* z
(sqrt (%pi z
)) 1/2))
3034 ;; For |z| > 1 and realpart(z) >= 0, we have
3035 ;; the asymptotic series z = erf(x) = 1 -
3036 ;; exp(-x^2)/x/sqrt(%pi).
3039 ;; x = sqrt(-log(x*sqrt(%pi)*(1-z))
3041 ;; We can use this as a fixed-point iteration
3042 ;; to find x, and we can start the iteration at
3043 ;; x = 1. Just do one more iteration. I (RLT)
3044 ;; think that's close enough to get the Newton
3045 ;; algorithm to converge.
3046 (let* ((sp (sqrt (%pi z
)))
3047 (a (sqrt (- (log (* sp
(- 1 z
)))))))
3048 (setf a
(sqrt (- (log (* a sp
(- 1 z
))))))
3049 (setf a
(sqrt (- (log (* a sp
(- 1 z
)))))))))))
3050 (when maxima
::*debug-newton
*
3051 (format t
"approx = ~S~%" result
))
3053 (let ((two/sqrt-pi
(/ 2 (sqrt (%pi z
))))
3055 ;; Try to pick a reasonable epsilon value for the
3056 ;; Newton iteration.
3057 (cond ((<= (abs z
) 1)
3059 (cl:real
(* maxima
::*newton-epsilon-factor-float
*
3060 maxima
::flonum-epsilon
))
3061 (t (* maxima
::*newton-epsilon-factor
* (epsilon z
)))))
3063 (* maxima
::*newton-epsilon-factor
* (epsilon z
))))))
3064 (when maxima
::*debug-newton
*
3065 (format t
"eps = ~S~%" eps
))
3067 ;; Derivative of erf(x)
3068 (* two
/sqrt-pi
(exp (- (* x x
))))))
3075 (defun bf-inverse-erfc (z)
3078 (intl:gettext
"bf-inverse-erfc: inverse_erfc(~M) is undefined")
3085 ;; Find an approximate solution for x =
3086 ;; inverse_erfc(z). We have inverse_erfc(z) =
3087 ;; inverse_erf(1-z), so that's a good starting point.
3088 ;; We don't need full precision, so a float value is
3089 ;; good enough. But if 1-z is 1, inverse_erf is
3090 ;; undefined, so we need to do something else.
3092 (let ((1-z (float (- 1 z
) 0.0)))
3094 (if (minusp (realpart z
))
3095 (bf-inverse-erf (+ 1 (* 5 maxima
::flonum-epsilon
)))
3096 (bf-inverse-erf (- 1 (* 5 maxima
::flonum-epsilon
)))))
3098 (bf-inverse-erf 1-z
))))))
3099 (when maxima
::*debug-newton
*
3100 (format t
"approx = ~S~%" result
))
3102 (let ((-two/sqrt-pi
(/ -
2 (sqrt (%pi z
))))
3103 (eps (* maxima
::*newton-epsilon-factor
* (epsilon z
))))
3104 (when maxima
::*debug-newton
*
3105 (format t
"eps = ~S~%" eps
))
3107 ;; Derivative of erfc(x)
3108 (* -two
/sqrt-pi
(exp (- (* x x
))))))
3109 (bf-newton #'bf-erfc
3115 ;; Newton iteration for solving f(x) = z, given f and the derivative
3117 (defun bf-newton (f df z start eps
)
3119 (delta (/ (- (funcall f start
) z
)
3121 (/ (- (funcall f x
) z
)
3123 (count 0 (1+ count
)))
3124 ((or (< (abs delta
) (* (abs x
) eps
))
3125 (> count maxima
::*newton-maxcount
*))
3126 (if (> count maxima
::*newton-maxcount
*)
3128 (intl:gettext
"bf-newton: failed to converge after ~M iterations: delta = ~S, x = ~S eps = ~S")
3131 (when maxima
::*debug-newton
*
3132 (format t
"x = ~S, abs(delta) = ~S relerr = ~S~%"
3133 x
(abs delta
) (/ (abs delta
) (abs x
))))
3134 (setf x
(- x delta
))))
3136 (in-package :maxima
)
3138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3140 ;;; Implementation of the Fresnel Integral S(z)
3142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3144 (defmfun $fresnel_s
(z)
3145 (simplify (list '(%fresnel_s
) z
)))
3147 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3149 ;;; Set properties to give full support to the parser and display
3151 (defprop $fresnel_s %fresnel_s alias
)
3152 (defprop $fresnel_s %fresnel_s verb
)
3154 (defprop %fresnel_s $fresnel_s reversealias
)
3155 (defprop %fresnel_s $fresnel_s noun
)
3157 ;;; fresnel_s is a simplifying function
3159 (defprop %fresnel_s simp-fresnel-s operators
)
3161 ;;; fresnel_s distributes over bags
3163 (defprop %fresnel_s
(mlist $matrix mequal
) distribute_over
)
3165 ;;; fresnel_s has mirror symmetry
3167 (defprop %fresnel_s t commutes-with-conjugate
)
3169 ;;; fresnel_s is an odd function
3171 ;;; Maxima has two mechanism to define a reflection property
3172 ;;; 1. Declare the feature oddfun or evenfun
3173 ;;; 2. Put a reflection rule on the property list
3175 ;;; The second way is used for the trig functions. We use it here too.
3177 ;;; This would be the first way to give the property of an odd function.
3180 ; #-gcl (:load-toplevel :execute)
3181 ; (let (($context '$global) (context '$global))
3182 ; (meval '(($declare) %fresnel_s $oddfun))
3183 ; ;; Let's remove built-in symbols from list for user-defined properties.
3184 ; (setq $props (remove '%fresnel_s $props))))
3186 (defprop %fresnel_s odd-function-reflect reflection-rule
)
3188 ;;; Differentiation of the Fresnel Integral S
3192 ((%sin
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))
3195 ;;; Integration of the Fresnel Integral S
3200 ((mtimes) z
((%fresnel_s
) z
))
3203 ((%cos
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))))
3206 ;;; Limits of the Fresnel Integral S
3208 (defprop %fresnel_s simplim%fresnel_s simplim%function
)
3209 (defun simplim%fresnel_s
(exp var val
)
3210 (let ((arg (limit (cadr exp
) var val
'think
)))
3211 (cond ((eq arg
'$inf
)
3216 `((%fresnel_s
) ,arg
)))))
3218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3220 (defvar *fresnel-maxit
* 1000)
3221 (defvar *fresnel-eps
* (* 2 flonum-epsilon
))
3222 (defvar *fresnel-min
* 1e-32)
3224 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3225 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3227 (in-package :bigfloat
)
3229 (defun bf-fresnel (z)
3230 (let* ((eps (epsilon z
))
3231 (maxit maxima
::*fresnel-maxit
*)
3234 ;; For very small x, we have
3235 ;; fresnel_s(x) = %pi/6*z^3
3237 (s (* (/ bf-pi
6) z z z
))
3239 (when (> (abs z
) eps
)
3242 (when maxima
::*debug-gamma
*
3243 (format t
"~& in FRESNEL series expansion.~%"))
3244 (let ((sums 0) (sumc z
))
3247 (fact (* (/ bf-pi
2) (* z z
)))
3254 (maxima::merror
(intl:gettext
"fresnel: series expansion failed for (COMPLEX-BFLOAT-FRESNEL ~:M).") z
))
3255 (setq term
(* term
(/ fact k
)))
3256 (setq sum
(+ sum
(/ (* sign term
) n
)))
3257 (setq test
(* (abs sum
) eps
))
3260 (setq sign
(- sign
))
3266 (if (< (abs term
) test
)
3271 (let* ((sqrt-pi (sqrt bf-pi
))
3272 (z+ (* (complex 1/2 1/2)
3275 (z- (* (complex 1/2 -
1/2)
3280 (setq s
(* (complex 1/4 1/4)
3281 (+ erf
+ (* (complex 0 -
1) erf-
))))
3282 (setq c
(* (complex 1/4 -
1/4)
3283 (+ erf
+ (* (complex 0 1) erf-
))))))))
3286 (defun bf-fresnel-s (z)
3287 (if (and (complexp z
) (zerop (realpart z
)))
3288 ;; A pure imaginary argument. Use fresnel_s(%i*x)=-%i*fresnel_s(x).
3290 (- (bf-fresnel-s (imagpart z
))))
3291 (let ((fs (bf-fresnel z
)))
3296 (defun bf-fresnel-c (z)
3297 (if (and (complexp z
) (zerop (realpart z
)))
3298 ;; A pure imaginary argument. Use fresnel_c(%i*x)=%i*fresnel_c(x).
3300 (bf-fresnel-c (imagpart z
)))
3301 (let ((fc (nth-value 1 (bf-fresnel z
))))
3306 (in-package :maxima
)
3307 (defun simp-fresnel-s (expr z simpflag
)
3309 (setq z
(simpcheck (cadr expr
) simpflag
))
3312 ;; Check for specific values
3315 ((eq z
'$inf
) '((rat simp
) 1 2))
3316 ((eq z
'$minf
) '((rat simp
) -
1 2))
3318 ;; Check for numerical evaluation
3319 ((numerical-eval-p z
)
3320 (to (bigfloat::bf-fresnel-s
(bigfloat::to z
))))
3322 ;; Check for argument simplification
3324 ((taylorize (mop expr
) (second expr
)))
3325 ((and $%iargs
(multiplep z
'$%i
))
3326 (mul -
1 '$%i
(simplify (list '(%fresnel_s
) (coeff z
'$%i
1)))))
3327 ((apply-reflection-simp (mop expr
) z $trigsign
))
3329 ;; Representation through equivalent functions
3331 ($erf_representation
3333 (div (add 1 '$%i
) 4)
3338 (mul (div (add 1 '$%i
) 2) (power '$%pi
'((rat simp
) 1 2)) z
)))
3343 (mul (div (sub 1 '$%i
) 2)
3344 (power '$%pi
'((rat simp
) 1 2)) z
)))))))
3346 ($hypergeometric_representation
3347 (mul (div (mul '$%pi
(power z
3)) 6)
3348 (take '($hypergeometric
)
3349 (list '(mlist) (div 3 4))
3350 (list '(mlist) (div 3 2) (div 7 4))
3351 (mul -
1 (div (mul (power '$%pi
2) (power z
4)) 16)))))
3354 (eqtest (list '(%fresnel_s
) z
) expr
))))
3356 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3358 ;;; Implementation of the Fresnel Integral C(z)
3360 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3362 (defmfun $fresnel_c
(z)
3363 (simplify (list '(%fresnel_c
) z
)))
3365 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3367 ;;; Set properties to give full support to the parser and display
3369 (defprop $fresnel_c %fresnel_c alias
)
3370 (defprop $fresnel_c %fresnel_c verb
)
3372 (defprop %fresnel_c $fresnel_c reversealias
)
3373 (defprop %fresnel_c $fresnel_c noun
)
3375 ;;; fresnel_c is a simplifying function
3377 (defprop %fresnel_c simp-fresnel-c operators
)
3379 ;;; fresnel_c distributes over bags
3381 (defprop %fresnel_c
(mlist $matrix mequal
) distribute_over
)
3383 ;;; fresnel_c has mirror symmetry
3385 (defprop %fresnel_c t commutes-with-conjugate
)
3387 ;;; fresnel_c is an odd function
3388 ;;; Maxima has two mechanism to define a reflection property
3389 ;;; 1. Declare the feature oddfun or evenfun
3390 ;;; 2. Put a reflection rule on the property list
3392 ;;; The second way is used for the trig functions. We use it here too.
3394 (defprop %fresnel_c odd-function-reflect reflection-rule
)
3396 ;;; Differentiation of the Fresnel Integral C
3400 ((%cos
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))
3403 ;;; Integration of the Fresnel Integral C
3408 ((mtimes) z
((%fresnel_c
) z
))
3411 ((%sin
) ((mtimes) ((rat) 1 2) $%pi
((mexpt) z
2))))))
3414 ;;; Limits of the Fresnel Integral C
3416 (defprop %fresnel_c simplim%fresnel_c simplim%function
)
3417 (defun simplim%fresnel_c
(exp var val
)
3418 (let ((arg (limit (cadr exp
) var val
'think
)))
3419 (cond ((eq arg
'$inf
)
3424 `((%fresnel_c
) ,arg
)))))
3426 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3428 (defun simp-fresnel-c (expr z simpflag
)
3430 (setq z
(simpcheck (cadr expr
) simpflag
))
3433 ;; Check for specific values
3436 ((eq z
'$inf
) '((rat simp
) 1 2))
3437 ((eq z
'$minf
) '((rat simp
) -
1 2))
3439 ;; Check for numerical evaluation
3440 ((numerical-eval-p z
)
3441 (to (bigfloat::bf-fresnel-c
(bigfloat::to z
))))
3444 ;; Check for argument simplification
3446 ((taylorize (mop expr
) (second expr
)))
3447 ((and $%iargs
(multiplep z
'$%i
))
3448 (mul '$%i
(simplify (list '(%fresnel_c
) (coeff z
'$%i
1)))))
3449 ((apply-reflection-simp (mop expr
) z $trigsign
))
3451 ;; Representation through equivalent functions
3453 ($erf_representation
3455 (div (sub 1 '$%i
) 4)
3460 (mul (div (add 1 '$%i
) 2) (power '$%pi
'((rat simp
) 1 2)) z
)))
3465 (mul (div (sub 1 '$%i
) 2)
3466 (power '$%pi
'((rat simp
) 1 2)) z
)))))))
3468 ($hypergeometric_representation
3470 (take '($hypergeometric
)
3471 (list '(mlist) (div 1 4))
3472 (list '(mlist) (div 1 2) (div 5 4))
3473 (mul -
1 (div (mul (power '$%pi
2) (power z
4)) 16)))))
3476 (eqtest (list '(%fresnel_c
) z
) expr
))))
3479 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3481 ;;; Implementation of the Beta function
3483 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3485 ;;; The code for the implementation of the beta function is in the files
3486 ;;; csimp2.lisp, simp.lisp and mactex.lisp.
3487 ;;; At this place we only implement the operator property SYMMETRIC.
3489 ;;; Beta is symmetric beta(a,b) = beta(b,a)
3493 #-gcl
(:load-toplevel
:execute
)
3494 (let (($context
'$global
) (context '$global
))
3495 (meval '(($declare
) $beta $symmetric
))
3496 ;; Let's remove built-in symbols from list for user-defined properties.
3497 (setq $props
(remove '$beta $props
))))
3499 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3501 ;;; Implementation of the Incomplete Beta function
3503 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3505 (defvar *beta-incomplete-maxit
* 10000)
3506 (defvar *beta-incomplete-eps
* 1.0e-15)
3508 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3510 (defmfun $beta_incomplete
(a b z
)
3511 (simplify (list '(%beta_incomplete
) a b z
)))
3513 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3515 (defprop $beta_incomplete %beta_incomplete alias
)
3516 (defprop $beta_incomplete %beta_incomplete verb
)
3518 (defprop %beta_incomplete $beta_incomplete reversealias
)
3519 (defprop %beta_incomplete $beta_incomplete noun
)
3521 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3523 (defprop %beta_incomplete simp-beta-incomplete operators
)
3525 ;;; beta_incomplete distributes over bags
3527 (defprop %beta_incomplete
(mlist $matrix mequal
) distribute_over
)
3529 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3531 (defprop %beta_incomplete
3535 ((%beta_incomplete
) a b z
)
3537 ((mexpt) ((%gamma
) a
) 2)
3538 (($hypergeometric_regularized
)
3539 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3540 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3550 ((mtimes) -
1 ((mqapply) (($psi array
) 0) ((mplus) a b
)))))
3552 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z
)))
3553 ((%log
) ((mplus) 1 ((mtimes) -
1 z
))))
3555 ((mexpt) ((%gamma
) b
) 2)
3556 (($hypergeometric_regularized
)
3557 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3558 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3559 ((mplus) 1 ((mtimes) -
1 z
)))
3560 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) b
))))
3561 ;; The derivative wrt z
3563 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) ((mplus) -
1 b
))
3564 ((mexpt) z
((mplus) -
1 a
))))
3567 ;;; Integral of the Incomplete Beta function
3569 (defprop %beta_incomplete
3574 ((mtimes) -
1 ((%beta_incomplete
) ((mplus) 1 a
) b z
))
3575 ((mtimes) ((%beta_incomplete
) a b z
) z
)))
3578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3580 (defun simp-beta-incomplete (expr ignored simpflag
)
3581 (declare (ignore ignored
))
3582 (arg-count-check 3 expr
)
3583 (let ((a (simpcheck (cadr expr
) simpflag
))
3584 (b (simpcheck (caddr expr
) simpflag
))
3585 (z (simpcheck (cadddr expr
) simpflag
))
3588 (format t
"~&SIMP-BETA-INCOMPLETE:~%")
3589 (format t
"~& : a = ~A~%" a
)
3590 (format t
"~& : b = ~A~%" b
)
3591 (format t
"~& : z = ~A~%" z
))
3594 ;; Check for specific values
3597 (let ((sgn ($sign
($realpart a
))))
3598 (cond ((member sgn
'($neg $zero
))
3601 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.")
3603 ((member sgn
'($pos $pz
))
3606 (eqtest (list '(%beta_incomplete
) a b z
) expr
)))))
3608 ((and (onep1 z
) (eq ($sign
($realpart b
)) '$pos
))
3609 ;; z=1 and realpart(b)>0. Simplify to a Beta function.
3610 ;; If we have to evaluate numerically preserve the type.
3612 ((complex-float-numerical-eval-p a b z
)
3613 (simplify (list '($beta
) ($float a
) ($float b
))))
3614 ((complex-bigfloat-numerical-eval-p a b z
)
3615 (simplify (list '($beta
) ($bfloat a
) ($bfloat b
))))
3617 (simplify (list '($beta
) a b
)))))
3620 (and (integer-representation-p a
)
3621 (eq ($sign a
) '$neg
)
3623 (not (integer-representation-p b
)))
3624 (eq ($sign
(add a b
)) '$pos
))))
3625 ;; The argument a is zero or a is negative and the argument b is
3626 ;; not in a valid range. Beta incomplete is undefined.
3627 ;; It would be more correct to return Complex infinity.
3630 "beta_incomplete: beta_incomplete(~:M,~:M,~:M) is undefined.") a b z
))
3632 ;; Check for numerical evaluation in Float or Bigfloat precision
3634 ((complex-float-numerical-eval-p a b z
)
3636 ((not (and (integer-representation-p a
) (< a
0.0)))
3637 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0))))
3638 (beta-incomplete ($float a
) ($float b
) ($float z
))))
3640 ;; Negative integer a and b is in a valid range. Expand.
3642 (beta-incomplete-expand-negative-integer
3643 (truncate a
) ($float b
) ($float z
))))))
3645 ((complex-bigfloat-numerical-eval-p a b z
)
3647 ((not (and (integer-representation-p a
) (eq ($sign a
) '$neg
)))
3648 (let ((*beta-incomplete-eps
*
3649 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
3650 (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z
))))
3652 ;; Negative integer a and b is in a valid range. Expand.
3654 (beta-incomplete-expand-negative-integer
3655 ($truncate a
) ($bfloat b
) ($bfloat z
))))))
3657 ;; Argument simplifications and transformations
3661 (or (not (integerp a
))
3663 ;; Expand for b a positive integer and a not a negative integer.
3665 (simplify (list '($beta
) a b
))
3667 (let ((index (gensumindex)))
3671 (simplify (list '($pochhammer
) a index
))
3672 (power (sub 1 z
) index
))
3673 (simplify (list '(mfactorial) index
)))
3674 index
0 (sub b
1)))))
3676 ((and (integerp a
) (plusp a
))
3677 ;; Expand for a a positive integer.
3679 (simplify (list '($beta
) a b
))
3683 (let ((index (gensumindex)))
3687 (simplify (list '($pochhammer
) b index
))
3689 (simplify (list '(mfactorial) index
)))
3690 index
0 (sub a
1)))))))
3692 ((and (integerp a
) (minusp a
) (integerp b
) (plusp b
) (<= b
(- a
)))
3693 ;; Expand for a a negative integer and b an integer with b <= -a.
3696 (let ((index (gensumindex)))
3699 (mul (simplify (list '($pochhammer
) (sub 1 b
) index
))
3702 (simplify (list '(mfactorial) index
))))
3703 index
0 (sub b
1)))))
3705 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
3707 (a (simplify (cons '(mplus) (cddr a
)))))
3711 (simplify (list '($pochhammer
) a n
))
3712 (simplify (list '($pochhammer
) (add a b
) n
)))
3713 ($beta_incomplete a b z
))
3715 (power (add a b n -
1) -
1)
3716 (let ((index (gensumindex)))
3720 (simplify (list '($pochhammer
)
3721 (add 1 (mul -
1 a
) (mul -
1 n
))
3723 (simplify (list '($pochhammer
)
3724 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
3726 (mul (power (sub 1 z
) b
)
3727 (power z
(add a n
(mul -
1 index
) -
1))))
3728 index
0 (sub n
1)))))))
3730 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
3731 (let ((n (- (cadr a
)))
3732 (a (simplify (cons '(mplus) (cddr a
)))))
3736 (simplify (list '($pochhammer
) (add 1 (mul -
1 a
) (mul -
1 b
)) n
))
3737 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3738 ($beta_incomplete a b z
))
3742 (list '($pochhammer
) (add 2 (mul -
1 a
) (mul -
1 b
)) (sub n
1)))
3743 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
3744 (let ((index (gensumindex)))
3748 (simplify (list '($pochhammer
) (sub 1 a
) index
))
3749 (simplify (list '($pochhammer
)
3750 (add 2 (mul -
1 a
) (mul -
1 b
))
3752 (mul (power (sub 1 z
) b
)
3753 (power z
(add a
(mul -
1 index
) -
1))))
3754 index
0 (sub n
1)))))))
3757 (eqtest (list '(%beta_incomplete
) a b z
) expr
)))))
3759 (defun beta-incomplete-expand-negative-integer (a b z
)
3762 (let ((index (gensumindex)) ($simpsum t
))
3765 (mul (simplify (list '($pochhammer
) (sub 1 b
) index
))
3767 (mul (add index a
) (simplify (list '(mfactorial) index
))))
3768 index
0 (sub b
1)))))
3770 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3772 (defun beta-incomplete (a b z
)
3774 ((eq ($sign
(sub (mul ($realpart z
) ($realpart
(add a b
2)))
3775 ($realpart
(add a
1))))
3779 (simplify (list '($beta
) a b
))
3780 (to (numeric-beta-incomplete b a
(sub 1.0 z
))))))
3782 (to (numeric-beta-incomplete a b z
)))))
3784 (defun numeric-beta-incomplete (a b z
)
3786 (format t
"~&NUMERIC-BETA-INCOMPLETE enters continued fractions~%"))
3787 (let ((a (bigfloat:to a
))
3789 (z (bigfloat:to z
)))
3790 (do* ((beta-maxit *beta-incomplete-maxit
*)
3791 (beta-eps *beta-incomplete-eps
*)
3792 (beta-min (bigfloat:* beta-eps beta-eps
))
3793 (ab (bigfloat:+ a b
))
3794 (ap (bigfloat:+ a
1.0))
3795 (am (bigfloat:- a
1.0))
3797 (d (bigfloat:-
1.0 (bigfloat:/ (bigfloat:* z ab
) ap
)))
3798 (d (if (bigfloat:< (bigfloat:abs d
) beta-min
) beta-min d
))
3799 (d (bigfloat:/ 1.0 d
))
3806 (merror (intl:gettext
"beta_incomplete: continued fractions failed for beta_incomplete(~:M, ~:M, ~:M).") a b z
))
3808 (setq aa
(bigfloat:/ (bigfloat:* m z
(bigfloat:- b m
))
3809 (bigfloat:* (bigfloat:+ am m2
)
3810 (bigfloat:+ a m2
))))
3811 (setq d
(bigfloat:+ 1.0 (bigfloat:* aa d
)))
3812 (when (bigfloat:< (bigfloat:abs d
) beta-min
) (setq d beta-min
))
3813 (setq c
(bigfloat:+ 1.0 (bigfloat:/ aa c
)))
3814 (when (bigfloat:< (bigfloat:abs c
) beta-min
) (setq c beta-min
))
3815 (setq d
(bigfloat:/ 1.0 d
))
3816 (setq h
(bigfloat:* h d c
))
3817 (setq aa
(bigfloat:/ (bigfloat:* -
1
3819 (bigfloat:+ ab m
) z
)
3820 (bigfloat:* (bigfloat:+ a m2
)
3821 (bigfloat:+ ap m2
))))
3822 (setq d
(bigfloat:+ 1.0 (bigfloat:* aa d
)))
3823 (when (bigfloat:< (bigfloat:abs d
) beta-min
) (setq d beta-min
))
3824 (setq c
(bigfloat:+ 1.0 (bigfloat:/ aa c
)))
3825 (when (bigfloat:< (bigfloat:abs c
) beta-min
) (setq c beta-min
))
3826 (setq d
(bigfloat:/ 1.0 d
))
3827 (setq de
(bigfloat:* d c
))
3828 (setq h
(bigfloat:* h de
))
3829 (when (bigfloat:< (bigfloat:abs
(bigfloat:- de
1.0)) beta-eps
)
3831 (format t
"~&Continued fractions finished.~%")
3832 (format t
"~& z = ~A~%" z
)
3833 (format t
"~& a = ~A~%" a
)
3834 (format t
"~& b = ~A~%" b
)
3835 (format t
"~& h = ~A~%" h
))
3841 (bigfloat:expt
(bigfloat:-
1.0 z
) b
)) a
)))
3843 (format t
"~& result = ~A~%" result
))
3846 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3848 ;;; Implementation of the Generalized Incomplete Beta function
3850 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3852 (defmfun $beta_incomplete_generalized
(a b z1 z2
)
3853 (simplify (list '(%beta_incomplete_generalized
) a b z1 z2
)))
3855 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3857 (defprop $beta_incomplete_generalized %beta_incomplete_generalized alias
)
3858 (defprop $beta_incomplete_generalized %beta_incomplete_generalized verb
)
3860 (defprop %beta_incomplete_generalized $beta_incomplete_generalized reversealias
)
3861 (defprop %beta_incomplete_generalized $beta_incomplete_generalized noun
)
3863 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3865 (defprop %beta_incomplete_generalized
3866 simp-beta-incomplete-generalized operators
)
3868 ;;; beta_incomplete_generalized distributes over bags
3870 (defprop %beta_incomplete_generalized
(mlist $matrix mequal
) distribute_over
)
3872 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3874 ;;; Generalized Incomplete Gamma function has not mirror symmetry for z1 or z2
3875 ;;; but not on the negative real axis and for z1 or z2 real and > 1.
3876 ;;; We support a conjugate-function which test these cases.
3878 (defprop %beta_incomplete_generalized
3879 conjugate-beta-incomplete-generalized conjugate-function
)
3881 (defun conjugate-beta-incomplete-generalized (args)
3882 (let ((a (first args
))
3886 (cond ((and (off-negative-real-axisp z1
)
3887 (not (and (zerop1 ($imagpart z1
))
3888 (eq ($sign
(sub ($realpart z1
) 1)) '$pos
)))
3889 (off-negative-real-axisp z2
)
3890 (not (and (zerop1 ($imagpart z2
))
3891 (eq ($sign
(sub ($realpart z2
) 1)) '$pos
))))
3894 '(%beta_incomplete_generalized
)
3895 (simplify (list '($conjugate
) a
))
3896 (simplify (list '($conjugate
) b
))
3897 (simplify (list '($conjugate
) z1
))
3898 (simplify (list '($conjugate
) z2
)))))
3902 (simplify (list '(%beta_incomplete_generalized
)
3905 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3907 (defprop %beta_incomplete_generalized
3912 ((%beta_incomplete
) a b z1
)
3915 ((mexpt) ((%gamma
) a
) 2)
3918 (($hypergeometric_regularized
)
3919 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3920 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3924 (($hypergeometric_regularized
)
3925 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
3926 ((mlist) ((mplus) 1 a
) ((mplus) 1 a
))
3929 ((mtimes) ((%beta_incomplete
) a b z2
) ((%log
) z2
)))
3933 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z1
)))
3934 ((%log
) ((mplus) 1 ((mtimes) -
1 z1
))))
3936 ((%beta_incomplete
) b a
((mplus) 1 ((mtimes) -
1 z2
)))
3937 ((%log
) ((mplus) 1 ((mtimes) -
1 z2
))))
3939 ((mexpt) ((%gamma
) b
) 2)
3942 (($hypergeometric_regularized
)
3943 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3944 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3945 ((mplus) 1 ((mtimes) -
1 z1
)))
3946 ((mexpt) ((mplus) 1 ((mtimes) -
1 z1
)) b
))
3948 (($hypergeometric_regularized
)
3949 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
3950 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
3951 ((mplus) 1 ((mtimes) -
1 z2
)))
3952 ((mexpt) ((mplus) 1 ((mtimes) -
1 z2
)) b
)))))
3953 ;; The derivative wrt z1
3956 ((mplus) 1 ((mtimes) -
1 z1
))
3958 ((mexpt) z1
((mplus) -
1 a
)))
3959 ;; The derivative wrt z2
3962 ((mplus) 1 ((mtimes) -
1 z2
))
3964 ((mexpt) z2
((mplus) -
1 a
))))
3967 ;;; Integral of the Incomplete Beta function
3969 (defprop %beta_incomplete_generalized
3975 ((%beta_incomplete
) ((mplus) 1 a
) b z1
)
3976 ((mtimes) ((%beta_incomplete_generalized
) a b z1 z2
) z1
))
3980 ((%beta_incomplete
) ((mplus) 1 a
) b z2
))
3981 ((mtimes) ((%beta_incomplete_generalized
) a b z1 z2
) z2
)))
3984 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3986 (defun simp-beta-incomplete-generalized (expr ignored simpflag
)
3987 (declare (ignore ignored
))
3988 (arg-count-check 4 expr
)
3989 (let ((a (simpcheck (second expr
) simpflag
))
3990 (b (simpcheck (third expr
) simpflag
))
3991 (z1 (simpcheck (fourth expr
) simpflag
))
3992 (z2 (simpcheck (fifth expr
) simpflag
))
3996 ;; Check for specific values
3999 (let ((sgn ($sign
($realpart a
))))
4000 (cond ((eq sgn
'$neg
)
4003 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
4005 ((member sgn
'($pos $pz
))
4006 (mul -
1 ($beta_incomplete a b z1
)))
4009 (list '(%beta_incomplete_generalized
) a b z1 z2
) expr
)))))
4012 (let ((sgn ($sign
($realpart a
))))
4013 (cond ((eq sgn
'$neg
)
4016 "beta_incomplete_generalized: beta_incomplete_generalized(~:M,~:M,~:M,~:M) is undefined.")
4018 ((member sgn
'($pos $pz
))
4019 (mul -
1 ($beta_incomplete a b z2
)))
4022 (list '(%beta_incomplete_generalized
) a b z1 z2
) expr
)))))
4024 ((and (onep1 z2
) (or (not (mnump a
)) (not (mnump b
)) (not (mnump z1
))))
4025 (let ((sgn ($sign
($realpart b
))))
4026 (cond ((member sgn
'($pos $pz
))
4027 (sub (simplify (list '($beta
) a b
))
4028 ($beta_incomplete a b z1
)))
4031 (list '(%beta_incomplete_generalized
) a b z1 z2
) expr
)))))
4033 ((and (onep1 z1
) (or (not (mnump a
)) (not (mnump b
)) (not (mnump z2
))))
4034 (let ((sgn ($sign
($realpart b
))))
4035 (cond ((member sgn
'($pos $pz
))
4036 (sub ($beta_incomplete a b z2
)
4037 (simplify (list '($beta
) a b
))))
4040 (list '(%beta_incomplete_generalized
) a b z1 z2
) expr
)))))
4042 ;; Check for numerical evaluation in Float or Bigfloat precision
4044 ((complex-float-numerical-eval-p a b z1 z2
)
4045 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0))))
4046 (sub (beta-incomplete ($float a
) ($float b
) ($float z2
))
4047 (beta-incomplete ($float a
) ($float b
) ($float z1
)))))
4049 ((complex-bigfloat-numerical-eval-p a b z1 z2
)
4050 (let ((*beta-incomplete-eps
*
4051 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
4052 (sub (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z2
))
4053 (beta-incomplete ($bfloat a
) ($bfloat b
) ($bfloat z1
)))))
4055 ;; Check for argument simplifications and transformations
4057 ((and (integerp a
) (plusp a
))
4059 (simplify (list '($beta
) a b
))
4062 (power (sub 1 z1
) b
)
4063 (let ((index (gensumindex)))
4067 (simplify (list '($pochhammer
) b index
))
4069 (simplify (list '(mfactorial) index
)))
4070 index
0 (sub a
1))))
4072 (power (sub 1 z2
) b
)
4073 (let ((index (gensumindex)))
4077 (simplify (list '($pochhammer
) b index
))
4079 (simplify (list '(mfactorial) index
)))
4080 index
0 (sub a
1)))))))
4082 ((and (integerp b
) (plusp b
))
4084 (simplify (list '($beta
) a b
))
4088 (let ((index (gensumindex)))
4092 (simplify (list '($pochhammer
) a index
))
4093 (power (sub 1 z2
) index
))
4094 (simplify (list '(mfactorial) index
)))
4095 index
0 (sub b
1))))
4098 (let ((index (gensumindex)))
4102 (simplify (list '($pochhammer
) a index
))
4103 (power (sub 1 z1
) index
))
4104 (simplify (list '(mfactorial) index
)))
4105 index
0 (sub b
1)))))))
4107 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
4109 (a (simplify (cons '(mplus) (cddr a
)))))
4113 (simplify (list '($pochhammer
) a n
))
4114 (simplify (list '($pochhammer
) (add a b
) n
)))
4115 ($beta_incomplete_generalized a b z1 z2
))
4117 (power (add a b n -
1) -
1)
4118 (let ((index (gensumindex)))
4122 (simplify (list '($pochhammer
)
4123 (add 1 (mul -
1 a
) (mul -
1 n
))
4125 (simplify (list '($pochhammer
)
4126 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
4129 (mul (power (sub 1 z1
) b
)
4130 (power z1
(add a n
(mul -
1 index
) -
1)))
4131 (mul (power (sub 1 z2
) b
)
4132 (power z2
(add a n
(mul -
1 index
) -
1)))))
4133 index
0 (sub n
1)))))))
4135 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
4136 (let ((n (- (cadr a
)))
4137 (a (simplify (cons '(mplus) (cddr a
)))))
4141 (simplify (list '($pochhammer
) (add 1 (mul -
1 a
) (mul -
1 b
)) n
))
4142 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
4143 ($beta_incomplete_generalized a b z1 z2
))
4147 (list '($pochhammer
) (add 2 (mul -
1 a
) (mul -
1 b
)) (sub n
1)))
4148 (simplify (list '($pochhammer
) (sub 1 a
) n
)))
4149 (let ((index (gensumindex)))
4153 (simplify (list '($pochhammer
) (sub 1 a
) index
))
4154 (simplify (list '($pochhammer
)
4155 (add 2 (mul -
1 a
) (mul -
1 b
))
4158 (mul (power (sub 1 z2
) b
)
4159 (power z2
(add a
(mul -
1 index
) -
1)))
4160 (mul (power (sub 1 z1
) b
)
4161 (power z1
(add a
(mul -
1 index
) -
1)))))
4162 index
0 (sub n
1)))))))
4165 (eqtest (list '(%beta_incomplete_generalized
) a b z1 z2
) expr
)))))
4167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4169 ;;; Implementation of the Regularized Incomplete Beta function
4171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4173 (defmfun $beta_incomplete_regularized
(a b z
)
4174 (simplify (list '(%beta_incomplete_regularized
) a b z
)))
4176 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4178 (defprop $beta_incomplete_regularized %beta_incomplete_regularized alias
)
4179 (defprop $beta_incomplete_regularized %beta_incomplete_regularized verb
)
4181 (defprop %beta_incomplete_regularized $beta_incomplete_regularized reversealias
)
4182 (defprop %beta_incomplete_regularized $beta_incomplete_regularized noun
)
4184 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4186 (defprop %beta_incomplete_regularized
4187 simp-beta-incomplete-regularized operators
)
4189 ;;; beta_incomplete_regularized distributes over bags
4191 (defprop %beta_incomplete_regularized
(mlist $matrix mequal
) distribute_over
)
4193 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4195 (defprop %beta_incomplete_regularized
4201 (($hypergeometric_regularized
)
4202 ((mlist) a a
((mplus) 1 ((mtimes) -
1 b
)))
4203 ((mlist) ((mplus) 1 a
) ((mplus) 2 a
)) z
)
4204 ((mexpt) ((%gamma
) b
) -
1)
4205 ((%gamma
) ((mplus) a b
))
4208 ((%beta_incomplete_regularized
) a b z
)
4210 ((mtimes) -
1 ((mqapply) (($psi array
) 0) a
))
4211 ((mqapply) (($psi array
) 0) ((mplus) a b
))
4216 ((%beta_incomplete_regularized
) b a
((mplus) 1 ((mtimes) -
1 z
)))
4218 ((mqapply) (($psi array
) 0) b
)
4219 ((mtimes) -
1 ((mqapply) (($psi array
) 0) ((mplus) a b
)))
4220 ((mtimes) -
1 ((%log
) ((mplus) 1 ((mtimes) -
1 z
))))))
4222 ((mexpt) ((%gamma
) a
) -
1)
4224 ((%gamma
) ((mplus) a b
))
4225 (($hypergeometric_regularized
)
4226 ((mlist) b b
((mplus) 1 ((mtimes) -
1 a
)))
4227 ((mlist) ((mplus) 1 b
) ((mplus) 1 b
))
4228 ((mplus) 1 ((mtimes) -
1 z
)))
4229 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) b
)))
4230 ;; The derivative wrt z
4232 ((mexpt) (($beta
) a b
) -
1)
4233 ((mexpt) ((mplus) 1 ((mtimes) -
1 z
)) ((mplus) -
1 b
))
4234 ((mexpt) z
((mplus) -
1 a
))))
4237 ;;; Integral of the Generalized Incomplete Beta function
4239 (defprop %beta_incomplete_regularized
4246 ((%beta_incomplete_regularized
) ((mplus) 1 a
) b z
)
4247 ((mexpt) ((mplus) a b
) -
1))
4248 ((mtimes) ((%beta_incomplete_regularized
) a b z
) z
)))
4251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4253 (defun simp-beta-incomplete-regularized (expr ignored simpflag
)
4254 (declare (ignore ignored
))
4255 (arg-count-check 3 expr
)
4256 (let ((a (simpcheck (second expr
) simpflag
))
4257 (b (simpcheck (third expr
) simpflag
))
4258 (z (simpcheck (fourth expr
) simpflag
))
4262 ;; Check for specific values
4265 (let ((sgn ($sign
($realpart a
))))
4266 (cond ((eq sgn
'$neg
)
4269 "beta_incomplete_regularized: beta_incomplete_regularized(~:M,~:M,~:M) is undefined.")
4271 ((member sgn
'($pos $pz
))
4275 (list '(%beta_incomplete_regularized
) a b z
) expr
)))))
4281 (let ((sgn ($sign
($realpart b
))))
4282 (cond ((member sgn
'($pos $pz
))
4286 (list '(%beta_incomplete_regularized
) a b z
) expr
)))))
4288 ((and (integer-representation-p b
)
4289 (if ($bfloatp b
) (minusp (cadr b
)) (minusp b
)) )
4290 ;; Problem: for b a negative integer the Regularized Incomplete
4291 ;; Beta function is defined to be zero. BUT: When we calculate
4292 ;; e.g. beta_incomplete(1.0,-2.0,1/2)/beta(1.0,-2.0) we get the
4293 ;; result -3.0, because beta_incomplete and beta are defined for
4294 ;; for this case. How do we get a consistent behaviour?
4297 ((and (integer-representation-p a
)
4298 (if ($bfloatp a
) (minusp (cadr a
)) (minusp a
)) )
4300 ;; TODO: The following line does not work for bigfloats.
4301 ((and (integer-representation-p b
) (<= b
(- a
)))
4302 ;; Does $beta_incomplete or simpbeta underflow in this case?
4303 (div ($beta_incomplete a b z
)
4304 (simplify (list '($beta
) a b
))))
4308 ;; Check for numerical evaluation in Float or Bigfloat precision
4310 ((complex-float-numerical-eval-p a b z
)
4311 (let ((*beta-incomplete-eps
* (bigfloat:epsilon
($float
1.0)))
4313 (setq a
($float a
) b
($float b
))
4314 (if (or (< ($abs
(setq beta
(simplify (list '($beta
) a b
)))) 1e-307)
4315 (< ($abs
(setq ibeta
(beta-incomplete a b
($float z
)))) 1e-307) )
4316 ;; In case of underflow (see bug #2999) or precision loss use bigfloats
4317 ;; and emporarily give some extra precision but avoid fpprec dependency.
4318 ;; Is this workaround correct for complex values?
4320 ($float
($beta_incomplete_regularized
($bfloat a
) ($bfloat b
) z
)) )
4321 ($rectform
(div ibeta beta
)) )))
4323 ((complex-bigfloat-numerical-eval-p a b z
)
4324 (let ((*beta-incomplete-eps
*
4325 (bigfloat:epsilon
(bigfloat:bigfloat
1.0))))
4326 (setq a
($bfloat a
) b
($bfloat b
))
4328 (div (beta-incomplete a b
($bfloat z
))
4329 (simplify (list '($beta
) a b
))))))
4331 ;; Check for argument simplifications and transformations
4333 ((and (integerp b
) (plusp b
))
4334 (div ($beta_incomplete a b z
)
4335 (simplify (list '($beta
) a b
))))
4337 ((and (integerp a
) (plusp a
))
4338 (div ($beta_incomplete a b z
)
4339 (simplify (list '($beta
) a b
))))
4341 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (plusp (cadr a
)))
4343 (a (simplify (cons '(mplus) (cddr a
)))))
4345 ($beta_incomplete_regularized a b z
)
4347 (power (add a b n -
1) -
1)
4348 (power (simplify (list '($beta
) (add a n
) b
)) -
1)
4349 (let ((index (gensumindex)))
4353 (simplify (list '($pochhammer
)
4354 (add 1 (mul -
1 a
) (mul -
1 n
))
4356 (simplify (list '($pochhammer
)
4357 (add 2 (mul -
1 a
) (mul -
1 b
) (mul -
1 n
))
4360 (power z
(add a n
(mul -
1 index
) -
1)))
4361 index
0 (sub n
1)))))))
4363 ((and $beta_expand
(mplusp a
) (integerp (cadr a
)) (minusp (cadr a
)))
4364 (let ((n (- (cadr a
)))
4365 (a (simplify (cons '(mplus) (cddr a
)))))
4367 ($beta_incomplete_regularized a b z
)
4369 (power (add a b -
1) -
1)
4370 (power (simplify (list '($beta
) a b
)) -
1)
4371 (let ((index (gensumindex)))
4375 (simplify (list '($pochhammer
) (sub 1 a
) index
))
4376 (simplify (list '($pochhammer
)
4377 (add 2 (mul -
1 a
) (mul -
1 b
))
4380 (power z
(add a
(mul -
1 index
) -
1)))
4381 index
0 (sub n
1)))))))
4384 (eqtest (list '(%beta_incomplete_regularized
) a b z
) expr
)))))
4386 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;