(* Package Specialfunctions, Copyright (C) 1992-2006 Wolfram Koepf, University Kassel *) (* Version fuer: Koepf, Wolfram: Computeralgebra. Eine algorithmisch orientierte Einfuehrung. Springer, Berlin/Heidelberg, 2006 *) (* Mathematica Version 8.0, Package Release 2.03 *) (* Um das Package "SpecialFunctions" zu installieren, verschiebt man die Datei "SpecialFunctions.m" in den Ordner AddOns/ExtraPackages, der sich in dem Verzeichnis befindet, wo man Mathematica installiert hat. Alternativ kann man das Verzeichnis, in dem "SpecialFunctions.m" liegt, mit dem Mathematica-Befehl SetDirectory angeben. Das Package laedt man dann mit dem Mathematica-Befehl Needs["SpecialFunctions`"]. *) (* This package loads the package zb_alg (C), Peter Paule/Markus Schorn from the same file. A newer version of their implementation can be downloaded from http://www.risc.uni-linz.ac.at/research/combinat/risc/software *) (*:Version: Mathematica 2.2-8.0 *) (*:Name: SpecialFunctions *) (*:Authors: Wolfram Koepf, Axel Rennoch, Gregor Stoelting 1992, 1993 Wolfram Koepf 1994-2011 *) (*:Keywords: ComplexFactor, ComplexApart, Pochhammer, SimpleDE, DEOrder, DEtoRE, SimpleRE, HolonomicDE, holonomicDE, PowerSeries, PS, FPS, AsymptPowerSeries, Convert, SimpByRecursion, FindRecursion, REtoDE, RETODE, SumtoDE, Bateman, Hankel1, Hankel2, KummerM, KummerU, WhittakerM, WhittakerW, StruveH, StruveL, Erfc, Abramowitz, NormalIntegral, KnuthA, KnuthB, ParabolicU, ParabolicD, ParabolicV, (* missing: ParabolicW, ParabolicE, ParabolicEstar, *) Hypergeometric0F1, Hypergeometric1F0, HypergeometricU, Hypergeometric1F1, Hypergeometric2F0, Hypergeometric2F1, Hypergeometric2F3, Hypergeometric3F2, (* missing: CoulombWaveF,CoulombWaveG, Mathieu, Kelvin, *) EllipticK, EllipticE, SphericalBesselJ, SphericalBesselY, SphericalBesselI, SphericalBesselK, SphericalHankel1, SphericalHankel2, Krawtchouk, Charlier, Meixner, DiscreteChebyshev, DiscreteLaguerre, Hahn, (* Nikiforov, Suslov, Uvarov: Classical Orthogonal Polynomials of a Discrete Variable *) (* todo: Wilson *) SumDE, DESum, ProductDE, DEProduct, SumRE, RESum, ProductRE, REProduct, ConvolutionRE, ZTransform, InverseZTransform, SumToHypergeometric, FunctionToHypergeometric, GeneratingFunction, ExponentialGeneratingFunction, specfunprint, nospecfunprint, specfunprintoff, SimplifyGamma, SimplifyCombinatorial, SimpComb, Ratio, ToGamma, HyperTerm, SeriesSolution, Taylor *) (*:References: Wolfram Koepf: Power Series in Computer Algebra, Journal of Symbolic Computation 13, 1992, 581-603. Wolfram Koepf: Algorithmic development of power series. In: Artificial intelligence and symbolic mathematical computing, J. Calmet and J. A. Campbell, Editors, International Conference AISMC-1, Karlsruhe, Germany, August 1992, Proceedings, Lecture Notes in Computer Science 737, Springer-Verlag, Berlin-Heidelberg, 1993, 195-213. Wolfram Koepf: Examples for the algorithmic calculation of formal Puiseux, Laurent and power series. SIGSAM Bulletin 27, 1993, 20-32. Wolfram Koepf, Dieter Schmersau: Bounded nonvanishing functions and Bateman functions. Preprint A/31-93 Free University Berlin, Department of Mathematics, 1993. Complex Variables 25, 1994, 237-259. Wolfram Koepf: A package on formal power series. Mathematica Journal 4, 1994, 62-69. Wolfram Koepf, Dieter Schmersau: Spaces of functions satisfying simple differential equations. Konrad-Zuse-Zentrum Berlin (ZIB), Technical Report TR 94-2, 1994. Wolfram Koepf: Algorithmic work with orthogonal polynomials and special functions. Konrad-Zuse-Zentrum Berlin (ZIB), Preprint SC 94-5, 1994. Wolfram Koepf: Algorithms for m-fold hypergeometric summation. Journal of Symbolic Computation 20, 1995, 399-417. Peter Paule, Markus Schorn: A Mathematica version of Zeilberger's algorithm for proving binomial coefficient identities. J. Symbolic Computation 20, 1995, 673-698. The article Wolfram Koepf: A Package on Orthogonal Polynomials and Special Functions. Konrad-Zuse-Zentrum Berlin (ZIB), Preprint 1996. is kind of a manual for the package. *) (*:Requirements: none. *) (*:History: Version 0.0 by Wolfram Koepf, Axel Rennoch, 1991 Modified by Wolfram Koepf, March, April 1992. Modified by Wolfram Koepf, Gregor Stoelting, October 1992. Version 0.01 by Wolfram Koepf, Gregor Stoelting, 1993. Release 0.50, Oct 25, 1993 (bugs FindRecursion eliminated) Release 0.51, Feb 08, 1994 (hypergeometric functions) Release 0.52, Mar 07, 1994 (special functions updated) Release 0.53, Mar 15, 1994 (BesselK) Release 0.54, Apr 18, 1994 (Knuth, Parabolic, LegendreQ) Release 0.55, Apr 27, 1994 (Pochhammer) Release 0.60, May 01--Sep 27, 1994 (SDE, FR, Hypergeometric2F3-3F2, REtoDE, SumtoDE, PS with SDE, AbsRules, Zeilberger, Gamma, Collect, ratalgo, integrate, Bloedsinn) Release 0.61, Nov 11, 1994 (FR/Pochhammer/Binomial) Release 0.62, Dec 02, 1994 (SumToHypergeometric/ FunctionToHypergeometric) Release 0.63, Dec 19, 1994 (hypergeometric representations) Release 0.64, Dec 29, 1994 (global->private, and FR) Release 0.65, Jan 05, 1995 (SimplifyGamma, ToGamma, SimplifyCombinatorial) Release 0.66, Jan 10, 1995 (SumToHypergeometric) Release 0.67, Feb 27, 1995 (Limits of orthogonal polynomials) Release 0.68, Sep 18, 1996 (DEOrder not lower than REOrder in Convert) Release 0.70, Oct 17-21, 1996 (again bugs in Convert, SeriesSolution, Taylor, zb_alg V 2.2 embedded, efficient computation of orth. poly., OP[-1,x]->0i, SimpComb, Ratio, HyperTerm) Release 0.99, Nov 20, 1996 (adaptions for Mathematica Version 3) Release 1.00, Dec 6, 1996 (final adaptions in connection with manual article) Release 1.01, May 19, 2004 (FPS alias for PS, holonomicDE alias for SpecialFunctions`Private`simpleDE) Release 1.02, May 25, 2004 (Norm -> norm for Mathematica 5) Release 2.00, Jan 31, 2006 (final adaptations for book: new SimplifyCombinatorial, put new functionalities from book into the SpecialFunctions context: DiskreteStammfunktion, GradSchranke, PrimDispersion, Dispersionsmenge, REtoPol, SumRekursion, WZCertificate) Release 2.01, Feb 21, 2006 Torsten Sprenger: bug fix in HolonomicRE[sum[...]] Release 2.02, Jun 30, 2007 Bernd Bauerhenne: bug fix in SimplifyGamma Release 2.03, Nov 15, 2011 Wolfram Koepf, Henning Seidler: adaption for Mathematica 8 in ProductDE *) (* todo: Tue Nov 21 17:00:36 GMT+0100 2000 SumToHypergeometric nur bei Summen von Reihen, die hypergeometrisch sind ArcSin[x] E^ArcSin[x] Algebraic: DEout ersetzt durch Map[Factor,Collect[... simple[e_]:=FullSimplify[e] (* CHANGE *) ??? SimplifyCombinatorial erneuern Hold-Funktionen fuer Sum etc. wieder aufheben ? done: Cleared three last lines *) (*:Warning: Pochhammer[n,k] is redefined appropriately. SimplifyGamma is redefined appropriately. Series[f,{x,a}] is defined appropriately. HypergeometricPFQ is cleared so that no automatic simplification applies. *) (*:Aims and Limitations: The aim of this package is to provide implementations - SimpleDE[f,x] to find a homogeneous linear differential equation with polynomial coefficients with respect to the variable x for any function built from x^a, Exp[x], Log[x], Sin[x], Cos[x], ArcSin[x], ArcTan[x], ArcSinh[x], ArcTanh[x], Erf[x], ExpIntegralEi[x], CosIntegral[x], SinIntegral[x], AiryAi[x], AiryBi[x], BesselI[x], BesselJ[x], BesselY[x], BesselK[x], LegendreP[n,m,x], LegendreQ[n,m,x], HypergeometricU[a,b,x], Hypergeometric0F1[a,x], Hypergeometric1F1[a,b,x], Hypergeometric2F1[a,b,x], HypergeometricPFQ[plist,qlist,x], JacobiP[n,a,b,x], GegenbauerC[n,a,x], ChebyshevT[n,x], ChebyshevU[n,x], LegendreP[n,x], LaguerreL[n,a,x], and HermiteH[n,x] by addition, multiplication, and the composition with rational functions, and rational powers. Similarly definitions for the following special functions have been added, that can be treated similarly: Bateman[n,x], Hankel1[n,x], Hankel2[n,x], KummerM[a,b,x], KummerU[a,b,x], WhittakerM[a,b,x], WhittakerW[a,b,x], StruveH[n,x], StruveL[n,x], Hypergeometric1F0[a,x], Hypergeometric2F0[a,b,x], Hypergeometric2F3[a,b,c,d,e,x], Hypergeometric3F2[a,b,c,d,e,x], Erfc[n,x], Abramowitz[n,x], NormalIntegral[n,x], ParabolicU[n,x], ParabolicD[n,x], ParabolicV[n,x]. Informations about these functions can be obtained by using Mathematica's ? feature after the package is loaded. - FindRecursion[f,n] to find a homogeneous linear recurrence equation with polynomial coefficients with respect to the variable n for any function built from the above mentioned special functions, n being one of their parameters, and n!, Gamma[n], Pochhammer[n,k], Pochhammer[k,n], Binomial[n,k], Binomial[k,n], by addition, multiplication, and the composition with functions of the type (m n+a), m integer. Further terms of the form Sum[f,{k,a,b}], and Sum[f,k] can be treated, f depending on k, and n, using the Zeilberger algorithm. - Series[f,{x,a}] to find an infinite series representation for f with respect to the variable x, developed at the point a, if f is of rational, explike, or of hypergeometric type. - SumToHypergeometric[f] to find a hypergeometric representation of an expression f involving infinite sums. - FunctionToHypergeometric[f,x] to find a hypergeometric representation of f, where x is assumed to be a variable occuring in the last argument of the hypergeometric function. - GeneratingFunction[a,k,x] to find an explicit form of the generating function Sum[a x^k,{k,0,Infinity}] in terms of variable x of the sequence a of variable k. - ExponentialGeneratingFunction[a,k,x] to find an explicit form of the exponential generating function Sum[a x^k/k!,{k,0,Infinity}] in terms of variable x of the sequence a of variable k. - Convert[Sum[a x^(m k+s),{k,k0,Infinity}],x] to find an explicit form of Sum[a x^(m k+s),{k,k0,Infinity}] - SeriesSolution[DE,y,x,incslist,maxorder] gives the n-th order power series approximation of the holonomic differential equation DE in terms of y[x], using the initial values incslist. - Taylor[f,{x,x0,n}] calculates the nth order power series approximation of f at the point x0 with respect to variable x, by computing a holonomic differential equation of f, if applicable. For holonomic functions this is the fasted known method. *) (* cancel automatic simplification for HypergeometricPFQ *) (* FINAL ??? Unprotect[HypergeometricPFQ] Clear[HypergeometricPFQ] Protect[HypergeometricPFQ] *) (* the following are for Mathematica Version 3 *) Off[SetDelayed::write] Off[TagSetDelayed::write] (* Global function declaration *) Unprotect[Series] Series::usage = "Series[f, {x, x0, n}] generates a power series expansion for f about the point x = x0 to order (x - x0)^n. Series[f, {x, x0, nx}, {y, y0, ny}] successively finds series expansions with respect to y, then x. Series[f, {x, x0}] tries to find a closed form power series representation for f, developed at x0." (* Bessel functions *) Unprotect[BesselI,BesselK,BesselY,BesselJ,D] (* AS 9.26. Seite 120 *) Literal[Derivative[0,1][BesselI]]:= Function[{nn,x}, BesselI[nn-1,x]-nn/x*BesselI[nn,x]] D[BesselI[nn_,x_],x_]:=Derivative[0,1][BesselI][nn, x] D[BesselI[nn_, x_],{x_,k_}]:= D[D[BesselI[nn, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 9.26. Seite 120 *) Literal[Derivative[0,1][BesselK]]:= Function[{nn,x}, -BesselK[nn-1,x]-nn/x*BesselK[nn,x]] D[BesselK[nn_,x_],x_]:=Derivative[0,1][BesselK][nn, x] D[BesselK[nn_, x_],{x_,k_}]:= D[D[BesselK[nn, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 9.1.27 Seite 105 *) Literal[Derivative[0,1][BesselY]]:= Function[{nn,x}, BesselY[-1 + nn, x] - (nn*BesselY[nn, x])/x] D[BesselY[nn_,x_],x_]:=Derivative[0,1][BesselY][nn, x] D[BesselY[nn_, x_],{x_,k_}]:= D[D[BesselY[nn, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 9.1.27 Seite 105 *) Literal[Derivative[0,1][BesselJ]]:= Function[{nn,x}, BesselJ[-1 + nn, x] - (nn*BesselJ[nn, x])/x] D[BesselJ[nn_,x_],x_]:=Derivative[0,1][BesselJ][nn, x] D[BesselJ[nn_, x_],{x_,k_}]:= D[D[BesselJ[nn, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Protect[BesselI,BesselK,BesselY,BesselJ,D] (* Erfc *) (* AS (7.2) *) Unprotect[Erfc,D] Erfc::usage = "Erfc[z] gives the complementary error function erfc(z) == 1 - erf(z). Erfc[n,z] gives the iterated integrals of the complementary error function, see Abramowitz/Stegun, (7.2)." Off[Erfc::argx] Literal[Derivative[0,k_][Erfc]]:= Function[{nn,x},(-1)^k*Erfc[nn-k,x]] D[Erfc[nn_,x_],x_]:= Derivative[0,1][Erfc][nn,x] Erfc[-1,x_]:=2/Sqrt[Pi]*E^(-x^2) Erfc[0,x_]:=(1-Erf[x]) Erfc[1,x_]:=Erfc[-1, x]/2 - x*Erfc[0, x] Protect[Erfc,D] Unprotect[SimplifyGamma] Clear[SimplifyGamma] SimplifyGamma::usage = "SimplifyGamma[expr] simplifies expressions involving rational functions, exponentials, and Gamma function terms according to a recursive application of the rule Gamma[a+1]->a*Gamma[a].\n\n Example: SimplifyGamma[Gamma[n+1]/Gamma[k]-Gamma[n]/Gamma[k+1]] results in\n\n (-1 + k n) Gamma[n]\n -------------------\n Gamma[1 + k]" Unprotect[LaguerreL,ChebyshevT,ChebyshevU,LegendreP,HermiteH,GegenbauerC, JacobiP] (* Limits of orthogonal polynomials *) LegendreP[nn_,-1]:=Cos[nn*Pi] LegendreP[nn_,0]:=Pi^(1/2)/(Gamma[(1 - nn)/2]*Gamma[1 + nn/2]) LegendreP[nn_,1]:=1 ChebyshevT[nn_,-1]:=Cos[nn*Pi] ChebyshevT[nn_,0]:=Cos[(nn*Pi)/2] ChebyshevT[nn_,1]:=1 ChebyshevU[nn_,-1]:=Cos[nn*Pi]*(1 + nn) ChebyshevU[nn_,0]:=Sin[((1 + nn)*Pi)/2] ChebyshevU[nn_,1]:=1 + nn GegenbauerC[nn_,0]:=(2*Pi*Gamma[2*a + nn])/ (2^(2*a)*nn!*Gamma[a]*Gamma[(1 - nn)/2]*Gamma[1/2 + a + nn/2]) GegenbauerC[nn_,1]:= (2*Pi^(1/2)*Gamma[2*a + nn])/(2^(2*a)*nn!*Gamma[a]*Gamma[1/2 + a]) LaguerreL[nn_,a_,0]:=Pochhammer[1 + nn, a]/Gamma[1 + a] HermiteH[nn_,0]:=(2^nn*Pi^(1/2))/Gamma[(1 - nn)/2] (* not yet: N-numeric *) (* iterative appoach, divide and conquer *) ChebyshevT[nn_,xxx_]:=Module[{a,bb,c,dd,g}, g[{a_,bb_,c_,dd_}]:=If[dd-2^c<0,{2*a^2-1,2*a*bb-xxx,c-1,dd}, {2*a*bb-xxx,2*bb^2-1,c-1,dd-2^c}]; If[nn==0,1,If[nn==1,xxx,FixedPoint[g, {1,xxx,Floor[N[Log[2,nn]]],nn},Floor[N[Log[2,nn]]+1]][[1]]]]] /; (NumberQ[xxx] && IntegerQ[nn] && nn>=0) (* to use this for symbolic x, use x /: NumberQ[x]:=True *) (* iterative series computation for symbolic x *) ChebyshevT[nn_,xxx_]:=Module[{kkk,ttmp,ttab}, If[nn<0,Return[0]]; If[nn==0,Return[1]]; If[nn==1,Return[xxx]]; ttmp=(2*xxx)^nn/2; ttab= Table[ttmp=-ttmp/4/kkk*(nn-2*kkk+2)*(nn-2*kkk+1)/xxx^2/(nn-kkk), {kkk,1,Floor[nn/2]}]; (2*x)^nn/2+Apply[Plus,ttab] ] /; IntegerQ[nn] (* this is still recursive approach, divide and conquer *) ChebyshevU[nn_,xxx_]:=(ChebyshevU[nn,xxx]= If[nn==0,1,If[nn==1,2*xxx,If[EvenQ[nn], 2*ChebyshevT[nn/2,xxx]*ChebyshevU[nn/2,xxx]-1, 2*ChebyshevU[(nn-1)/2,xxx]*ChebyshevT[(nn+1)/2,xxx]]]]) /; (NumberQ[x] && IntegerQ[nn] && nn>=0) HermiteHH[nn_,xxx_]:=Module[{kkk,iinit,ttmp,ttab}, If[nn<0,Return[0]]; If[nn==0,Return[1]]; iinit=ttmp=2^nn*xxx^nn; ttab=Table[ttmp=-ttmp/xxx^2*(kkk+(1-nn)/2)*(kkk-nn/2)/(kkk+1), {kkk,0,nn-1}]; iinit+Apply[Plus,ttab] ] /; IntegerQ[nn] LegendreP[nn_,xxx_]:=Module[{kkk,iinit,ttmp,ttab}, If[nn<0,Return[0]]; If[nn==0,Return[1]]; iinit=ttmp=Binomial[2*nn,nn]*xxx^nn/2^nn; ttab=Table[ttmp=ttmp/xxx^2*(kkk+(1-nn)/2)*(kkk-nn/2)/(kkk+1/2-nn)/ (kkk+1),{kkk,0,nn-1}]; iinit+Apply[Plus,ttab] ] /; IntegerQ[nn] LaguerreL[nn_,aalpha_,xxx_]:=Module[{kkk,iinit,ttmp,ttab}, If[nn<0,Return[0]]; If[nn==0,Return[1]]; iinit=ttmp=Binomial[nn+aalpha,nn]; ttab=Table[ttmp=ttmp*xxx*(kkk-nn)/(kkk+aalpha+1)/(kkk+1),{kkk,0,nn-1}]; iinit+Apply[Plus,ttab] ] /; IntegerQ[nn] LaguerreL[nn_,xxx_]:=Module[{kkk,iinit,ttmp,ttab}, If[nn<0,Return[0]]; If[nn==0,Return[1]]; iinit=ttmp=1; ttab=Table[ttmp=ttmp*xxx*(kkk-nn)/(kkk+1)^2,{kkk,0,nn-1}]; iinit+Apply[Plus,ttab] ] /; IntegerQ[nn] GegenbauerC[nn_,aalpha_,xxx_]:=Module[{kkk,iinit,ttmp,ttab,factor}, If[nn<0,Return[0]]; If[nn==0,Return[1]]; If[Simplify[aalpha]===0,Return[GegenbauerC[nn,xxx]]]; iinit=ttmp=2^nn*xxx^nn*Binomial[nn+aalpha-1,nn]; factor=Together[1/xxx^2*(kkk+(1-nn)/2)*(kkk-nn/2)/(kkk+1-aalpha-nn)/ (kkk+1)]; ttab=Table[ttmp=ttmp*factor,{kkk,0,Floor[nn/2]-1}]; iinit+Apply[Plus,ttab] ] /; IntegerQ[nn] Off[GegenbauerC::argrx] GegenbauerC[nn_,xxx_]:=Module[{kkk,iinit,ttmp,ttab}, If[nn<0,Return[0]]; If[nn==0,Return[1]]; iinit=ttmp=2^nn*xxx^nn/nn; ttab=Table[ttmp=ttmp/xxx^2*(kkk+(1-nn)/2)*(kkk-nn/2)/(kkk+1-nn)/(kkk+1), {kkk,0,Floor[nn/2]-1}]; iinit+Apply[Plus,ttab] ] /; IntegerQ[nn] JacobiP[nn_,aalpha_,bbeta_,xxx_]:=Module[{kkk,iinit,ttmp,ttab,factor}, If[nn<0,Return[0]]; If[nn==0,Return[1]]; iinit=ttmp=Binomial[nn+aalpha,nn]; factor=Together[(1-xxx)/2*(kkk-nn)*(kkk+nn+aalpha+bbeta+1)/ (kkk+aalpha+1)/(kkk+1)]; ttab=Table[ttmp=ttmp*factor,{kkk,0,nn-1}]; iinit+Apply[Plus,ttab] ] /; IntegerQ[nn] Protect[ChebyshevT,HermiteH,LegendreP,LaguerreL,GegenbauerC,JacobiP] (* ChebyshevU cannot be protected because of remember option *) (* PAULE-SCHORN PACKAGE loading ... *) (* file: algutil.m *) (* written by Markus Schorn *) BeginPackage["algutil`"] IntLinCoef IntLinQ ExtractNonIntLin ExtractIntLin MyCoefficientList PolyContent NormFactor norm MinusSign MR NC GCDofFactored ShiftFactored FactoredToList (* name convention for Mathematica Version 3 *) PauleSchornSplit ConstElems GP Q NaturalQ FCollect Begin["`private`"] NaturalQ[ n_] := IntegerQ[n] && (n >= 0) (* -------------------------------------------------------------------- *) (* integer-linear stuff *) IntLinCoef[ poly_, var_] := Module[ {exp = Exponent[ Expand[poly], var], coef = Coefficient[ poly, var, 1]}, If[ IntegerQ[ coef] && exp < 2, Return[ coef]]; Print[poly, " is not integer-linear in ", var]; Abort[] ] IntLinQ[ poly_, var_] := (Exponent[ Expand[poly], var] < 2) && IntegerQ[ Coefficient[ poly, var, 1]] IntLinQ[ poly_^i_Integer, var_] := (Exponent[ Expand[poly], var] < 2) && IntegerQ[ Coefficient[ poly, var, 1]] ExtractNonIntLin[ t_Times, var_]:= PauleSchornSplit[ t, (PolynomialQ[#, var] && !IntLinQ[#, var])&] ExtractNonIntLin[ t_^i_Integer, var_] := ExtractNonIntLin[ t, var]^i ExtractNonIntLin[ t_, var_]:= If[ PolynomialQ[ t, var] && !IntLinQ[ t, var], {t, 1}, {1, t}] ExtractIntLin[ t_Times, var_]:= PauleSchornSplit[ t, (PolynomialQ[#, var] && IntLinQ[#, var])&] ExtractIntLin[ t_^i_Integer, var_] := ExtractIntLin[ t, var]^i ExtractIntLin[ t_, var_]:= If[ PolynomialQ[ t, var] && IntLinQ[ t, var], {t, 1}, {1, t}] MyCoefficientList[ term_, var_] := Module[ {result = {}, t = Expand[ term], i}, Return[ Table[ Coefficient[ t, var, i], {i, 0, Max[0, Exponent[ term, var]]}]]; ] (* -------------------------------------------------------------------- *) (* extract rationals to get a list of polys *) PolyContent[ l_List] := Module[ {i, numgcd = 0, denlcm = 1}, Do[ numgcd = PolynomialGCD[ numgcd, Numerator[ l[[i]]]]; denlcm = PolynomialLCM[ denlcm, Denominator[ l[[i]]]], {i, Length[l]}]; Return[ {numgcd / denlcm, Cancel[ denlcm / numgcd l]}]; ] (* -------------------------------------------------------------------- *) (* factorization with normed factors (+-) *) SetAttributes[ NormFactor, Listable] NormFactor[ x_]:= norm[ Factor[ x]]; (* -------------------------------------------------------------------- *) (* Norm factors to having positive sign in front of last variable *) SetAttributes[norm, Listable] norm[ a_Times] := norm /@ a norm[ a_^n_]:= norm[a]^n norm[ sum_Plus]:= If[ sign[ Last[ sum]] == 1, sum, MinusSign neg[ sum]] norm[a_] := If[ sign[a] === 1, a, MinusSign * -a] MinusSign/: Power[MinusSign, i_Integer] := If [ OddQ[i], MinusSign, 1] MR = (MinusSign -> -1) NC = (norm[#] /. MR)& sign[ i_?NumberQ]:= Sign[i] sign[ (i_Integer:1)*_]:= Sign[i] neg[a_] := -a (* ------------------------------------------------------------------- *) (* shift a factored polynomial yielding a factored one *) ShiftFactored[ f_Times, var_, i_] := ShiftFactored[ #, var, i]& /@ f ShiftFactored[ f_^n_Integer, var_, i_] := ShiftFactored[ f, var, i]^n ShiftFactored[ f_, var_, i_] := Expand[ f /. var -> var + i] (* ------------------------------------------------------------------- *) (* convert a factored polynomial to a list of these factors *) FactoredToList[ 1] = {} FactoredToList[ f_Times] := List @@ Flatten[ FactoredToList /@ (List @@ f)] FactoredToList[ f_^n_Integer:1] := Table[ f, {n}] FCollect[ t_, var_] := Module[ {res, const}, const = t /. var -> 0; res = Collect[ t - const, var]; If[ Head[ res] === Plus, res = Factor /@ Select[res, (!FreeQ[#, var])&], res = Factor[res]]; Factor[const] + res ] (* ------------------------------------------------------------------- *) (* PauleSchornSplit a list into two lists *) PauleSchornSplit[list_, test_]:= {Select[list, test], Select[list, (test[#] =!= True) &]} (* ------------------------------------------------------------------- *) (* PauleSchornSplit product into non-constant and constant factor *) ConstElems[ list_, var_] := PauleSchornSplit[ list, FreeQ[#, var]&] (* ------------------------------------------------------------------- *) (* computation of gcd and disjunct factors of two factored polynomials *) flattenExponent[x_^y_:1]:= {x,y} GCDofFactored[x_, y_]:= GCDofNFactored[ norm[x], norm[y]] /. MR GCDofNFactored[ 0, 0]:= {0, 0, 1} GCDofNFactored[ i1_Integer * x_, i2_Integer * y_] := Module[ {gcd = GCD[ i1, i2]}, Return[ GCDofNFactored[ x, y] {i1/gcd, i2/gcd, gcd}] ] GCDofNFactored[ x_, y_]:= Module[ {oldX , oldY, gcd = 1, newX = 1, newY = 1, powX, powY}, oldX = If[ Head[x] === Times, List @@ x, {x}]; oldY = If[ Head[y] === Times, List @@ y, {y}]; (* compare factors *) While[!((oldX === {}) || (oldY ==={})), {firstX, powX} = flattenExponent[ oldX[[1]]]; {firstY, powY} = flattenExponent[ oldY[[1]]]; If[ firstX === firstY, If[ powX < powY, gcd *= firstX ^powX; newY *= firstX ^ (powY-powX), gcd *= firstX ^powY; newX *= firstX ^ (powX-powY) ]; oldX = Rest[oldX]; oldY = Rest[oldY], If[ OrderedQ[{firstX, firstY}], newX *= firstX ^ powX; oldX = Rest[oldX], newY *= firstY ^ powY; oldY = Rest[oldY] ] ] ]; If[ oldX === {}, newY *= Times @@ oldY, newX *= Times @@ oldX]; Return[ {newX, newY, gcd}]; ] (* -------------------------------------------------------------------- *) (* calculate GP canonical-form of a factored rational function *) GP[ rat_, var_]:= Module[ {p = 1, q, r, numlist, denlist, constnum, constden, classnum, classden, class, num, den, coef, div, classPoly, nln, nld, nlq, nlp=1, nlr, poss, nposs, d, res, pos, min}, (* check linearity of factors *) {nlq, num} = ExtractNonIntLin[ Numerator[ rat], var]; {nlr, den} = ExtractNonIntLin[ Denominator[ rat], var]; If[ nlq =!= 1 && nlr =!= 1, Print[ "Gosper`s condition cannot be checked without resultants,"]; Run["sleep 1"]; Print[ "therefore I use resultants."]; nln = FactoredToList[ nlq]; nld = FactoredToList[ nlr]; nlq = nlr = 1; While[ nld =!= {}, If[ nln === {}, nlr *= Times @@ nld; nld = {}, {poss, nposs} = PauleSchornSplit[ nln, (Exponent[#, var] === Exponent[First[nld], var])&]; res = Resultant[ First[nld] /. var -> var+d, #, var] & /@ poss; res = FactoredToList[Factor[#]]& /@ res; res = Map[ Select[ #, (IntLinQ[#, d] && ! FreeQ[#, d])&]&, res, {1}]; res = Map[(-# /. d -> 0 / Coefficient[#, d, 1])&, res, {2}]; res = Map[ Select[ #, NaturalQ]&, res, {1}]; res = Min /@ res; min = Min[ Select[ Flatten[res], NaturalQ]]; If[ min < Infinity, pos = Position[ res, min, {1}]; nlp *= Product[ ShiftFactored[ First[nld], var, i-1], {i, min}]; poss = Drop[ poss, pos[[1]]], nlr *= First[ nld] ]; nld = Rest[nld]; nln = Join[ poss, nposs]; ]; ]; nlq *= Times @@ nln; ]; (* extract the constant parts *) {constnum, numlist} = ConstElems[ FactoredToList[ norm[num]], var]; {constden, denlist} = ConstElems[ FactoredToList[ norm[den]], var]; q = Times @@ constnum; r = Times @@ constden; div = Module[ {coefficient}, coefficient = Coefficient[ #, var]; {coefficient, Cancel[ #/coefficient]}]&; numlist = div /@ numlist; denlist = div /@ denlist; (* treat all classes *) While[ denlist =!= {} && numlist =!= {}, (* select a class *) coef = First[First[denlist]]; class = Last[First[denlist]]; classPoly = Cancel[ class coef]; {classnum, numlist} = PauleSchornSplit[ numlist, (coef === First[#] && IntegerQ[ Together[ Last[#] - class]])&]; {classden, denlist} = PauleSchornSplit[ denlist, (coef === First[#] && IntegerQ[ Together[ Last[#] - class]])&]; classnum = Sort[ Together[ Last[#] - class]& /@ classnum]; classden = Sort[ Together[ Last[#] - class]& /@ classden]; (* fullfill gospers cond *) While[ classden =!= {} && classnum =!= {}, If[ First[ classden] > First[ classnum], q *= ShiftFactored[ classPoly, var, First[ classnum]]; classnum = Rest[ classnum], p *= Product[ ShiftFactored[ classPoly, var, i], {i, First[ classden], First[ classnum] - 1} ]; classden = Rest[ classden]; classnum = Rest[ classnum] ] ]; q *= Apply[Times, ShiftFactored[ classPoly, var, #]& /@ classnum]; r *= Apply[Times, ShiftFactored[ classPoly, var, #]& /@ classden]; ]; q *= Apply[Times, Cancel[ #[[1]] * #[[2]]]& /@ numlist]; r *= Apply[Times, Cancel[ #[[1]] * #[[2]]]& /@ denlist]; Return[{nlp p, nlq q, ShiftFactored[ nlr r, var, -1]} /. MR] ] (* -------------------------------------------------------------------- *) (* calculate the shiftquotient *) Q[ free_, var_] := 1 /; FreeQ[ free, var] Q[ hyp_Times, var_] := Q[ #, var]& /@ hyp; Q[ hyp_^i_Integer, var_] := Q[ hyp, var]^i Q[ arg_^exp_, var_]:= arg^IntLinCoef[ exp, var] /; FreeQ[ arg, var] Q[ f_!, var_]:= Module[ {coef = IntLinCoef[ f, var]}, Return[ Which[ coef === 0, 1, coef > 0, Product[ Factor[f+i], {i, coef}], coef < 0, 1 / Product[ Factor[f-i+1], {i, -coef}] ] ] ] Q[ Binomial[n_, k_], var_]:= Q[ n!, var] / Q[ (n-k)!, var] / Q[ k!, var] Q[ rat_, var_]:= If[ ! PolynomialQ[ Numerator[rat], {var}] || ! PolynomialQ[ Denominator[ rat], {var}], Print[ "The factor ", rat, " cannot be handled!"]; Abort[], ShiftFactored[ rat, var, 1] / rat] End[] EndPackage[] (* file: zeilutil.m *) (* written by Peter Paule and Markus Schorn *) BeginPackage["zeilutil`", {"algutil`"}] PolyDeg ZeilbergerSummand CorrectingTerm Conditions SolveGosperEquation Psi PsiForFactored Begin["`private`"] (* -------------------------------------- *) (* Degree of a polynomial giving -1 for 0 *) PolyDeg[0, _] := -1 PolyDeg[expr_, var_] := Exponent[expr, var] (* ------------------------------------------------------------------- *) (* compute the impact of an unknown operator to a hypergeometric term *) ZeilbergerSummand[f_, ord_, var_, symbol_]:= Module[ {shqt, q, num, den, oldden, b0, i, r1, r2, gcd}, shqt = norm[ Q[ f, var]]; q = 1; oldden = 1; b0 = {symbol[0]}; For[ i = 1, i <= ord, i++, q = NC[ q * ShiftFactored[ shqt, var, i-1]]; den = Denominator[q]; num = Numerator[q]; (* calculate lcm of denomis *) {r1, r2, gcd} = GCDofFactored[ oldden, den]; oldden *= r2; b0 = Append[ r2 b0, r1 num symbol[i]] /. MR; ]; Return[{Plus @@ b0, oldden /. MR}]; ] (* ------------------------------------------------------------ *) (* compute the correction terms in dependence of NonRat(border) *) CorrectingTerm[ _, 0, _, _, _, _, _, _] = 0 CorrectingTerm[ ord_, coef_, bound_, b0_, rule_, q_, var_, c_]:= Module[ {result = 0, index, rat=1, pm = 0, b00 = b0, nq = norm[q]}, If[ bound > 0, If[ coef > 0, Do[ b00 = norm[ Factor[ b00 /. c[index] -> 0]]; Do[ rat *= ShiftFactored[ nq, var, pm++]; b00 = ShiftFactored[ b00, var, 1]; result += rat (b00 /. rule), {coef}], {index, 0, ord - 1}], Do[ b00 = norm[ Factor[ b00 /. c[index] -> 0]]; Do[ result += rat (b00 /. rule); rat /= ShiftFactored[ nq, var, --pm]; b00 = ShiftFactored[ b00, var, -1], {-coef}], {index, 0, ord - 1}] ], If[ coef > 0, Do[ b00 = norm[ Factor[ b00 /. c[index] -> 0]]; Do[ result += rat (b00 /. rule); rat *= ShiftFactored[ nq, var, pm++]; b00 = ShiftFactored[ b00, var, 1], {coef}], {index, 0, ord - 1}], Do[ b00 = norm[ Factor[ b00 /. c[index] -> 0]]; Do[ rat /= ShiftFactored[ nq, var, --pm]; b00 = ShiftFactored[ b00, var, -1]; result += rat (b00 /. rule), {-coef}], {index, 0, ord - 1}] ] ]; Return[ result /. MR] ] (* -------------------------------------------------- *) (* evaluable-form of Factorial-expressions *) divide[pol_, var_]:= Module[ {coef}, coef = Together[ Coefficient[ pol, Variables[pol][[1]]]]; If[ coef === 0, coef = 1]; {coef, Together[ pol / coef]} ] Psi[ f_, var_]:= Module[ {den, rest}, den = Denominator[ f]; {den, rest} = ExtractIntLin[ den, var]; Psi[ den, Numerator[f]/ rest, var, 0] ] Psi[ den_, f_, var_, v_] := PsiForFactored[ Factor[den], Factor[f], var, v] /. MR PsiForFactored[ den_, f_, var_, v_]:= Module[ {fn, fd, den1, nc, fac, bin, facmod, binmod, nonlin, const, d, c, nd, newden = 1, newnum = 1, dif, sel, i, j, k}, fn = NC[ Numerator[f]/den]; fd = Denominator[f]; den1 = Denominator[ fn]; fn = Numerator[ fn]; fn = FactoredToList[ fn]; fd = FactoredToList[ fd]; {fac, fd} = PauleSchornSplit[ fd, MatchQ[ #, x_!]&]; {bin, fn} = PauleSchornSplit[ fn, MatchQ[ #, Binomial[x_, y_]]&]; facmod = divide[ First[#], var]& /@ fac; binmod = {divide[ First[#] - Last[#], var], divide[ Last[#], var]}& /@ bin; If[ v > 0, Print["fn = ", fn]]; If[ v > 0, Print["fd = ", fd]]; If[ v > 0, Print["fac = ", fac]]; If[ v > 0, Print["bin = ", bin]]; {nonlin, den1} = ExtractNonIntLin[ den1, var]; {const, den1} = ConstElems[ FactoredToList[ den1], var]; If[ v > 0, Print["nonlin = ", nonlin]; Print["const = ", const]; Print["den1 = ", den1]]; While[ den1 =!= {}, d = First[ den1]; den1 = Rest[ den1]; (* R1 *) nc = NC[ newnum / d]; If[ Denominator[nc] === 1, newnum = nc; If[ v > 0, Print["R1 (", d,"): newnum = ", newnum]], (* R2 *) {c, nd} = divide[ d, var]; dif = Together[ #[[1]](nd - #[[2]]) - 1]& /@ facmod; sel = Position[ dif, _?NaturalQ, {1}]; If[ sel =!= {}, sel = sel[[1,1]]; j = facmod[[sel, 1]] / c; i = dif[[sel]]; fac[[sel,1]] += i + 1; newnum *= j Product[ Factor[j c nd - k], {k, i}]; facmod[[sel]] = divide[fac[[sel]], var]; If[ v > 0, Print["R2 (", d,"):"]; Print[" newnum = ", newnum]; Print[" fac = ", fac]], (* R7 *) dif = Together[ #[[2,1]](nd - #[[2,2]]) - 1]& /@ binmod; sel = Position[ dif, _?NaturalQ, {1}]; If[ sel =!= {}, sel = sel[[1,1]]; j = binmod[[sel, 2, 1]] / c; i = dif[[sel]]; newnum *= j Product[ Factor[j c nd - k], {k, i}]; newden *= Product[ Factor[ bin[[sel, 1]] + k], {k, i+1}]; bin[[sel,1]] += i+1; bin[[sel,2]] += i+1; binmod[[sel,2]] = divide[ bin[[sel,2]], var]; If[ v > 0, Print["R7 (", d,"):"]; Print[" newnum = ", newnum]; Print[" newden = ", newden]; Print[" bin = ", bin]], (* R8 *) dif = Together[ #[[1,1]](nd - #[[1,2]]) - 1]& /@ binmod; sel = Position[ dif, _?NaturalQ, {1}]; If[ sel =!= {}, sel = sel[[1,1]]; j = binmod[[sel, 1, 1]] / c; i = dif[[sel]]; newnum *= j Product[ Factor[j c nd - k], {k, i}]; newden *= Product[ Factor[ bin[[sel, 1]] + k], {k, i+1}]; bin[[sel,1]] += i+1; binmod[[sel,1]] = divide[ bin[[sel,1]] - bin[[sel, 2]], var]; If[ v > 0, Print["R8 (", d,"):" ]; Print[" newnum = ", newnum]; Print[" newden = ", newden]; Print[" bin = ", bin]], (* no rule *) newden *= d; If[ v > 0, Print["No rule for ", d]] ]]]]]; Return[ newnum / newden / nonlin / (Times @@ const) (Times @@ fn) / (Times @@ fd) (Times @@ bin) / (Times @@ fac) ] ] (* -------------------------------------------- *) (* Binomial entries are supposed to be positive *) Conditions[ f_, l_, u_, ord_, x1_, x2_] := Module[ {bins, nc, result, nat, cnat, ci, i, j, iv, res, z}, bins = Union[ FactoredToList[ Numerator[f]], FactoredToList[ Denominator[f]]]; bins = Select[ bins, MatchQ[#, Binomial[x_,y_]]&]; nc = Union[ Flatten[ Intersection[ Variables[#[[1]]], Variables[#[[2]]]]& /@ bins]]; nc = Union[ nc, Variables[l], Variables[u], {x1}]; bins = Union[ Expand[First[#]]& /@ bins]; bins = AppendTo[ bins, Expand[u-l]]; bins = Select[ bins, SameQ[ Complement[ Variables[#], nc], {}]&]; result = If[ IntLinCoef[ #, x1] > 0, ((# /. x1 -> l) + ord * Min[ 0, IntLinCoef[l, x2] IntLinCoef[#, x1] + IntLinCoef[#, x2]] )& /@ bins, ((# /. x1 -> u) + ord * Min[ 0, IntLinCoef[u, x2] IntLinCoef[#, x1] + IntLinCoef[#, x2]] )& /@ bins]; nat = Expand[u-l]; nat += Min[ 0, IntLinCoef[ nat, x2]]; vl = Prepend[ Variables[ nat], x2]; Do[ If[ IntLinQ[ nat, vl[[i]]], iv = vl[[i]]; cnat = IntLinCoef[ nat, iv]], {i, Length[vl]}]; If[ cnat =!= 0, Do[ ci = IntLinCoef[ result[[i]], iv]; If[ i =!= j && ci cnat > 0, res = Expand[ result[[i]] - ci/cnat nat]; If[ res >= 0, result[[i]] = res]], {i, Length[ result]}] ]; Do[ z = Expand[ result[[j]]]; vl = Prepend[ Variables[ z], x2]; Do[ If[ IntLinQ[ z, vl[[i]]], iv = vl[[i]]; cnat = IntLinCoef[ z, iv]], {i, Length[vl]}]; If[ cnat =!= 0, Do[ ci = IntLinCoef[ result[[i]], iv]; If[ i =!= j && ci =!=0, If[ NaturalQ[ cnat/ci], res = Expand[ result[[i]] - ci/cnat z]; If[ NumberQ[res] && (! IntegerQ[res] || NaturalQ[res]), result[[i]] = res ]; ]; ], {i, Length[ result]}] ], {j, Length[result]}]; result = Select[ Union[ Factor[result]], (!NumberQ[#] || NaturalQ[-#-1])&]; Return[{nat,result}]; ] (* --------------------------------------------------------------- *) (* find the degree-bound for solutions of the gosper equation *) findDegBound[ p_, q_, r_, var_, v_]:= Module[ { pDeg, qDeg, rDeg, qrneg, qrnegDeg, k0, set}, {pDeg, qDeg, rDeg} = PolyDeg[ #, var]& /@ {p, q, r}; If[ v > 0, Print[ "{pDeg, qDeg, rDeg}: ", {pDeg, qDeg, rDeg} ]]; If[ rDeg > qDeg, Return[ pDeg - rDeg]]; If[ rDeg < qDeg, Return[ pDeg - qDeg]]; qLcf = Coefficient[ q, var, qDeg]; If[ v > 0, Print[ "qLcf: ", qLcf ]]; If[ Expand[ Coefficient[ r, var, rDeg] - qLcf] =!= 0, Return[ pDeg - qDeg]]; qrneg = Expand[q - r]; qrnegDeg = PolyDeg[ qrneg, var]; If[ v > 0, Print[ "qrnegDeg: ", qrnegDeg ]]; set = {pDeg - qDeg + 1}; If[ qrnegDeg <= pDeg, AppendTo[ set, 0]]; If[ qDeg === qrnegDeg + 1, k0 = Cancel[ -Coefficient[ qrneg, var, qrnegDeg] / qLcf]; If[ v > 0, Print[ "k0: ", k0 ]]; If[ IntegerQ[ k0], AppendTo[ set, k0]]]; Max[set] ] (* ---------------------------------------------------- *) (* solving gospers equation with additional variables *) SolveGosperEquation[ p_, q_, r_, var_, varlist_, systembreaker_, files_, v_] := Module[ {varmany, degbound, i, coefs, len, sols}, varmany = Length[ varlist]; degbound = findDegBound[ p, q, r, var, v-1]; If[ v > 0, Print["degbound = ", degbound]]; If[ degbound < 0, Return[ {}]]; (* set up equations *) coefs = Join[ (Coefficient[ p, #, 1]& /@ varlist), Table[ - q (var + 1)^i + r var^i, {i, 0, degbound}]]; coefs = MyCoefficientList[ #, var]& /@ coefs; len = Max @@ (Length /@ coefs); coefs = Reverse[ Join[ #, Table[ 0, {len - Length[#]}]]]& /@ coefs; coefs = Transpose[ coefs]; coefs = Select[ coefs, (!SameQ[ #, Table[ 0, {varmany + degbound + 1}]])&]; (* solve equations *) If[ v > 0, Print[ Dimensions[ coefs], {"Equations", "Variables"}]]; If[ files, Put[ coefs, "~/.mat"]]; sols = systembreaker[ coefs]; If[ v > 0, Print["sols = ", InputForm[sols]]]; sols = Select[ sols, (Take[#, varmany] =!= Table[0, {varmany}])&]; (* simplify solution vectors *) sols = PolyContent[ #][[2]]& /@ sols; sols = Prepend[ Take[ #, varmany], Sum[ #[[varmany+i+1]] var^i, {i, 0, degbound}]]& /@ sols; Return[ sols] ] (*-----------------------------------------------------------------------*) End[] EndPackage[] (* file: linsolve.m *) (* written by Markus Schorn *) BeginPackage["linsolve`"] NoSolutionByLinSolve LinSolve Begin["`privat`"] LinSolve [A_List, b_List, NullSpaceAlgorithm_]:= Module[ {nsp}, nsp = NullSpaceAlgorithm[ Transpose[ Append[ Transpose[A], -b]]]; nsp = Select[ nsp, (Last[#] =!= 0)&]; If[ nsp === {}, Return[ NoSolutionByLinSolve]]; Return[ Cancel[ Drop[First[nsp], -1] / Last[First[nsp]]]] ] End[] EndPackage[] (* file: enullspace.m *) (* written by Erhard Aichinger *) BeginPackage["enullspace`", {"linsolve`"}] ENullspace ELinSolve Begin["`private`"] ELinSolve [A_List, b_List]:= linsolve`LinSolve[A,b,ENullspace] ENullspace [mat_List] := Module[{res, perm, lines, columns, y, dim, M}, {lines, columns} = Dimensions[mat]; {M , perm} = MakeTriangularMatrix[lines, columns, mat]; {y, dim} = BackwardSubstitute[lines, columns, M]; res = SettleColumnExchanges[y, dim, columns, perm]; Return[res] ] MakeTriangularMatrix [lines_, columns_, mat_] := Module[{perm, T=mat, ended=False, i=1, i1, j1, iPivot, jPivot, Mult}, perm = Range[columns]; While[i <= lines && i <= columns && ! ended, {iPivot, jPivot} = SearchPivot[T, i, lines, columns]; If[iPivot === 0, ended = True, T = ExchangeLines[i, iPivot, T, lines]; {T, perm} = ExchangeColumns[i, jPivot, T, lines, perm]; i1 = i + 1; While[i1 <= lines, If[T[[i1, i]] =!= 0, Mult = Cancel[T [[ i1, i ]] / T[[i,i]] ]; T[[i1, i]] = 0; j1 = i + 1; While[j1 <= columns, T[[ i1, j1 ]] = Together[T[[i1, j1]] - Mult * T[[i, j1]]]; j1++ ] (* for j1 *) ]; (* if != 0 *) i1++ ] (* for i1 *) ]; (* if iPivot == 0 *) i++; ]; (* for i *) Return[{T, perm}] ] BackwardSubstitute [lines_, columns_, T_] := Module[{ last, dim, x, i, k, l, sum }, last = Min[lines, columns]; While[last > 0 && T [[last, last]] === 0, last--]; dim = columns - last; x = Table [ Table [ 0, {columns} ], {dim} ]; (* BUG !!!! columns -> dim *) i = 1; While[last + i <= columns, x[[i, last + i]] = 1; k = last; While[k >= 1, sum = 0; l = k + 1; While[l <= last, sum = Together[ sum + T[[k,l]] * x[[i,l]]]; l++ ]; (* for l *) sum = Together[sum + T[[k, last + i]]]; sum = -sum; x [[i, k]] = Cancel[sum / T[[k,k]]]; k-- ]; (* for k *) i++ ]; (* for i *) Return[{x, dim}] ] SettleColumnExchanges [y_, dim_, columns_, perm_] := Module[{x, i, j}, x = Table [ Table [ 0, {columns} ], {dim} ]; Do[ Do[ x[[i, perm [[j]]]] = y[[i, j]], {j, columns} ], {i, dim} ]; Return[x] ] SearchPivot [T_, i_, lines_, columns_] := Module[{currentIPivot, currentJPivot, currentSize, i1, j1, sizeI1J1}, currentIPivot = 0; currentSize = Infinity; i1 = i; While[i1 <= lines, j1 = i; While[j1 <= columns, If[T[[i1, j1]] =!= 0, sizeI1J1 = PivotSize[T[[i1, j1]] ]; If[sizeI1J1 < currentSize, currentSize = sizeI1J1; currentIPivot = i1; currentJPivot = j1 ] ]; j1++ ]; i1++ ]; Return[{currentIPivot, currentJPivot}] ] PivotSize [p_] := LeafCount [p] TotalLength [p_, bound_] := Module[{l, i, sum}, l = Length[p]; If[l === 0, Return[1], sum = 0; i = 1; While[i <= l && sum < bound, sum = sum + TotalLength[p[[i]], bound - sum]; i++ ]; Return[sum] ] ] ExchangeLines [i1_, i2_, M_, lines_] := Module[{i}, Return[Table[If[i === i1, M[[i2]], If[i === i2, M[[i1]], M[[i]] ] ],{i,lines} ] ] ] ExchangeColumns [j1_, j2_, M_, lines_, perm_] := Module[{i, newPerm, newM}, newPerm = perm; newPerm[[j1]] = perm[[j2]]; newPerm[[j2]] = perm[[j1]]; newM = M; i = 1; While[i <= lines, newM[[i, j1]] = M[[i, j2]]; newM[[i, j2]] = M[[i, j1]]; i++ ]; Return[{newM, newPerm}] ] End[] EndPackage[] (* file: zb_alg.m *) (* written by: Peter Paule and Markus Schorn *) (* slightly modified by Wolfram Koepf for the use in SpecialFunctions *) (* an original copy can be obtained by anonymous ftp from ftp.risc.uni-linz.ac.at *) BeginPackage["fastZeil`",{"algutil`","zeilutil`", "enullspace`"}] Zb::usage = "Zb[ function, range, n, order], uses Zeilberger's algorithm to find a recurrence relation of given order in n for the sum of the function over the range. \n\nZb[ function, k, recvar, order], uses Zeilberger's algorithm to find a recurrence relation of given order in n for the function. This recurrence is -- up to a telescoping part -- free of k." Gosper::usage = "Gosper[ function, range], uses Gosper's algorithm to find a hypergeometric closed form for the sum of the function over the range, \n\nGosper[ function, k], computes the hypergeometric forward anti-difference of function in k, if it exists, \n\nGosper[ function, range, degree] or \nGosper[ function, k, degree] use Gosper's algorithm with an undetermined polynomial of given degree in k multiplied to the function." Systembreaker::usage = "Systembreaker contains the method used to find the nullspace of a matrix during the execution of either Zb or Gosper. For instance, Systembreaker = NullSpace uses the built in algorithm." Prove::usage = "Prove produces a short certificate for the last result obtained by using either Zb or Gosper and appends it to the file named `proof', \n\nProve[filename] appends the certificate to the specified file." SUM::usage = "SUM is an abbreviation for the sum of the function over the range used in the output. Both the function and the range is defined by your input to the algorithm. Reveal its definition by Show[SUM]!" F::usage = "F is an abbreviation for your inputted function, used in the output. Reveal its definition by Show[F]!" R::usage = "R is an abbreviation for the rational function that yields the anti-difference of F and is used in the output. Reveal its definition by Show[R]!" Unprotect[Show] Show::usage = "Show[abbreviation] reveals the definition for the abbreviation. Abbreviations that may be used are SUM, F and R." Delta::usage ="Delta[ k, function] denotes the forward difference operator in k applied to the function." pl Begin["`private`"] LINE = 0 (* --------------------------------------------------------------------- *) (* Zeilberger's algorithm for natural bounds *) Zb[ _, _Symbol, _Symbol, order_] := "Use Gosper's Algorithm!" /; order <= 0 Zb[ f_, x1_Symbol, x2_Symbol, order_Integer, pl -> v_] := Zb[f, {x1, -Infinity, Infinity}, x2, order, pl -> v] (* --------------------------------------------------------------------- *) (* Gosper's algorithm using the Zeilberger implementation *) Gosper[ f_, {x1_Symbol, bl_, bu_}, pl -> p_] := Zb[ f, {x1, bl, bu}, x2, 0, pl -> p] Gosper[ f_, {x1_Symbol, bl_, bu_}, deg_Integer, pl -> p_] := Zb[ f, {x1, bl, bu}, x2, -deg, pl -> p] Gosper[ f_, x1_Symbol, pl -> p_] := Gosper[ f, {x1, Delta, Delta}, pl -> p] Gosper[ f_, x1_Symbol, deg_Integer, pl -> p_] := Gosper[ f, {x1, Delta, Delta}, deg, pl -> p] Gosper[ a_, b_] := Gosper[a,b,pl->0] Gosper[ a_, b_, c_] := Gosper[a,b,c,pl->0] (* --------------------------------------------------------------------- *) (* the common interface bu Zeilberger/Gosper *) f/: Format[f] := "f"; y/: Format[y] := "y"; Zb[ a_,b_,c_,d_] := Zb[a,b,c,d,pl -> 0] Zb[ f_, {x1_Symbol, bl_, bu_}, x2_Symbol, ord_Integer, pl -> v_]:= Module[ { c, i, j, f1, f2, varlist, b0, b1, nonlin, shqt, p, q, r, sollist, outlist, sol, solrule, cl, cu, cbl, cbu, gratl, gratu, g, gu, gl, rhs, bounds }, c/: Format[c] := "c"; Clear[ Show, ANTI]; LINE = $Line; (* presetting dependent on Gosper/Zb *) f1 = Factor[ f]; Show[F] = f1; varlist = Array[ c, Abs[ord] + 1, 0]; If[ ord <= 0, (* this is the Gosper call *) b0 = Sum[ c[i] x1^i, {i, 0, -ord}]; b1 = 1, (* else *) (* here we run Zeilberger's *) {b0, b1} = ZeilbergerSummand[ f1, ord, x2, c]; ]; If[ v > 0, Print["b0 = ", b0]]; If[ v > 0, Print["b1 = ", b1]]; (* work around non-linear polynomials *) {nonlin, f2} = ExtractNonIntLin[ NC[f1/b1], x1]; If[ v > 0, Print["nonlin = ", nonlin]]; If[ v > 0, Print["f2 = ", f2]]; (* calculate GP-form of shift-quotient *) shqt = NC[ Q[ f2, x1]]; {p,q,r} = GP[ shqt, x1] * {nonlin, 1, 1}; shqt *= ShiftFactored[ nonlin, x1, 1] / nonlin; If[ v > 0, Print["Q f/b1 = ", shqt]; Print["Gosper's equation:"]; Print[ b0 p == q y[x1 + 1] - r y[x1], "."] ]; sollist = SolveGosperEquation[ b0 p, q, r, x1, varlist, Systembreaker, Files, v-1]; If[ v > 0, Print["Solutions for y and the c's:"]; Print[ sollist]]; (* no solution *) If[ sollist === {}, Return[ {}]]; (* some solutions *) outlist = {}; Do[ (* initialization *) sol = sollist[[i]]; solrule = Thread[ varlist -> Drop[ sol, 1]]; (* compute rational function for certificate *) gratl = r First[ sol] / p; gratu = q ShiftFactored[ First[ sol], x1, 1] / p; Show[R] = gratl/b1; If[ v > 0, Print["{gratl, gratu} =", {gratl, gratu}]]; If[ ord > 0 && Abs[ bl] === Infinity && bu === Infinity, rhs = 0; bounds = False, (* else *) bounds = True; (* rat. representation of correcting terms *) If[ ord <= 0, cl = cu = 0, (* else *) If[ v > 0, Print["Calculating correcting terms"]]; {cbl, cbu} = If[ Abs[#] === Infinity, 0, IntLinCoef[ #, x2]]& /@ {bl, bu}; cl = Sign[cbl] CorrectingTerm[ ord, cbl, -1, b0, solrule, shqt, x1, c]; cu = Sign[cbu] CorrectingTerm[ ord, cbu, 1, b0, solrule, shqt, x1, c]; If[ v > 0, Print["{cl, cu} =", {cl, cu}]]; ]; (* corrected rational factors *) cratl = If[ Abs[bl] === Infinity, 0, Factor[ Together[ gratl + cl]]]; cratu = If[ Abs[bu] === Infinity, 0, Factor[ Together[ gratu + cu]]]; If[ v > 0, Print["{cratl, cratu} =", {cratl, cratu}]]; (* make Stammfunction evaluable at bounds *) g = PsiForFactored[ b1, f1, x1, v-1]; If[ v > 0, Print["f1/b1 = ", g]]; gl = PsiForFactored[ Denominator[ cratl], g Numerator[ cratl], x1, v-1]; gu = PsiForFactored[ Denominator[ cratu], g Numerator[ cratu], x1, v-1]; If[ v > 0, Print["{gl, gu} =", {gl, gu}]]; ]; If[ ord > 0, (* Zeilberger-Output *) If[ bounds, ProofType = Sumrecursion; RHS = Factor[gu /. x1 -> bu] - Factor[ gl /. x1 -> bl]; LHS = Table[ SUM[x2 + i], {i, 0, ord}] . Factor[ Drop[ sol, 1]] /. MR; ANTI = Show[R] F; Show[SUM] = Sum[ Show[F], {x1, bl, bu}], ProofType = Recursion; RHS = 0; LHS = Table[ SUM[x2 + i], {i, 0, ord}] . Factor[ Drop[ sol, 1]] /. MR; ]; AppendTo[ outlist, LHS == RHS], (* else *) (* Gosper-Output *) If[ bl === Delta, ProofType = Divideout; If[ ord === 0, RHS = Delta[ x1, gl/sol[[2]]]; LHS = f1, RHS = Delta[ x1, gl]; LHS = Factor[ b0 /. solrule /. MR] f1; ]; AppendTo[ outlist, LHS == RHS], ProofType = Sumevaluation; If[ ord === 0, RHS = Factor[gu/tag /. x1 -> bu] - Factor[ gl/tag /. x1 -> bl] /. tag -> sol[[2]]; LHS = Sum[f1, {x1, bl, bu}]; ANTI = gl/sol[[2]], RHS = Factor[gu /. x1 -> bu] - Factor[ gl /. x1 -> bl]; LHS = Sum[Factor[ b0 /. solrule /. MR] f1, {x1, bl, bu}]; ANTI = gl; ]; AppendTo[ outlist, LHS == RHS] ]; ]; ,{i, Length[ sollist]}]; If[ Abs[bl] =!= Infinity && Abs[bu] =!= Infinity && bl =!= Delta, cond = Conditions[ f1, bl, bu, ord, x1, x2]; If[ cond[[2]] === {}, CondText = "If `" <> ToString[cond[[1]]] <> "' is a natural number, then:", If[ Length[ cond[[2]]] === 1, CondText = "If `" <> ToString[cond[[1]]] <> "' is a natural number" <> "\nand `" <> ToString[cond[[2,1]]] <> "' is no negative integer, then:", CondText = "If `" <> ToString[cond[[1]]] <> "' is a natural number and none of \n" <> ToString[ cond[[2]]] <> "\nis a negative integer, then:" ] ]; Print[ CondText]; ]; If[ bl =!= Delta && outlist =!= {}, OK = True]; Return[ outlist]; ] Clear[ ProofType]; Prove := Prove1[ ProofType, "proof"] Prove[ filename_] := Prove1[ ProofType, filename] Prove1[ Divideout, file_] := Module[ {handle, w, skip}, handle = OpenAppend[ file, FormatType -> OutputForm]; w[ x_] := Write[ handle, x]; skip[ n_]:= Do[ Write[ file], {n}]; Print["Creating proof for Out[", LINE, "] in file '", file,"'."]; w["Computer Theorem:"]; w[ SequenceForm["Let ", Delta[RHS[[1]], "."], " denote the forward difference operator in ", RHS[[1]], " then"]]; w[LHS == RHS]; skip[1]; w["Proof:"]; w["By dividing the right-hand side by the left-hand one,"]; w["we get a rational function that simplifies to 1."]; w["------------------------------------------------------------------------"]; Close[ handle]; ] Prove1[ Sumevaluation, file_] := Module[ {handle, w, skip}, handle = OpenAppend[ file, FormatType -> OutputForm]; w[ x_] := Write[ handle, x]; skip[ n_]:= Do[ Write[ file], {n}]; Print["Creating proof for Out[", LINE, "] in file '", file,"'."]; w["Computer Theorem:"]; w[CondText]; w[LHS == RHS]; skip[2]; w["Proof:"]; w[ SequenceForm["Let ", Delta[ANTI[[1]], "."], " denote the forward difference operator in ", RHS[[1]], " then"]]; w["the Theorem follows from summing the equation"]; skip[1]; w[ LHS[[1]] == Delta[ LHS[[2,1]], ANTI]]; skip[1]; w[ "over the range " <> ToString[LHS[[2]]] <> "."]; skip[1]; w[ "The equation is routinely verifyable by dividing the right-hand side by"]; w[ "the left-hand one and simplifying the resulting rational function to 1."]; w["------------------------------------------------------------------------"]; Close[ handle]; ] Prove1[ Recursion, file_] := Module[ {handle, w, skip}, handle = OpenAppend[ file, FormatType -> OutputForm]; w[ x_] := Write[ handle, x]; skip[ n_]:= Do[ Write[ file], {n}]; Print["Creating proof for Out[", LINE, "] in file '", file,"'."]; w["Computer Theorem:"]; w[ SequenceForm["Let ", Delta[RHS[[1]], "."], " denote the forward difference operator in ", RHS[[1]], " let"]]; w[SequenceForm[F, " := ", Show[F], " and"]]; w[SequenceForm[R, " := ", Show[R], ", then"]]; skip[1]; w[SequenceForm[LHS == RHS,"."]]; skip[2]; w["Proof:"]; w["By dividing both sides of the equation by F, we find a rational equation"]; w["that can be verified routinely."]; w["------------------------------------------------------------------------"]; Close[ handle]; ] Prove1[ Sumrecursion, file_] := Module[ {handle, w, skip, n, var, iterator, recvar, a, b, c, d}, handle = OpenAppend[ file, FormatType -> OutputForm]; w[ x_] := Write[ handle, x]; skip[ n_]:= Do[ Write[ file], {n}]; Print["Creating proof for Out[", LINE, "] in file '", file,"'."]; iterator = Part[ Show[SUM], 2]; var = First[ iterator]; recvar = LHS /. (a_ SUM[b_Symbol + c_] + d_:0) -> b; w["Computer Theorem:"]; w[ SequenceForm["Let ",F, " := ", Show[F], " and ", SUM, " := ", Sum[F, Evaluate[ iterator]], ", then:"]]; w[ CondText]; w[ SequenceForm[LHS == RHS, "."]]; skip[2]; w["Proof:"]; w[ SequenceForm["Let ", Delta[var, "."], " denote the forward difference operator in ", var, " and define"]]; w[ SequenceForm[ R, " := ", Show[R], ","]]; w["then the Theorem follows from summing the equation"]; skip[1]; w[ (LHS /. SUM[n_] -> F[ var, n]) == Delta[ var, R F[var, recvar]]]; skip[1]; w[ SequenceForm["over the range ", iterator, "."]]; skip[1]; w[ "This equation is routinely verifyable by dividing both sides by F,"]; w[ "and checking the resulting rational equation."]; w["----------------------------------------------------------------------"]; Close[ handle]; ] End[]; EndPackage[] Systembreaker = ENullspace (* Print[ "Fast Zeilberger by Peter Paule and Markus Schorn. (V 2.2)"]; Print[ "Systembreaker = ", Systembreaker]; *) (* done ... PAULE-SCHORN PACKAGE *) (* PACKAGE *) BeginPackage["SpecialFunctions`"] Unprotect[D] (* Beginn Einfuegung fuer Buch *) DiskreteStammfunktion::usage = "DiskreteStammfunktion[a, k] ist eine Anwendung des Gosperalgorithmus und erzeugt eine diskrete Stammfunktion. Koepf: Computeralgebra, Springer, 2006, S. 436" GradSchranke::usage = "GradSchranke[A, B, C, k] ist ein Teil des Gosperalgorithmus und bestimmt die Gradschranke einer Polynoml\[ODoubleDot]sung einer inhomogenen Rekursion. Koepf: Computeralgebra, Springer, 2006, S. 413" PrimDispersion::usage = "PrimDispersion[q, r, k] ist ein Teil des Gosperalgorithmus und bestimmt die Dispersion zweier irreduzibler Polynome. Koepf: Computeralgebra, Springer, 2006, S. 417" DispersionsMenge::usage = "DispersionsMenge[q, r, k] ist ein Teil des Gosperalgorithmus und bestimmt die Dispersionsmenge zweier Polynome. Koepf: Computeralgebra, Springer, 2006, S. 418" REtoPol::usage = "REtoPol[A, B, C, k] ist ein Teil des Gosperalgorithmus und bestimmt die Polynoml\[ODoubleDot]sung einer inhomogenen Rekursion. Koepf: Computeralgebra, Springer, 2006, S. 414" SumRekursion::usage = "SumRekursion[F, k, S[n]] ist eine Anwendung des Zeilbergeralgorithmus und erzeugt eine Rekursion f\[UDoubleDot]r eine definite hypergeometrische Summe. Koepf: Computeralgebra, Springer, 2006, S. 424" WZCertificate::usage = "WZCertificate[F, k, n] liefert das WZ-Zertifikat einer konstanten hypergeometrischen Summe unter Anwendung des Gosperalgorithmus. Koepf: Computeralgebra, Springer, 2006, S. 431" (* Ende Einfuegung fuer Buch *) (* Airy function *) Ai::usage = "Ai[n,x] is the iterated derivative D[AiryAi[x],{x,n}]" Literal[Derivative[0,kk_][Ai]]:=Module[{n,xx}, Function[{n,xx},Ai[n+kk,xx]]] D[Ai[n_,xx_],xx_]:= Derivative[0,1][Ai][n,xx] Ai[0,xx_]:=AiryAi[xx] Ai[1,xx_]:=AiryAiPrime[xx] (* Bateman *) (* AS (13.6) *) Bateman::usage = "Bateman[n,x] is the Bateman function given by Bateman[n,x] == (-1)^n*2/Pi*Integrate[Cos[t*Tan[theta]-2*n*theta],{theta,0,Pi/2}]" Bateman[0,xx_]:=E^(-xx) Bateman[1,xx_]:=(-2*xx)/E^xx Literal[Derivative[0,1][Bateman]]:=Module[{n,xx}, Function[{n,xx}, 1/xx*((n-xx)*Bateman[n, xx]-(n-1)*Bateman[n-1, xx])]] D[Bateman[n_,xx_],xx_]:= Derivative[0,1][Bateman][n, xx] D[Bateman[n_,xx_],{xx_,kk_}]:=D[D[Bateman[n, xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* Hankel functions *) (* AS (9.1.3)-(9.1.4) *) Hankel1::usage = "Hankel1[n,x] is the first Hankel function, see Abramowitz/Stegun, (9.1.3)" Hankel2::usage = "Hankel2[n,x] is the second Hankel function, see Abramowitz/Stegun, (9.1.4)" Literal[Derivative[0,1][Hankel1]]:=Module[{n,xx}, Function[{n,xx}, (Hankel1[n-1,xx] - (n/xx) * Hankel1[n,xx])]] D[Hankel1[n_,xx_],xx_]:= Derivative[0,1][Hankel1][n, xx] D[Hankel1[n_,xx_],{xx_,kk_}]:=D[D[Hankel1[n, xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) Literal[Derivative[0,1][Hankel2]]:=Module[{n,xx}, Function[{n,xx}, (Hankel2[n-1,xx] - (n/xx) * Hankel2[n,xx])]] D[Hankel2[n_,xx_],xx_]:= Derivative[0,1][Hankel2][n, xx] D[Hankel2[n_,xx_],{xx_,kk_}]:=D[D[Hankel2[n, xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* Kummer functions *) (* AS (13.1.2) *) KummerM::usage = "KummerM[a,b,z] is Kummer's M-function given by KummerM[a,b,z] == Sum[Pochhammer[a,k]/(Pochhammer[b,k]*k!)*z^k,{k,0,Infinity}], see Abramowitz/Stegun, (13.1.2)." Literal[Derivative[0,0,1][KummerM]]:=Module[{aa,b,xx}, Function[{aa,b,xx}, 1/xx*((b-aa)*KummerM[aa-1,b,xx]-(b-aa-xx)*KummerM[aa,b,xx])]] D[KummerM[n_,m_,xx_],xx_]:= Derivative[0,0,1][KummerM][n, m, xx] D[KummerM[n_,m_,xx_],{xx_,kk_}]:=D[D[KummerM[n, m, xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* AS (13.1.3) *) KummerU::usage = "KummerU[a,b,z] is Kummer's U-function given by KummerU[a,b,z] == Pi/Sin[Pi*b]*(KummerM[a,b,z]/(Gamma[1+a-b]*Gamma[b]) - z^(1-b)*KummerM[1+a-b,2-b,z]/(Gamma[a]*Gamma[2-b])), see Abramowitz/Stegun, (13.1.3)." Literal[Derivative[0,0,1][KummerU]]:=Module[{aa,b,xx}, Function[{aa,b,xx}, (- KummerU[aa-1,b,xx] + (aa-b+xx)*KummerU[aa,b,xx])/xx]] D[KummerU[n_,m_,xx_],xx_]:= Derivative[0,0,1][KummerU][n, m, xx] D[KummerU[n_,m_,xx_],{xx_,kk_}]:=D[D[KummerU[n, m, xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* Whittaker functions *) (* AS (13.1.32) *) WhittakerM::usage = "WhittakerM[a,b,z] is Whittakers M-function given by WhittakerM[a,b,z] == E^(-z/2)*z^(1/2+b)*KummerM[1/2+b-a,1+2*b,z], see Abramowitz/Stegun, (13.1.32)." Literal[Derivative[0,0,1][WhittakerM]]:=Module[{n,m,xx}, Function[{n,m,xx}, 1/(2*xx)*((1+2*m-2*n)*WhittakerM[n-1,m,xx] + (2*n-xx)*WhittakerM[n,m,xx])]] D[WhittakerM[n_,m_,xx_],xx_]:= Derivative[0,0,1][WhittakerM][n, m, xx] (* AS (13.1.33) *) WhittakerW::usage = "WhittakerW[a,b,z] is Whittakers W-function given by WhittakerW[a,b,z] == E^(-z/2)*z^(1/2+b)*KummerU[1/2+b-a,1+2*b,z], see Abramowitz/Stegun, (13.1.33)." D[WhittakerM[n_,m_,xx_],{xx_,kk_}]:=D[D[WhittakerM[n, m, xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) Literal[Derivative[0,0,1][WhittakerW]]:=Module[{n,m,xx}, Function[{n,m,xx}, 1/(4*xx)*((1-4*m^2-4*n+4*n^2)*WhittakerW[n-1,m,xx] + (4*n-2*xx)*WhittakerW[n,m,xx])]] D[WhittakerW[n_,m_,xx_],xx_]:= Derivative[0,0,1][WhittakerW][n, m, xx] D[WhittakerW[n_,m_,xx_],{xx_,kk_}]:=D[D[WhittakerW[n, m, xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* Hypergeometric1F0 function *) Hypergeometric1F0::usage = "Hypergeometric1F0[a,z] is the hypergeometric function 1F0(a; ; z)." Literal[Derivative[0,1][Hypergeometric1F0]]:=Module[{aa,xx}, Function[{aa,xx}, aa/(1-xx)*Hypergeometric1F0[aa,xx]] ] D[Hypergeometric1F0[aa_,xx_],xx_]:= Derivative[0,1][Hypergeometric1F0][aa,xx] D[Hypergeometric1F0[aa_,xx_],{xx_,kk_}]:= D[D[Hypergeometric1F0[aa,xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* Hypergeometric2F0 function *) Hypergeometric2F0::usage = "Hypergeometric2F0[a,b,z] is the hypergeometric function 2F0(a, b; ; z)." Literal[Derivative[0,0,1][Hypergeometric2F0]]:=Module[{aa,b,xx}, Function[{aa,b,xx}, aa/xx*(Hypergeometric2F0[aa+1,b,xx]-Hypergeometric2F0[aa,b,xx])]] D[Hypergeometric2F0[aa_,b_,xx_],xx_]:= Derivative[0,0,1][Hypergeometric2F0][aa,b,xx] D[Hypergeometric2F0[aa_,b_,xx_],{xx_,kk_}]:= D[D[Hypergeometric2F0[aa,b,xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* Hypergeometric2F3 function *) Hypergeometric2F3::usage = "Hypergeometric2F3[a,b,c,d,e,z] is the hypergeometric function 2F3(a, b; c, d, e; z)." Literal[Derivative[0,0,0,0,0,1][Hypergeometric2F3]]:=Module[{aa,b,cc,d,e,xx}, Function[{aa,b,cc,d,e,xx}, aa/xx*(Hypergeometric2F3[aa+1,b,cc,d,e,xx]-Hypergeometric2F3[aa,b,cc,d,e,xx])]] D[Hypergeometric2F3[aa_,b_,cc_,d_,e_,xx_],xx_]:= Derivative[0,0,0,0,0,1][Hypergeometric2F3][aa,b,cc,d,e,xx] D[Hypergeometric2F3[aa_,b_,cc_,d_,e_,xx_],{xx_,kk_}]:= D[D[Hypergeometric2F3[aa,b,cc,d,e,xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* Hypergeometric3F2 function *) Hypergeometric3F2::usage = "Hypergeometric3F2[a,b,c,d,e,z] is the hypergeometric function 3F2(a, b, c; d, e; z)." Literal[Derivative[0,0,0,0,0,1][Hypergeometric3F2]]:=Module[{aa,b,cc,d,e,xx}, Function[{aa,b,cc,d,e,xx}, aa/xx*(Hypergeometric3F2[aa+1,b,cc,d,e,xx]-Hypergeometric3F2[aa,b,cc,d,e,xx])]] D[Hypergeometric3F2[aa_,b_,cc_,d_,e_,xx_],xx_]:= Derivative[0,0,0,0,0,1][Hypergeometric3F2][aa,b,cc,d,e,xx] D[Hypergeometric3F2[aa_,b_,cc_,d_,e_,xx_],xx_]:= Derivative[0,0,0,0,0,1][Hypergeometric3F2][aa,b,cc,d,e,xx] (* Struve functions *) StruveH::usage = "StruveH[n,x] is the Struve H-function, see Abramowitz/Stegun, (12.1.3)." (* AS (12.1.9)-(12.1.10) *) Literal[Derivative[0,1][StruveH]]:=Module[{n,xx}, Function[{n,xx}, (xx*StruveH[-1 + n,xx] - n*StruveH[n,xx])/xx]] D[StruveH[n_,xx_],xx_]:=Derivative[0,1][StruveH][n, xx] D[StruveH[n_, xx_],{xx_,kk_}]:= D[D[StruveH[n, xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) StruveL::usage = "StruveL[n,x] is the Struve L-function, see Abramowitz/Stegun, (12.2.1)." (* AS (12.2.4)-(12.2.5) *) Literal[Derivative[0,1][StruveL]]:=Module[{n,xx}, Function[{n,xx}, (xx*StruveL[-1 + n,xx] - n*StruveL[n,xx])/xx]] D[StruveL[n_,xx_],xx_]:=Derivative[0,1][StruveL][n, xx] D[StruveL[n_, xx_],{xx_,kk_}]:= D[D[StruveL[n, xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* AS (27.5) *) Abramowitz::usage = "Abramowitz[n,z] is the Abramowitz function given by Abramowitz[n,z] == Integrate[t^n*Exp[-t^2-z/t],{t,0,Infinity}], see Abramowitz/Stegun, (27.5)." Literal[Derivative[0,kk_][Abramowitz]]:=Module[{n,xx}, Function[{n,xx},(-1)^kk*Abramowitz[n-kk,xx]]] D[Abramowitz[n_,xx_],xx_]:= Derivative[0,1][Abramowitz][n,xx] Abramowitz[n_,0]:=Gamma[(n+1)/2]/2 (* NormalIntegral *) (* AS (26.2.41) *) NormalIntegral::usage = "NormalIntegral[n,z] is the repeated integral of the Normal Probability Integral, see Abramowitz/Stegun, (26.2.41)." Literal[Derivative[0,kk_][NormalIntegral]]:=Module[{n,xx}, Function[{n,xx},(-1)^kk*NormalIntegral[n-kk,xx]]] D[NormalIntegral[n_,xx_],xx_]:= Derivative[0,1][NormalIntegral][n,xx] NormalIntegral[-1,xx_]:=1/Sqrt[2 Pi]*E^(-xx^2/2) NormalIntegral[0,xx_]:=1/2 - Erf[xx/2^(1/2)]/2 KnuthA::usage = "KnuthA[n,x] is the function KnuthA[n,x]==E^(-x^3/6)/3^((n+1)/3)* Sum[(3^(2/3)*x/2)^k/(k!*Gamma[(n+1-2k)/3]),{k,0,Infinity}]" KnuthB::usage = "KnuthB[n,x] is the function KnuthB[n,x]==1/3^((n+1)/3)* Sum[(3^(2/3)*x/2)^k/(k!*Gamma[(n+1-2k)/3]),{k,0,Infinity}]" (* Knuth (10.23) *) Literal[Derivative[0,1][KnuthA]]:=Module[{n,xx}, Function[{n,xx},KnuthA[n-2,xx]/2-xx^2*KnuthA[n,xx]/2]] D[KnuthA[n_,xx_],xx_]:= Derivative[0,1][KnuthA][n,xx] D[KnuthA[n_,xx_],{xx_,kk_}]:=D[D[KnuthA[n,xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* Knuth (10.6) *) Literal[Derivative[0,1][KnuthB]]:=Module[{n,xx}, Function[{n,xx},KnuthB[n-2,xx]/2]] D[KnuthB[n_,xx_],xx_]:= Derivative[0,1][KnuthB][n,xx] D[KnuthB[n_,xx_],{xx_,kk_}]:=D[D[KnuthB[n,xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) ParabolicU::usage = "ParabolicU[n,z] is the parabolic cylinder function U(n,z), see Abramowitz/Stegun, Chapter 19." ParabolicV::usage = "ParabolicV[n,z] is the parabolic cylinder function V(n,z), see Abramowitz/Stegun, Chapter 19." ParabolicD::usage = "ParabolicD[n,z] is the parabolic cylinder function D(n,z), see Abramowitz/Stegun, Chapter 19." (* AS (19.6.2) *) Literal[Derivative[0,1][ParabolicU]]:=Module[{n,xx}, Function[{n,xx},-ParabolicU[n-1,xx]+xx/2*ParabolicU[n,xx]]] D[ParabolicU[n_,xx_],xx_]:= Derivative[0,1][ParabolicU][n,xx] D[ParabolicU[n_,xx_],{xx_,kk_}]:=D[D[ParabolicU[n,xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* AS (19.6.5) *) Literal[Derivative[0,1][ParabolicV]]:=Module[{n,xx}, Function[{n,xx},(n-1/2)*ParabolicV[n-1,xx]+xx/2*ParabolicV[n,xx]]] D[ParabolicV[n_,xx_],xx_]:= Derivative[0,1][ParabolicV][n,xx] D[ParabolicV[n_,xx_],{xx_,kk_}]:=D[D[ParabolicV[n,xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) (* using AS (19.3.1) *) Literal[Derivative[0,1][ParabolicD]]:=Module[{n,xx}, Function[{n,xx},-ParabolicD[n+1,xx]+xx/2*ParabolicD[n,xx]]] D[ParabolicD[n_,xx_],xx_]:= Derivative[0,1][ParabolicD][n,xx] D[ParabolicD[n_,xx_],{xx_,kk_}]:=D[D[ParabolicD[n,xx],{xx,kk-1}],xx]/; (IntegerQ[kk] && kk>1) SphericalBesselJ::usage = "SphericalBesselJ[n,x] is the spherical Bessel function SphericalBesselJ[n,x]=Sqrt[Pi/(2x)]*BesselJ[n+1/2,x]" SphericalBesselY::usage = "SphericalBesselY[n,x] is the spherical Bessel function SphericalBesselY[n,x]=Sqrt[Pi/(2x)]*BesselY[n+1/2,x]" SphericalBesselI::usage = "SphericalBesselI[n,x] is the spherical Bessel function SphericalBesselI[n,x]=Sqrt[Pi/(2x)]*BesselI[n+1/2,x]" SphericalBesselK::usage = "SphericalBesselK[n,x] is the spherical Bessel function SphericalBesselK[n,x]=Sqrt[Pi/(2x)]*BesselK[n+1/2,x]" SphericalHankel1::usage = "SphericalHankel1[n,x] is the spherical Hankel function SphericalHankel1[n,x]=Sqrt[Pi/(2x)]*Hankel1[n+1/2,x]" SphericalHankel2::usage = "SphericalHankel2[n,x] is the spherical Hankel function SphericalHankel2[n,x]=Sqrt[Pi/(2x)]*Hankel2[n+1/2,x]" SphericalBesselJ[n_,xx_]:=Sqrt[Pi/(2xx)]*BesselJ[n+1/2,xx] SphericalBesselY[n_,xx_]:=Sqrt[Pi/(2xx)]*BesselY[n+1/2,xx] SphericalHankel1[n_,xx_]:=Sqrt[Pi/(2xx)]*Hankel1[n+1/2,xx] SphericalHankel2[n_,xx_]:=Sqrt[Pi/(2xx)]*Hankel2[n+1/2,xx] SphericalBesselI[n_,xx_]:=Sqrt[Pi/(2xx)]*BesselI[n+1/2,xx] (* here a second one is mentioned *) SphericalBesselK[n_,xx_]:=Sqrt[Pi/(2xx)]*BesselK[n+1/2,xx] Krawtchouk::usage = "Krawtchouk[n,N,p,x] denote the Krawtchouk polynomials, Krawtchouk[n,N,p,x] == (-1)^n*Binomial[N,n]*p^n*Hypergeometric2F1[-n,-x,-N,1/p], see Nikiforov, Suslov, Uvarov: Classical Orthogonal Polynomials of a Discrete Variable" Krawtchouk[n_,N_,p_,xx_]:=Module[{kk,init,tmp,tab}, If[n==0,Return[1]]; init=tmp=(-1)^n*Binomial[N,n]*p^n; tab=Table[tmp=tmp*(kk-n)*(kk-xx)/(kk-N)/(kk+1)/p,{kk,0,n-1}]; init+Apply[Plus,tab] ] /; (IntegerQ[n] && n>=0) Charlier::usage = "Charlier[n,mu,x] denote the Charlier polynomials, Charlier[n,mu,x] == Hypergeometric2F0[-n,-x,-1/mu], see Nikiforov, Suslov, Uvarov: Classical Orthogonal Polynomials of a Discrete Variable" Charlier[n_,mu_,xx_]:=Module[{kk,init,tmp,tab}, If[n==0,Return[1]]; init=tmp=1; tab=Table[tmp=-tmp*(kk-n)*(kk-xx)/(kk+1)/mu,{kk,0,n-1}]; init+Apply[Plus,tab] ] /; (IntegerQ[n] && n>=0) Meixner::usage = "Meixner[n,gamma,mu,x] denote the Meixner polynomials, Meixnerm[n,gamma,mu,x] == Pochhammer[gamma,n]*Hypergeometric2F1[-n,-x,gamma,1-1/mu], see Nikiforov, Suslov, Uvarov: Classical Orthogonal Polynomials of a Discrete Variable" Meixner[n_,gamma_,mu_,xx_]:=Module[{kk,init,tmp,tab}, If[n==0,Return[1]]; init=tmp=Pochhammer[gamma,n]; tab=Table[tmp=tmp*(kk-n)*(kk-xx)/(kk+gamma)/(kk+1)*(1-1/mu),{kk,0,n-1}]; init+Apply[Plus,tab] ] /; (IntegerQ[n] && n>=0) DiscreteLaguerre::usage = "DiscreteLaguerre[n,rho,alpha,x] denote the discrete Laguerre polynomials DiscreteLaguerre[n,rho,alpha,x] == Pochhammer[1+alpha,n]*rho^n/n!* Hypergeometric2F1[-n,-x+1,1+alpha,1-1/rho]" DiscreteLaguerre[n_,rho_,alpha_,xx_]:=Module[{kk,init,tmp,tab}, If[n==0,Return[1]]; init=tmp=Pochhammer[1+alpha,n]*rho^n/n!; tab=Table[tmp=tmp*(kk-n)*(kk-xx+1)/(kk+1+alpha)/(kk+1)*(1-1/rho), {kk,0,n-1}]; init+Apply[Plus,tab] ] /; (IntegerQ[n] && n>=0) Hahn::usage = "Hahn[n,N,alpha,beta,x] denote the discrete Hahn polynomials, Hahn[n,N,alpha,beta,x] == (-1)^n/n!*Pochhammer[N-n,n]*Pochhammer[beta+1,n]* HypergeometricPFQ[{-n,-x,alpha+beta+n+1},{beta+1,1-N},1], see Nikiforov, Suslov, Uvarov: Classical Orthogonal Polynomials of a Discrete Variable" Hahn[n_,N_,alpha_,beta_,xx_]:=Module[{kk,init,tmp,tab}, If[n==0,Return[1]]; init=tmp=(-1)^n/n!*Pochhammer[N-n,n]*Pochhammer[beta+1,n]; tab=Table[ tmp=tmp*(kk-n)*(kk-xx)*(kk+alpha+beta+n+1)/(kk+1)/(kk+beta+1)/(kk+1-N), {kk,0,n-1}]; init+Apply[Plus,tab] ] /; (IntegerQ[n] && n>=0) DiscreteChebyshev::usage = "DiscreteChebyshev[n,N,x] denote the discrete Chebyshev polynomials, DiscreteChebyshev[n,N,x] == (-1)^n*Pochhammer[N-n,n]*HypergeometricPFQ[{-n,-x,n+1},{1,-N},1], see Nikiforov, Suslov, Uvarov: Classical Orthogonal Polynomials of a Discrete Variable" DiscreteChebyshev[n_,N_,xx_]:= Hahn[n,N,0,0,xx] /; (IntegerQ[n] && n>=0) Protect[D] (* usages *) ZTransform::usage = "ZTransform[a,k,z] gives the Z Transform Sum[a[k] z^(-k),{k,0,Infinity}].\n\n Example: ZTransform[1/k!,k,z] results in\n\n 1/z\n E" InverseZTransform::usage = "InverseZTransform[f,z] gives the inverse Z Transform f[z]==Sum[a[k] z^(-k),{k,0,Infinity}].\n\n Example: InverseZTransform[E^(1/z),z] results in\n\n 1 k\n (-)\n z\n sum[----, {k, 0, Infinity}]\n k!" SumDE::usage = "SumDE[de1,de2,F[x]] gives the holonomic differential equation for the sum f+g, given holonomic differential equations de1 for f and de2 for g in terms of F[x]. You can also use SumDE[de1,de2,F,x].\n\n Example: SumDE[F''[x]-F[x]==0,F'[x]-x F[x]==0,F[x]] results in\n\n 2 2 (3)\n (2 + x ) F[x] - x F'[x] + (-2 - x ) F''[x] + x F [x] == 0" DESum::usage = "DESum[de1,de2,F[x]] gives the holonomic differential equation for the sum f+g, given holonomic differential equations de1 for f and de2 for g in terms of F[x]. You can also use DESum[de1,de2,F,x].\n\n Example: DESum[F''[x]-F[x]==0,F'[x]-x F[x]==0,F[x]] results in\n\n 2 2 (3)\n (2 + x ) F[x] - x F'[x] + (-2 - x ) F''[x] + x F [x] == 0" ProductDE::usage = "ProductDE[de1,de2,F[x]] gives the holonomic differential equation for the product f*g, given holonomic differential equations de1 for f and de2 for g in terms of F[x]. You can also use ProductDE[de1,de2,F,x].\n\n Example: ProductDE[F''[x]-F[x]==0,F'[x]-x F[x]==0,F[x]] results in\n\n 2\n (-2 + x ) F[x] - 2 x F'[x] + F''[x] == 0" DEProduct::usage = "DEProduct[de1,de2,F[x]] gives the holonomic differential equation for the product f*g, given holonomic differential equations de1 for f and de2 for g in terms of F[x]. You can also use DEProduct[de1,de2,F,x].\n\n Example: DEProduct[F''[x]-F[x]==0,F'[x]-x F[x]==0,F[x]] results in\n\n 2\n (-2 + x ) F[x] - 2 x F'[x] + F''[x] == 0" SumRE::usage = "SumRE[re1,re2,A[k] gives the holonomic recurrence equation for the sum a+b, given holonomic recurrence equations re1 for a and re2 for b given in terms of A[k]. You can also use SumRE[re1,re2,A,k].\n\n Example: SumRE[A[k+1]==A[k]/(k+1),A[k+1]==A[k]+A[k-1],A[k]] results in\n\n 2 3\n (2 + k) (4 + k) A[k] + (-1 - 9 k - 6 k - k ) A[1 + k] +\n \n 2 3 2\n (-17 - 21 k - 8 k - k ) A[2 + k] + (1 + k) (3 + k) A[3 + k] == 0" RESum::usage = "RESum[re1,re2,A[k]] gives the holonomic recurrence equation for the sum a+b, given holonomic recurrence equations re1 for a and re2 for b given in terms of A[k]. You can also use RESum[re1,re2,A,k].\n\n Example: RESum[A[k+1]==A[k]/(k+1),A[k+1]==A[k]+A[k-1],A[k]] results in\n\n 2 3\n (2 + k) (4 + k) A[k] + (-1 - 9 k - 6 k - k ) A[1 + k] +\n \n 2 3 2\n (-17 - 21 k - 8 k - k ) A[2 + k] + (1 + k) (3 + k) A[3 + k] == 0" ProductRE::usage = "ProductRE[re1,re2,A[k]] gives the holonomic recurrence equation for the product a*b, given holonomic recurrence equations re1 for a and re2 for b given in terms of A[k]. You can also use ProductRE[re1,re2,A,k].\n\n Example: ProductRE[A[k+1]==A[k]/(k+1),A[k+1]==A[k]+A[k-1],A[k]] results in\n\n A[k] + (1 + k) A[1 + k] - (1 + k) (2 + k) A[2 + k] == 0" REProduct::usage = "REProduct[re1,re2,A[k]] gives the holonomic recurrence equation for the product a*b, given holonomic recurrence equations re1 for a and re2 for b given in terms of A[k].You can also use REProduct[re1,re2,A,k].\n\n Example: REProduct[A[k+1]==A[k]/(k+1),A[k+1]==A[k]+A[k-1],A[k]] results in\n\n A[k] + (1 + k) A[1 + k] - (1 + k) (2 + k) A[2 + k] == 0" ConvolutionRE::usage = "ConvolutionRE[b,c,A[k],n] gives the holonomic recurrence equation of the sum Sum[b[k]*c[n-k],{k,0,n}] in terms of A[k]. You can also us ConvolutionRE[b,c,k,n,A].\n\n Example: ConvolutionRE[(-1/2)^m PolyGamma[1+m]/m!,1/m!,a[m],n] results in\n\n a[n] - (8 + 5 n) a[1 + n] + 2 (2 + n) (9 + 4 n) a[2 + n] -\n\n 2\n 4 (2 + n) (3 + n) a[3 + n] == 0" SumToHypergeometric::usage = "SumToHypergeometric[f] calculates a hypergeometric representation of an expression f involving sums of the form Sum[expr,{k,0,Infinity}].\n\n Example: SumToHypergeometric[sum[(-1)^k*Binomial[2n,k]^2,{k,0,Infinity}]] results in\n\n hypergeometricPFQ[{-2 n, -2 n}, {1}, -1]" FunctionToHypergeometric::usage = "FunctionToHypergeometric[f,x] calculates a hypergeometric representation of an expression f.\n\n Example: FunctionToHypergeometric[Sin[x],x] results in\n\n 2\n 3 -x\n x hypergeometricPFQ[{}, {-}, ---]\n 2 4" HolonomicDE::usage = "HolonomicDE[g,f[x]] searches for a homogeneous linear differential equation with polynomial coefficients for the function g of the variable x, and results in this DE using the symbol f[x]. You can also use HolonomicDE[g,x,f] or the shortform HolonomicDE[g,x].\n\n Example: HolonomicDE[ArcSin[x]^2,f[x]] results in\n\n (3)\n f'[x] + 3 x f''[x] + (-1 + x) (1 + x) f [x] == 0" holonomicDE::usage = "HolonomicDE[g,f[x],max] searches for a homogeneous linear differential equation with polynomial coefficients for the function g of the variable x up to order max, and results in this DE using the symbol f[x]. You can also use holonomicDE[g,f[x]] with max=5.\n\n Example: holonomicDE[ArcSin[x]^2,f[x]] results in\n\n (3)\n f'[x] + 3 x f''[x] + (-1 + x) (1 + x) f [x] == 0" HolonomicRE::usage = "HolonomicRE[expr,a[k]] finds a homogeneous recurrence equation with polynomial coefficients satisfied by expr depending on k, and results in this RE using the symbol a[k]. You can also use HolonomicRE[expr,k,a] or the shortform HolonomicRE[expr,k].\n\n Example: HolonomicRE[(-3 - (1/3)^k + 3*(1/2)^k),a[k]] results in\n\n a[k] - 6 a[1 + k] + 11 a[2 + k] - 6 a[3 + k] == 0" ComplexFactor::usage = "ComplexFactor[f,x] gives the complex factorization of the rational expression f with respect to the variable x.\n\n Example: ComplexFactor[(1-x^2)/(1+x^2),x] results in\n\n (-1 + x) (1 + x)\n -(----------------)\n (-I + x) (I + x)" ComplexApart::usage = "ComplexApart[f,x] gives the complex partial fraction decomposition of the rational expression f with respect to the variable x.\n\n Example: ComplexApart[(1-x^2)/(1+x^2),x] results in\n\n I I\n -1 - ------ + -----\n -I + x I + x" SimpleDE::usage = "SimpleDE[g,f[x]] searches for a homogeneous linear differential equation with polynomial coefficients for the function f of the variable x, and results in this DE using the symbol f[x]. You can also use SimpleDE[g,x,f] or the shortform SimpleDE[g,x].\n\n Example: SimpleDE[ArcSin[x]^2,f[x]] results in\n\n (3)\n f'[x] + 3 x f''[x] + (-1 + x) (1 + x) f [x] == 0" DEtoRE::usage = "DEtoRE[de,F[x],a[k]] converts the homogeneous linear differential equation de of the function F[x] with polynomial coefficients into an equivalent recurrence equation using the general coefficient a[k]. You can also use DEtoRE[de,F,x,a,k] or the shortform DEtoRE[de,F,x].\n\n Example: DEtoRE[G[t] + G''[t] == 0,G[t],b[n]] results in\n\n b[n] + (1 + n) (2 + n) b[2 + n] == 0" SimpleRE::usage = "SimpleRE[f,x,a[k]] searches for a homogeneous linear recurrence equation with polynomial coefficients for the formal power series coefficients of the expression f with respect to the variable x, and results in this RE using the symbol a[k] for the general coefficient. You can also use SimpleRE[f,x,a,k] or the shortform SimpleRE[f,x].\n\n Example: SimpleRE[Sin[t],t,b[n]] results in\n\n b[n] + (1 + n) (2 + n) b[2 + n] == 0" SeriesSolution::usage = "SeriesSolution[DE,y[x],incslist,n] gives the n-th order power series approximation of the holonomic differential equation DE in terms of y[x], using the initial values incslist. You can also use SeriesSolution[DE,y,x,incslist,n].\n\n Example: SeriesSolution[y''[x]-x*y[x]==0,y[x],{AiryAi[0],AiryAi'[0]},3] results in\n\n 3\n x 1 x\n -(-------------) + ------------- + ---------------\n 1/3 1 2/3 2 2/3 2\n 3 Gamma[-] 3 Gamma[-] 6 3 Gamma[-]\n 3 3 3" Taylor::usage = "Taylor[f,{x,x0,n}] calculates the nth order power series approximation of f at the point x0 with respect to variable x, by computing a holonomic differential equation of f, if applicable. For holonomic functions this is the fasted known method. For x0=0 ypu can also use Taylor[f,x,n].\n\n Example: Taylor[Sin[x]*Exp[x],{x,0,13}] results in\n\n 3 5 6 7 9 10 11 13\n 2 x x x x x x x x\n x + x + -- - -- - -- - --- + ----- + ------ + ------- - --------\n 3 30 90 630 22680 113400 1247400 97297200" PowerSeries::usage = "PowerSeries[f,x,x0] tries to find a formal power series expansion for f with respect to the variable x at the point of development x0. It also works for formal Laurent series (negative exponents), for Puiseux series (fractional exponents), and in certain cases of logarithmic singularities. PS is a shortform for PowerSeries.\n\n Example: PowerSeries[Sin[x],x,Pi] results in\n\n k 1 + 2 k\n (-1) (-Pi + x)\n sum[-(----------------------), {k, 0, Infinity}]\n (1 + 2 k)!" PS::usage = PowerSeries::usage FPS::usage = PowerSeries::usage (* begin Algebraic package *) AlgebraicDE::usage = "AlgebraicDE[F,y[x]] searches for a homogeneous linear differential equation with polynomial coefficients for the function y[x] of the variable x, given by the algebraic equation F[x,y]==0, and results in this differential equation. The order of the differential equation is at most the order of F with respect to y.\n\n Example: AlgebraicDE[y^3+x^2 y-2 x^3,y[x]] results in\n\n -y[x] + x y'[x] == 0" (* end Algebraic package *) Convert::usage="Convert[sum[expr*x^(m*k+b),{k,k0,Infinity}],x] converts the Laurent-Puiseux series Sum[expr*x^(m*k+b),{k,k0,Infinity}] to its generating function with respect to the variable x.\n\n Example: Convert[sum[(k!)^2/(2k)!x^k,{k,0,Infinity}],x] results in\n\n Sqrt[4 - x] (-2 + x)\n 2 Sqrt[x] ArcTan[--------------------]\n -4 Pi Sqrt[x] (-4 + x) Sqrt[x]\n ------ - -------------------- + --------------------------------------\n -4 + x Sqrt[4 - x] (-4 + x) Sqrt[4 - x] (-4 + x)" GeneratingFunction::usage="GeneratingFunction[a,k,x] calculates the generating function Sum[a*x^k,{k,0,Infinity}] in terms of the variable x of the sequence a depending on k.\n\n Example: GeneratingFunction[LegendreP[n,x],n,z] results in\n\n 1\n --------------------\n 2\n Sqrt[1 - 2 x z + z ]" ExponentialGeneratingFunction::usage="ExponentialGeneratingFunction[a,k,x] calculates the exponential generating function Sum[a*x^k/k!,{k,0,Infinity}] in terms of the variable x of the sequence a depending on k.\n\n Example: ExponentialGeneratingFunction[HermiteH[n,x],n,z] results in\n\n (2 x - z) z\n E" SimpByRecursion::usage= "SimpByRecursion[expr] simplifies an expression involving special functions according to known recurrence equations. \n\n Example: SimpByRecursion[x*BesselI[n+2,x]+2*(1+n)*BesselI[n+1,x]] results in \n\n x BesselI[n, x]" FindRecursion::usage="FindRecursion[expr,a[k]] finds a homogeneous recurrence equation with polynomial coefficients satisfied by expr depending on k, and results in this RE using the symbol a[k]. You can also use FindRecursion[expr,k,a] or thee shortform FindRecursion[expr,k].\n\n Example: FindRecursion[(-3 - (1/3)^k + 3*(1/2)^k),a[k]] results in\n\n a[k] - 6 a[1 + k] + 11 a[2 + k] - 6 a[3 + k] == 0" DEOrder::usage = "DEOrder[de,y[x]] gives the order of the linear differential equation de formed by the expression y depending on the variable x. You can also use DEOrder[de,y,x]." AsymptPowerSeries::usage="AsymptPowerSeries[f,x] tries to find a formal asymptotic power series expansion for f with respect to the variable x for x->+Infinity. It also works for formal Laurent series, and in certain cases of fractional, or logarithmic singularities. \n\n Example: AsymptPowerSeries[ArcTan[x],x] results in\n\n k 1 1 + 2 k\n (-1) (-)\n Pi x\n -- + sum[-(----------------), {k, 0, Infinity}]\n 2 1 + 2 k" specfunprint::usage = "specfunprint turns on the specfun-info messages of the SpecialFunctions package." specfunprintoff::usage = "specfunprintoff turns off the specfun-info messages of the SpecialFunctions package." nospecfunprint::usage = "nospecfunprint turns off the specfun-info messages of the SpecialFunctions package." REtoDE::usage = "REtoDE[re,a[k],f[x]] converts the homogeneous linear recurrence equation re of the function a[k] with polynomial coefficients into an equivalent differential equation using the general function f[x]. You can also use REtoDE[re,a,k,f,x] or the shortform REtoDE[re,a,k].\n\n Example: REtoDE[a[k+1]==a[k]+a[k-1],a[k],f[x]] results in\n\n 2\n -f[x] - 2 x f[x] + f'[x] - x f'[x] - x f'[x] == 0" RETODE::usage = "RETODE[re,a,k,f,x] converts the homogeneous linear recurrence equation re of the function a[k] with polynomial coefficients into an equivalent differential equation using the general function f[x], assuming the recurrence equation is valid for all integer k. Hence an inhomogeneous part might be missing. A shortform is RETODE[re,a,k].\n\n Example: RETODE[a[k+1]==a[k]+a[k-1],a,k] results in\n\n 2\n (1 - x - x ) f[x] == 0" SumtoDE::usage = "SumtoDE[sum[expr*x^k,{k,0,Infinity}],f[x]] converts the power series Sum[expr*x^k,{k,0,Infinity}] to a differential equation using the general function f[x]. You can also use SumtoDE[sum[expr*x^k,{k,0,Infinity}],x,f] or the shortform SumtoDE[sum[expr*x^k,{k,0,Infinity}],x].\n\n Example: SumtoDE[sum[(k!)^2/(2k)!x^k,{k,0,Infinity}],f[x]] results in\n\n 2\n f[x] - 2 f'[x] + 3 x f'[x] - 4 x f''[x] + x f''[x] == 0" SimplifyCombinatorial::usage = "SimplifyCombinatorial[expr] simplifies expressions involving rational functions, exponentials, factorials, Gamma function terms, Binomial coefficients, and Pochhammer symbols by a conversion to Gamma function terms, and an application of SimplifyGamma.\n\n Example: SimplifyCombinatorial[(Binomial[n,k]/2^n-Binomial[n-1,k]/2^(n-1))/\n (Binomial[n,k-1]/2^n-Binomial[n-1,k-1]/2^(n-1))] results in\n\n (-1 + k - n) (2 k - n)\n ----------------------\n k (2 - 2 k + n)" SimpComb::usage = "SimplifyCombinatorial[expr] simplifies expressions involving rational functions, exponentials, factorials, Gamma function terms, Binomial coefficients, and Pochhammer symbols by a conversion to Gamma function terms, and an application of SimplifyGamma.\n\n Example: SimpComb[(Binomial[n,k]/2^n-Binomial[n-1,k]/2^(n-1))/\n (Binomial[n,k-1]/2^n-Binomial[n-1,k-1]/2^(n-1))] results in\n\n (-1 + k - n) (2 k - n)\n ----------------------\n k (2 - 2 k + n)" ToGamma::usage = "ToGamma[expr] converts expressions involving factorials, Binomial coefficients, and Pochhammer symbols to Gamma function terms.\n\n Example: ToGamma[Binomial[n,k]] results in\n\n Gamma[1 + n]\n -----------------------------\n Gamma[1 + k] Gamma[1 - k + n]" Ratio::usage = "Ratio[expr,k] simplifies the term ratio expr[k+1]/expr[k] if expr is written in terms of expressions involving rational functions, exponentials, and Gamma function terms.\n\n Example: Ratio[Binomial[n+1,k]-Binomial[n,k],k] results in\n\n 1 - k + n\n ---------\n k" HyperTerm::usage = "HyperTerm[upper,lower,x,k] gives the k-th summand of the hypergeometric function HypergeometricPFQ[upper,lower,x].\n\n Example: HyperTerm[{a,b},{c},x,k] results in\n\n k\n x Pochhammer[a, k] Pochhammer[b, k]\n ------------------------------------\n k! Pochhammer[c, k]" (* PACKAGE *) Begin["`Private`"] Unprotect[ ComplexFactor,ComplexApart,SimpleDE,DEtoRE,SimpleRE, PowerSeries,PS,FPS,Convert,SimpByRecursion,FindRecursion, AsymptPowerSeries,Bateman,specfunprint,specfunprintoff,nospecfunprint,REtoDE,SumtoDE] (* Version for Mathematica Version 2.2 to 5.2 *) specfuninfo = "SpecialFunctions, (C) Wolfram Koepf, version 2.03, 2011" Print[specfuninfo] Print["Fast Zeilberger, (C) Peter Paule and Markus Schorn (V 2.2) loaded"] (* Beginn Einfuegung fuer Buch *) Clear[GradSchranke] GradSchranke[A_,B_,C_,k_]:=Module[{pol1,pol2,deg1,deg2,a,b}, pol1=Collect[A-B,k]; pol2=Collect[A+B,k]; If[pol1===0,deg1=-1,deg1=Exponent[pol1,k]]; If[pol2===0,deg2=-1,deg2=Exponent[pol2,k]]; If[deg1\[LessEqual]deg2,Print["Teil 1"];Return[Exponent[C,k]-deg2]]; a=Coefficient[pol1,k,deg1]; If[deg2=0, g=Sum[\[Alpha][j]*k^j,{j,0,deg}]; rec=Collect[A*(g/.k\[Rule]k+1)+B*g-CC,k]; sol= Solve[CoefficientList[rec,k]\[Equal]0, Union[Table[\[Alpha][j],{j,0,deg}],Table[\[Sigma][j],{j,1,J}]]]; If[Not[sol==={}], RE=S[n]+Sum[\[Sigma][j]*S[n+j]/.sol[[1]],{j,1,J}]; RE=Numerator[Together[RE]]; RE=Collect[RE,S[___]]; RE=Map[Factor,RE]; Return[] ] ] ,{J,1,5}]; If[Not[PolynomialQ[u,k] &&PolynomialQ[v,k]], Return["Eingabe ist kein hypergeometrischer Term"], If[RE==={}, "Es gibt keine Rekursion der Ordnung 5",RE\[Equal]0]] ] Clear[WZCertificate] WZCertificate[F_,k_,n_]:= Module[{ratk,ratn,rat,u,v,M,dis,h,j,A,B,CC,gcd,g}, ratk=SimplifyCombinatorial[(F/.k\[Rule]k+1)/F]; ratn=SimplifyCombinatorial[(F/.n\[Rule]n+1)/F]; rat=SimplifyCombinatorial[ratk*((ratn/.k\[Rule]k+1)-1)/(ratn-1)]; u=Numerator[rat]; v=Denominator[rat]; If[Not[PolynomialQ[u,k]&&PolynomialQ[v,k]], Return["Eingabe ist kein hypergeometrischer Term"]]; M=DispersionsMenge[u/.k\[Rule]k-1,v,k]; dis=Max[M]; h=PolynomialGCD[Product[u/.k\[Rule]k-1-j,{j,0,dis}], Product[v/.k\[Rule]k+j,{j,0,dis}]]; If[dis<1,A=Together[u/(h/.k\[Rule]k+1)]; B=-Together[v/h]; CC=v, gcd=PolynomialGCD[h*u,-(h/.k\[Rule]k+1)*v,h*(h/.k\[Rule]k+1)*v]; A=Together[h*u/gcd]; B=Together[-(h/.k\[Rule]k+1)*v/gcd]; CC=Together[h*(h/.k\[Rule]k+1)*v/gcd]]; g=REtoPol[A,B,CC,k]; If[g==="keine Polynoml\[ODoubleDot]sung",Return["WZ-Methode scheitert"]]; SimplifyCombinatorial[g/h*(ratn-1)]] (* Ende Einfuegung fuer Buch *) (* From now on all Print messages only will be printed if the global variable SpecialFunctionsPrintMessages is set to True. By default, this is not the case. By the command specfunprint or specfuninfo you can set SpecialFunctionsPrintMessages to True. *) SpecialFunctionsPrintMessages=False specfunprint:=(SpecialFunctionsPrintMessages=True;) specfunprintoff:=(SpecialFunctionsPrintMessages=False;) nospecfunprint:=(SpecialFunctionsPrintMessages=False;) asympt = False transformspecial1={} transformspecial2={} (* compatibility mode for simpleDE *) transformspecial1={ BesselI->besselI, BesselK->besselK, BesselJ->besselJ, BesselY->besselY, JacobiP->jacobiP, GegenbauerC->gegenbauerC, ChebyshevT->chebyshevT, ChebyshevU->chebyshevU, Global`ChebyshevS->chebyshevS, Global`ChebyshevC->chebyshevC, Global`ChebyshevTstar->chebyshevTstar, Global`ChebyshevUstar->chebyshevUstar, LegendreP->legendreP, LegendreQ->legendreQ, Global`LegendrePstar->legendrePstar, LaguerreL->laguerreL, HermiteH->hermiteH, HermiteHe->hermiteHe, Hankel1->hankel1, Hankel2->hankel2, Bateman->bateman, KummerM->kummerM, KummerU->kummerU, (* equals HypergeometricU *) WhittakerW->whittakerW, WhittakerM->whittakerM, StruveH->struveH, StruveL->struveL, System`Hypergeometric0F1->hypergeometric0F1, Hypergeometric1F0->hypergeometric1F0, System`HypergeometricU->hypergeometricU, System`Hypergeometric1F1->hypergeometric1F1, Hypergeometric2F0->hypergeometric2F0, System`Hypergeometric2F1->hypergeometric2F1, (* article *) Ai->ai, System`Erfc->erfc, System`ExpIntegralE->expIntegralE, Abramowitz->abramowitz, NormalIntegral->NormalIntegral, KnuthA->knuthA, KnuthB->knuthB, ParabolicU->parabolicU, ParabolicD->parabolicD, ParabolicV->parabolicV, ParabolicW->parabolicW, ParabolicE->parabolicE } transformspecial2={ besselI->BesselI, besselK->BesselK, besselJ->BesselJ, besselY->BesselY, jacobiP->JacobiP, gegenbauerC->GegenbauerC, chebyshevT->ChebyshevT, chebyshevU->ChebyshevU, chebyshevS->ChebyshevS, chebyshevC->ChebyshevC, chebyshevTstar->ChebyshevTstar, chebyshevUstar->ChebyshevUstar, legendreP->LegendreP, legendreQ->LegendreQ, legendrePstar->LegendrePstar, laguerreL->LaguerreL, hermiteH->HermiteH, hermiteHe->HermiteHe, hankel1->Hankel1, hankel2->Hankel2, bateman->Bateman, kummerM->KummerM, kummerU->KummerU, whittakerW->WhittakerW, whittakerM->WhittakerM, struveH->StruveH, struveL->StruveL, hypergeometric0F1->System`Hypergeometric0F1, hypergeometric1F0->Hypergeometric1F0, hypergeometricU->System`HypergeometricU, hypergeometric1F1->System`Hypergeometric1F1, hypergeometric2F0->Hypergeometric2F0, hypergeometric2F1->System`Hypergeometric2F1, (* article *) ai->Ai, erfc->System`Erfc, expIntegralE->System`ExpIntegralE, abramowitz->Abramowitz, NormalIntegral->NormalIntegral, knuthA->KnuthA, knuthB->KnuthB, parabolicU->ParabolicU, parabolicD->ParabolicD, parabolicV->ParabolicV, parabolicW->ParabolicW, parabolicE->ParabolicE } (* begin module derivatives *) laguerreL[n_,x_]:= laguerreL[n,0,x] legendreP[n_,x_]:= legendreP[n,0,x] Unprotect[D] Literal[Derivative[0,1][bateman]]:= Function[{n,x}, 1/x*((n-x)*bateman[n, x]-(n-1)*bateman[n-1, x])] D[bateman[n_,x_],x_]:= Derivative[0,1][bateman][n, x] D[bateman[n_,x_],{x_,k_}]:=D[D[bateman[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 22.8.1 *) Literal[Derivative[0,0,0,1][jacobiP]]:= Function[{n,a, b, x}, (2*(a + n)*(b + n)*jacobiP[-1 + n, a, b, x])/((a + b + 2*n)*(1 - x^2)) + (n*(a - b - (a + b + 2*n)*x)*jacobiP[n, a, b, x])/((a + b + 2*n)*(1 -x^2))] D[jacobiP[n_, a_, b_, x_],x_]:= Derivative[0,0,0,1][jacobiP][n, a, b, x] D[jacobiP[n_, a_, b_, x_],{x_,k_}]:= D[D[jacobiP[n, a, b, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 22.8.2 *) Literal[Derivative[0,0,1][gegenbauerC]]:= Function[{n,a,x}, ((-1 + 2*a + n)*gegenbauerC[-1 + n, a, x])/(1 - x^2) - (n*x*gegenbauerC[n, a, x])/(1 - x^2)] D[gegenbauerC[n_,a_,x_],x_]:= Derivative[0,0,1][gegenbauerC][n, a, x] D[gegenbauerC[n_,a_,x_],{x_,k_}]:= D[D[gegenbauerC[n, a, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 22.8.3 *) Literal[Derivative[0,1][chebyshevT]]:= Function[{n,x}, (n*chebyshevT[-1 + n, x])/(1 - x^2) - (n*x*chebyshevT[n, x])/(1 - x^2)] D[chebyshevT[n_, x_],x_]:= Derivative[0,1][chebyshevT][n, x] D[chebyshevT[n_, x_],{x_,k_}]:= D[D[chebyshevT[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* Eigenbau aus AS 22.5.5 *) Literal[Derivative[0,1][chebyshevC]]:= Function[{n,x}, (n*chebyshevC[-1 + n, x])/(2*(1 - x^2/4)) - (n*x*chebyshevC[n, x])/(4*(1 - x^2/4)) ] D[chebyshevC[n_, x_],x_]:= Derivative[0,1][chebyshevC][n, x] D[chebyshevC[n_, x_],{x_,k_}]:= D[D[chebyshevC[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* Eigenbau aus AS 22.5.9 und 22.5.13 *) Literal[Derivative[0,1][chebyshevS]]:= Function[{n,x}, (2*(1 + n)*chebyshevS[-1 + n, x])/(4 - x^2) + (n*x*chebyshevS[n, x])/(-4 + x^2) ] D[chebyshevS[n_, x_],x_]:= Derivative[0,1][chebyshevS][n, x] D[chebyshevS[n_, x_],{x_,k_}]:= D[D[chebyshevS[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* Eigenbau aus AS 22.5.14 *) Literal[Derivative[0,1][chebyshevTstar]]:= Function[{n,x}, -((n*chebyshevTstar[-1 + n, x])/(-2*x + 2*x^2)) + (n*(-1 + 2*x))/(-2*x + 2*x^2) *chebyshevTstar[n, x] ] D[chebyshevTstar[n_, x_],x_]:= Derivative[0,1][chebyshevTstar][n, x] D[chebyshevTstar[n_, x_],{x_,k_}]:= D[D[chebyshevTstar[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* Eigenbau aus AS 22.5.15 *) Literal[Derivative[0,1][chebyshevUstar]]:= Function[{n,x}, 2*(((1 + n)*chebyshevUstar[-1 + n, x])/(1 - (-1 + 2*x)^2) - (n*(-1 + 2*x)*chebyshevUstar[n, x])/(1 - (-1 + 2*x)^2)) ] D[chebyshevUstar[n_, x_],x_]:= Derivative[0,1][chebyshevUstar][n, x] D[chebyshevUstar[n_, x_],{x_,k_}]:= D[D[chebyshevUstar[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* 22.8.4 *) Literal[Derivative[0,1][chebyshevU]]:= Function[{n,x}, ((1 + n)*chebyshevU[-1 + n, x])/(1 - x^2) - (n*x*chebyshevU[n, x])/(1 - x^2)] D[chebyshevU[n_, x_],x_]:= Derivative[0,1][chebyshevU][n, x] D[chebyshevU[n_, x_],{x_,k_}]:= D[D[chebyshevU[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* 22.8.5 *) (* WK auf drei Parameter geaendert AS (8.5.4), ist eigentlich unnoetig, da in Mathematica korrekt *) (* Literal[Derivative[0,1][legendreP]]:= Function[{n,x}, (n*legendreP[-1 + n, x])/(1 - x^2) - (n*x*legendreP[n, x])/(1 - x^2)] D[legendreP[n_, x_],x_]:= Derivative[0,1][legendreP][n, x] D[legendreP[n_, x_],{x_,k_}]:= D[D[legendreP[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) *) Literal[Derivative[0,0,1][legendreP]]:= Function[{n,m,x}, (n+m)*legendreP[-1+n,m,x]/(1 - x^2) - (n*x*legendreP[n,m,x])/(1 - x^2)] D[legendreP[n_,m_,x_],x_]:= Derivative[0,0,1][legendreP][n,m,x] D[legendreP[n_,m_,x_],{x_,k_}]:= D[D[legendreP[n,m,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,0,1][legendreQ]]:= Function[{n,m,x}, (n+m)*legendreQ[-1+n,m,x]/(1 - x^2) - (n*x*legendreQ[n,m,x])/(1 - x^2)] D[legendreQ[n_,m_,x_],x_]:= Derivative[0,0,1][legendreQ][n,m,x] D[legendreQ[n_,m_,x_],{x_,k_}]:= D[D[legendreQ[n,m,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* Vermutung, da es bei den anderen shifted- Funktionen auch so ging. Ich habe angenommen, dass legendrePstar[n,x] == legendreP[n,(1+x)/2] ist *) Literal[Derivative[0,1][legendrePstar]]:= Function[{n,x}, 2*((n*legendrePstar[-1 + n, x])/(1 - (-1 + 2*x)^2)- (n*(-1 + 2*x)*legendrePstar[n, x])/(1 - (-1 + 2*x)^2))] D[legendrePstar[n_, x_],x_]:= Derivative[0,1][legendrePstar][n, x] D[legendrePstar[n_, x_],{x_,k_}]:= D[D[legendrePstar[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* 22.8.6 *) Literal[Derivative[0,0,1][laguerreL]]:= Function[{n,a,x}, ((-a - n)*laguerreL[-1 + n, a, x])/x + n*laguerreL[n, a, x]/x] (* klappt noch nicht -laguerreL[-1 + n, 1 + a, x]] *) D[laguerreL[n_, x_],x_]:= Derivative[0,0,1][laguerreL][n,0,x] D[laguerreL[n_,a_,x_],x_]:= Derivative[0,0,1][laguerreL][n,a,x] D[laguerreL[n_,a_,x_],{x_,k_}]:= D[D[laguerreL[n,a, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* 22.8.7 *) Literal[Derivative[0,1][hermiteH]]:= Function[{n,x}, 2 n hermiteH[-1 + n, x]] D[hermiteH[n_, x_],x_]:= Derivative[0,1][hermiteH][n, x] D[hermiteH[n_, x_],{x_,k_}]:= D[D[hermiteH[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* 22.8.8 *) Literal[Derivative[0,1][hermiteHe]]:= Function[{n,x}, n hermiteHe[-1 + n, x] ] D[hermiteHe[n_, x_],x_]:= Derivative[0,1][hermiteHe][n, x] D[hermiteHe[n_, x_],{x_,k_}]:= D[D[HermiteHe[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 9.26. Seite 120 *) Literal[Derivative[0,1][besselI]]:= Function[{n,x}, besselI[n-1,x]-n/x*besselI[n,x]] D[besselI[n_,x_],x_]:=Derivative[0,1][besselI][n, x] D[besselI[n_, x_],{x_,k_}]:= D[D[besselI[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 9.26. Seite 120 *) Literal[Derivative[0,1][besselK]]:= Function[{n,x}, -besselK[n-1,x]-n/x*besselK[n,x]] D[besselK[n_,x_],x_]:=Derivative[0,1][besselK][n, x] D[besselK[n_, x_],{x_,k_}]:= D[D[besselK[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 9.1.27 Seite 105 *) Literal[Derivative[0,1][besselY]]:= Function[{n,x}, besselY[-1 + n, x] - (n*besselY[n, x])/x] D[besselY[n_,x_],x_]:=Derivative[0,1][besselY][n, x] D[besselY[n_, x_],{x_,k_}]:= D[D[besselY[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS 9.1.27 Seite 105 *) Literal[Derivative[0,1][besselJ]]:= Function[{n,x}, besselJ[-1 + n, x] - (n*besselJ[n, x])/x] D[besselJ[n_,x_],x_]:=Derivative[0,1][besselJ][n, x] D[besselJ[n_, x_],{x_,k_}]:= D[D[besselJ[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,1][hankel1]]:= Function[{n,x}, (hankel1[n-1,x] - (n/x) * hankel1[n,x]) ] D[hankel1[n_,x_],x_]:= Derivative[0,1][hankel1][n, x] D[hankel1[n_,x_],{x_,k_}]:=D[D[hankel1[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,1][hankel2]]:= Function[{n,x}, (hankel2[n-1,x] - (n/x) * hankel2[n,x]) ] D[hankel2[n_,x_],x_]:= Derivative[0,1][hankel2][n, x] D[hankel2[n_,x_],{x_,k_}]:=D[D[hankel2[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,0,1][kummerM]]:= Function[{a,b,x}, 1/x*((b-a)*kummerM[a-1,b,x]-(b-a-x)*kummerM[a,b,x])] D[kummerM[n_,m_,x_],x_]:= Derivative[0,0,1][kummerM][n, m, x] D[kummerM[n_,m_,x_],{x_,k_}]:=D[D[kummerM[n, m, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,0,1][kummerU]]:= Function[{a,b,x}, (- kummerU[a-1,b,x] + (a-b+x)*kummerU[a,b,x])/x] D[kummerU[n_,m_,x_],x_]:= Derivative[0,0,1][kummerU][n, m, x] D[kummerU[n_,m_,x_],{x_,k_}]:=D[D[kummerU[n, m, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,0,1][whittakerM]]:= Function[{n,m,x}, 1/(2*x)*((1+2*m-2*n)*whittakerM[n-1,m,x] + (2*n-x)*whittakerM[n,m,x])] D[whittakerM[n_,m_,x_],x_]:= Derivative[0,0,1][whittakerM][n, m, x] D[whittakerM[n_,m_,x_],{x_,k_}]:=D[D[whittakerM[n, m, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,0,1][whittakerW]]:= Function[{n,m,x}, 1/(4*x)*((1-4*m^2-4*n+4*n^2)*whittakerW[n-1,m,x] + (4*n-2*x)*whittakerW[n,m,x])] D[whittakerW[n_,m_,x_],x_]:= Derivative[0,0,1][whittakerW][n, m, x] D[whittakerW[n_,m_,x_],{x_,k_}]:=D[D[whittakerW[n, m, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* hypergeometric functions *) Literal[Derivative[0,1][hypergeometric0F1]]:= Function[{a,x}, hypergeometric0F1[1 + a, x]/a] D[hypergeometric0F1[a_,x_],x_]:= Derivative[0,1][hypergeometric0F1][a,x] D[hypergeometric0F1[a_,x_],{x_,k_}]:= D[D[hypergeometric0F1[a,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,0,1][hypergeometricU]]:= Function[{a,b,x}, 1/x*((b-a)*hypergeometricU[a-1,b,x]-(b-a-x)*hypergeometricU[a,b,x])] D[hypergeometricU[a_,b_,x_],x_]:= Derivative[0,0,1][hypergeometricU][a,b,x] D[hypergeometricU[a_,b_,x_],{x_,k_}]:= D[D[hypergeometricU[a,b,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,0,1][hypergeometric1F1]]:= Function[{a,b,x}, 1/x*((b-a)*hypergeometric1F1[a-1,b,x]-(b-a-x)*hypergeometric1F1[a,b,x])] D[hypergeometric1F1[a_,b_,x_],x_]:= Derivative[0,0,1][hypergeometric1F1][a,b,x] D[hypergeometric1F1[a_,b_,x_],{x_,k_}]:= D[D[hypergeometric1F1[a,b,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,1][hypergeometric1F0]]:= Function[{a,x}, a/(1-x)*hypergeometric1F0[a,x] ] D[hypergeometric1F0[a_,x_],x_]:= Derivative[0,1][hypergeometric1F0][a,x] D[hypergeometric1F0[a_,x_],{x_,k_}]:= D[D[hypergeometric1F0[a,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,0,1][hypergeometric2F0]]:= Function[{a,b,x}, a/x*(hypergeometric2F0[a+1,b,x]-hypergeometric2F0[a,b,x])] D[hypergeometric2F1[a_,b_,x_],x_]:= Derivative[0,0,1][hypergeometric2F0][a,b,x] D[hypergeometric2F0[a_,b_,x_],{x_,k_}]:= D[D[hypergeometric2F0[a,b,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS (15.2.3) *) Literal[Derivative[0,0,0,1][hypergeometric2F1]]:= Function[{a,b,c,x}, a/x*(hypergeometric2F1[a+1,b,c,x]-hypergeometric2F1[a,b,c,x])] D[hypergeometric2F1[a_,b_,c_,x_],x_]:= Derivative[0,0,0,1][hypergeometric2F1][a,b,c,x] D[hypergeometric2F1[a_,b_,c_,x_],{x_,k_}]:= D[D[hypergeometric2F1[a,b,c,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,1][struveH]]:= Function[{n,x}, (x*struveH[-1 + n,x] - n*struveH[n,x])/x ] D[struveH[n_,x_],x_]:=Derivative[0,1][struveH][n, x] D[struveH[n_, x_],{x_,k_}]:= D[D[struveH[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,1][struveL]]:= Function[{n,x}, (x*struveL[-1 + n,x] - n*struveL[n,x])/x ] D[struveL[n_,x_],x_]:=Derivative[0,1][struveL][n, x] D[struveL[n_, x_],{x_,k_}]:= D[D[struveL[n, x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* special examples article *) (* lower order preferred Literal[Derivative[0,1][ai]]:= Function[{n,x}, x*ai[n-1,x]+(n-1)*ai[n-2,x]] D[ai[n_,x_],x_]:= Derivative[0,1][ai][n,x] D[ai[n_,x_],{x_,k_}]:=D[D[ai[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) *) Literal[Derivative[0,1][ai]]:= Function[{n,x}, ai[n+1,x]] D[ai[n_,x_],x_]:= Derivative[0,1][ai][n,x] D[ai[n_,x_],{x_,k_}]:=D[D[ai[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,1][erfc]]:= Function[{n,x}, -erfc[n-1,x]] D[erfc[n_,x_],x_]:= Derivative[0,1][erfc][n,x] D[erfc[n_,x_],{x_,k_}]:=D[D[erfc[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[1][erfc]]:= Function[{x}, -2/(E^x^2*Pi^(1/2))] D[erfc[x_],x_]:= Derivative[1][erfc][x] D[erfc[x_],{x_,k_}]:=D[D[erfc[x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Literal[Derivative[0,1][expIntegralE]]:= Function[{n,x}, -expIntegralE[n-1,x]] D[expIntegralE[n_,x_],x_]:= Derivative[0,1][expIntegralE][n,x] D[expIntegralE[n_,x_],{x_,k_}]:=D[D[expIntegralE[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS (27.5) *) Literal[Derivative[0,1][abramowitz]]:= Function[{n,x}, -abramowitz[n-1,x]] D[abramowitz[n_,x_],x_]:= Derivative[0,1][abramowitz][n,x] D[abramowitz[n_,x_],{x_,k_}]:=D[D[abramowitz[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS (26.2.41) *) Literal[Derivative[0,1][NormalIntegral]]:= Function[{n,x},-NormalIntegral[n-1,x]] D[NormalIntegral[n_,x_],x_]:= Derivative[0,1][NormalIntegral][n,x] D[NormalIntegral[n_,x_],{x_,k_}]:=D[D[NormalIntegral[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* Knuth (10.23) *) Literal[Derivative[0,1][knuthA]]:= Function[{n,x},knuthA[n-2,x]/2-x^2*knuthA[n,x]/2] D[knuthA[n_,x_],x_]:= Derivative[0,1][knuthA][n,x] D[knuthA[n_,x_],{x_,k_}]:=D[D[knuthA[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* Knuth (10.6) *) Literal[Derivative[0,1][knuthB]]:= Function[{n,x},knuthB[n-2,x]/2] D[knuthB[n_,x_],x_]:= Derivative[0,1][knuthB][n,x] D[knuthB[n_,x_],{x_,k_}]:=D[D[knuthB[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS (19.6.2) *) Literal[Derivative[0,1][parabolicU]]:= Function[{n,x},-parabolicU[n-1,x]+x/2*parabolicU[n,x]] D[parabolicU[n_,x_],x_]:= Derivative[0,1][parabolicU][n,x] D[parabolicU[n_,x_],{x_,k_}]:=D[D[parabolicU[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* AS (19.6.5) *) Literal[Derivative[0,1][parabolicV]]:= Function[{n,x},(n-1/2)*parabolicV[n-1,x]+x/2*parabolicV[n,x]] D[parabolicV[n_,x_],x_]:= Derivative[0,1][parabolicV][n,x] D[parabolicV[n_,x_],{x_,k_}]:=D[D[parabolicV[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) (* using AS (19.3.1) *) Literal[Derivative[0,1][parabolicD]]:= Function[{n,x},-parabolicD[n+1,x]+x/2*parabolicD[n,x]] D[parabolicD[n_,x_],x_]:= Derivative[0,1][parabolicD][n,x] D[parabolicD[n_,x_],{x_,k_}]:=D[D[parabolicD[n,x],{x,k-1}],x]/; (IntegerQ[k] && k>1) Protect[D] (* end module derivatives *) (* begin module recursions *) reclist = { besselI[nnnnn,x] == besselI[nnnnn-2, x]-((2 (nnnnn-1))/x)*besselI[nnnnn-1, x], besselK[nnnnn, x] == besselK[-2 + nnnnn, x] + (2*(-1 + nnnnn)*besselK[-1 + nnnnn, x])/x, (* AS 9.6.26 Seite 120 *) besselJ[nnnnn,x] == -besselJ[-2 + nnnnn,x] + (2*(-1 + nnnnn)*besselJ[-1 + nnnnn, x])/x, besselY[nnnnn,x] == -besselY[-2 + nnnnn,x] + (2*(-1 + nnnnn)*besselY[-1 + nnnnn,x])/x, (* AS 9.1.27. Seite 105 *) expIntegralE[nnnnn, x] == (x*expIntegralE[-2 + nnnnn,x])/(-1 + nnnnn) + ((-2 + nnnnn - x)*expIntegralE[-1 + nnnnn,x])/(-1 + nnnnn), (* AS 5.1.14 *) (*7*) jacobiP[nnnnn, a, b, x] == ((-a + a^2 - b + 2*a*b - a^2*b + b^2 - a*b^2 - 2*nnnnn + 4*a*nnnnn - a^2*nnnnn + 4*b*nnnnn - 4*a*b*nnnnn - b^2*nnnnn + 4*nnnnn^2 - 3*a*nnnnn^2 - 3*b*nnnnn^2 - 2*nnnnn^3)*jacobiP[-2 + nnnnn,a,b,x])/ (nnnnn*(a + b + nnnnn)*(-2 + a + b + 2*nnnnn)) + ((-a^2 + a^3 + a^2*b + b^2 - a*b^2 - b^3 + 2*a^2*nnnnn - 2*b^2*nnnnn + 2*a*x - 3*a^2*x + a^3*x + 2*b*x - 6*a*b*x + 3*a^2*b*x - 3*b^2*x + 3*a*b^2*x + b^3*x + 4*nnnnn*x - 12*a*nnnnn*x + 6*a^2*nnnnn*x - 12*b*nnnnn*x + 12*a*b*nnnnn*x + 6*b^2*nnnnn*x - 12*nnnnn^2*x + 12*a*nnnnn^2*x + 12*b*nnnnn^2*x + 8*nnnnn^3*x)* jacobiP[-1 + nnnnn,a,b,x])/(2*nnnnn*(a + b + nnnnn)*(-2 + a + b + 2*nnnnn)), (*9*) gegenbauerC[nnnnn, b, x] == -(((-2 + 2*b + nnnnn)*gegenbauerC[-2 + nnnnn, b, x])/nnnnn)+ (2*(-1 + b + nnnnn)*x*gegenbauerC[-1 + nnnnn, b, x])/nnnnn, (*10*) chebyshevT[nnnnn, x] == -chebyshevT[-2 + nnnnn, x] + 2 x chebyshevT[-1 + nnnnn, x], (*11*) chebyshevU[nnnnn, x] == -chebyshevU[-2 + nnnnn, x] + 2 x chebyshevU[-1 + nnnnn, x], (*12*) chebyshevS[nnnnn, x] == -chebyshevS[-2 + nnnnn, x] + x chebyshevS[nnnnn-1, x], (*13*) chebyshevC[nnnnn, x] == -chebyshevC[-2 + nnnnn, x] + x chebyshevC[-1 + nnnnn, x], (*14*) chebyshevTstar[nnnnn, x] == -chebyshevTstar[-2 + nnnnn, x] + (-2 + 4 x) chebyshevTstar[-1 + nnnnn, x], (*15*) chebyshevUstar[nnnnn, x] == -chebyshevUstar[-2 + nnnnn, x] + (-2 + 4 x) chebyshevUstar[-1 + nnnnn, x], (*16*) (* legendreP[nnnnn, x] == -(((-1 + nnnnn)*legendreP[-2 + nnnnn, x])/nnnnn) + ((1 + 2*(-1 + nnnnn))*x*legendreP[-1 + nnnnn, x])/nnnnn, *) (*17*) legendreP[nnnnn, b, x] == (1 - b - nnnnn)/(-b + nnnnn)*legendreP[-2 + nnnnn, b, x] + (-1 + 2*nnnnn)*x/(-b + nnnnn)*legendreP[-1 + nnnnn, b, x], legendreQ[nnnnn, b, x] == ((1 - b - nnnnn)*legendreQ[-2 + nnnnn, b, x] + (-1 + 2*nnnnn)*x*legendreQ[-1 + nnnnn, b, x])/(-b + nnnnn), legendrePstar[nnnnn, x] == -(((-1 + nnnnn)*legendrePstar[-2 + nnnnn, x])/nnnnn) + ((-1 - 2*(-1 + nnnnn) + (2 + 4*(-1 + nnnnn))*x)* legendrePstar[-1 + nnnnn, x])/nnnnn, (*18*) laguerreL[nnnnn, a, x] == -(((-1 + a + nnnnn)*laguerreL[-2 + nnnnn, a, x])/nnnnn) + ((1 + a + 2*(-1 + nnnnn) - x)*laguerreL[-1 + nnnnn, a, x])/nnnnn, (* klappt noch nicht laguerreL[b, 1 + nnnnn, x] == -(((b + nnnnn)*laguerreL[b, -1 + nnnnn, x])/x) + ((nnnnn + x)*laguerreL[b, nnnnn, x])/x, *) (*19*) hermiteH[nnnnn, x] == -2 (-1 + nnnnn) hermiteH[-2 + nnnnn, x] + 2 x hermiteH[-1 + nnnnn, x], (*20*) hermiteHe[nnnnn, x] == -((-1 + nnnnn) hermiteHe[-2 + nnnnn, x]) + x hermiteHe[-1 + nnnnn, x], (* AS 22.7.1- 14, genau in der Reihenfolge *) (*21*) hankel1[nnnnn,x]== - hankel1[nnnnn-2,x] + (2*(nnnnn-1)/x)*hankel1[nnnnn-1,x], hankel2[nnnnn,x]== - hankel2[nnnnn-2,x] + (2*(nnnnn-1)/x)*hankel2[nnnnn-1,x], kummerM[nnnnn,b,x]== 1/(nnnnn-1)*((b-nnnnn+1)*kummerM[nnnnn-2,b,x] + (2*nnnnn-2-b+x)*kummerM[nnnnn-1,b,x]), kummerU[nnnnn,b,x]== -1/((nnnnn-1)*(nnnnn-b))* (kummerU[nnnnn-2,b,x] + (b-2*nnnnn+2-x)*kummerU[nnnnn-1,b,x]), whittakerM[nnnnn, b, x] == (3+2*b-2*nnnnn)/(2*b+2*nnnnn-1)*whittakerM[nnnnn-2,b,x]+ (4*nnnnn-4-2*x)/(2*b+2*nnnnn-1)*whittakerM[nnnnn-1,b,x], whittakerW[nnnnn, b, x] == (3/2 + b - nnnnn)*(-3/2 + b + nnnnn)* whittakerW[-2 + nnnnn,b,x]-(2*(-1+nnnnn)-x)*whittakerW[-1+nnnnn,b,x], bateman[nnnnn,x] == (2 - nnnnn)/nnnnn*bateman[nnnnn-2,x] + ((2*(-1 + nnnnn) - 2*x)/nnnnn) * bateman[nnnnn-1,x], (* hypergeometric functions *) hypergeometric0F1[nnnnn, x] == (-2 + nnnnn)*(-1 + nnnnn)/x*hypergeometric0F1[-2 + nnnnn, x]- (-2 + nnnnn)*(-1 + nnnnn)/x*hypergeometric0F1[-1 + nnnnn, x], (* AS (15.2.10) *) (* verified *) hypergeometricU[nnnnn,b,x]== 1/(nnnnn-1)*((b-nnnnn+1)*hypergeometricU[nnnnn-2,b,x] + (2*nnnnn-2-b+x)*hypergeometricU[nnnnn-1,b,x]), hypergeometric1F1[nnnnn,b,x]== (b-nnnnn+1)/(nnnnn-1)*hypergeometric1F1[nnnnn-2,b,x] + (2*nnnnn-2-b+x)/(nnnnn-1)*hypergeometric1F1[nnnnn-1,b,x], (* verified *) hypergeometric2F0[nnnnn,b,x]== -1/(-x + nnnnn*x)*hypergeometric2F0[nnnnn-2,b,x]+1/(-x + nnnnn*x)* (1-x+nnnnn*x-b x)*hypergeometric2F0[nnnnn-1,b,x], hypergeometric2F1[nnnnn,b,c,x] == -1/((nnnnn-1)*(x-1))* ((2*(nnnnn-1)-c-(nnnnn-1)*x+b*x)*hypergeometric2F1[nnnnn-1,b,c,x]+ (c-nnnnn+1)*hypergeometric2F1[nnnnn-2,b,c,x]), (* AS (12.1.9)-(12.1.10) *) struveH[nnnnn,x]== (x^2*struveH[-3 + nnnnn,x] + 5*x*struveH[-2 + nnnnn,x] - 4*nnnnn*x*struveH[-2 + nnnnn,x] + 2*struveH[-1 + nnnnn,x] - 6*nnnnn*struveH[-1 + nnnnn,x] + 4*nnnnn^2*struveH[-1 + nnnnn,x] + x^2*struveH[-1 + nnnnn,x])/(-x + 2*nnnnn*x), (* AS (12.2.4)-(12.2.5) *) struveL[nnnnn, x] == (-(x*struveL[-3 + nnnnn, x]) + (-1 + 4*(-1 + nnnnn))*struveL[-2 + nnnnn, x] + ((-2*(-1 + nnnnn) - 4*(-1 + nnnnn)^2 + x^2)*struveL[-1 + nnnnn, x])/x)/ (1 + 2*(-1 + nnnnn)), (*22*) (* special examples article *) ai[nnnnn,x]==x*ai[nnnnn-2,x]+(nnnnn-2)*ai[nnnnn-3,x], (*23*) (* AS (7.2) *) erfc[nnnnn,x]==1/(2*nnnnn)*erfc[nnnnn-2,x]-x/nnnnn*erfc[nnnnn-1,x], (* AS (27.5) *) abramowitz[nnnnn,x]==(nnnnn-1)/2*abramowitz[nnnnn-2,x]+x/2*abramowitz[nnnnn-3,x], (* AS (26.2.44) *) NormalIntegral[nnnnn,x]== 1/nnnnn*(NormalIntegral[nnnnn-2,x]-x*NormalIntegral[nnnnn-1,x]), (* Knuth (10.22) *) knuthA[nnnnn,x]== x*knuthA[nnnnn-2,x]/(nnnnn-2)+knuthA[nnnnn-3,x]/(nnnnn-2), (* Knuth (10.25) *) knuthB[nnnnn,x]== x*knuthB[nnnnn-2,x]/(nnnnn-2)+knuthB[nnnnn-3,x]/(nnnnn-2), (* AS (19.6.4) *) parabolicU[nnnnn, x]== -2*parabolicU[-2+nnnnn,x]/(1-2*nnnnn) + 2*x*parabolicU[-1+nnnnn,x]/(1-2*nnnnn), (* AS (19.6.8) *) parabolicV[nnnnn, x]== (-3 + 2*nnnnn)/2*parabolicV[-2 + nnnnn, x] + x*parabolicV[-1 + nnnnn, x], (* using AS (19.3.1) *) parabolicD[nnnnn, x]== parabolicD[-2 + nnnnn, x] - nnnnn*parabolicD[-2 + nnnnn, x] + x*parabolicD[-1 + nnnnn, x] } (* end module recursions *) (* Simplification Rules for Factorial, Binomial, Product *) (* combinas.m /DOS *) (* Copyright 1988 Wolfram Research Inc. *) (* by Roman Maeder *) (* plus some own parts *) protection = Unprotect[Factorial, Binomial, Product,Gamma] Factorial/: (n_)!/(m_)! := Product[i, {i, m+1, n}] /; Simplify[n-m] > 0 && IntegerQ[Simplify[n-m]] Factorial/: (n_)!/(m_)! := 1/Product[i, {i, n+1, m}] /; Simplify[m-n] > 0 && IntegerQ[Simplify[m-n]] Binomial/: Binomial[n_, k_]/Binomial[n_, k1_] := (n-k+1)/k /; k1 == k-1 Binomial/: Binomial[n_, k1_]/Binomial[n_, k_] := k/(n-k+1) /; k1 == k-1 Product/: Product[t_, {x_, a_, n_, 1}]/Product[t_, {x_, a_, n1_, 1}] := (t /. x-> n) /; n1 == n-1 Product/: Product[t_, {x_, a_, n1_, 1}]/Product[t_, {x_, a_, n_, 1}] := 1/(t /. x-> n) /; n1 == n-1 Product[i_,{i_,i1_,i2_}]:=i1*Product[i,{i,i1+1,i2}] /; Simplify[i2-i1]>0 && IntegerQ[Simplify[i2-i1]] Product[i_,{i_,i1_,i2_}]:=i1 /; Simplify[i2-i1]==0 (* currently Gamma/: Gamma[a_]*Gamma[b_]:=Module[{x=1-b,k=a+b}, Pi/Sin[Pi*(1-x)]*Pochhammer[x,k-1]]/;(*(Simplify[a+b]>0) && *) IntegerQ[Simplify[a+b]] *) Protect[Release[protection]] (* end of combinas.m *) (* begin Algebraic package *) AlgebraicDE[F_,y_[x_]]:=AlgebraicDE[F,x,y] AlgebraicDE[F_,x_,y_]:=Module[ (* Clear as much as possible *) {n,k,j,z}, Clear[list,values]; plugin[expr_,form_,order_]:=Module[{level}, level=Length[CoefficientList[expr,y[x]]]-1; If[level>=order,plugin[Expand[expr /. y[x]^level->y[x]^(level-order)*form[[1,1,2]]],form,order], expr] ]; If[FreeQ[F,y[x]],eq=(F /. y->y[x]),eq=F]; If[SameQ[Head[F],Equal],eq=Expand[eq[[1]]-eq[[2]]]==0,eq=Expand[eq]==0]; order=Length[CoefficientList[eq[[1]],y[x]]]-1; y0=(Solve[eq /. y[x]^order->z,z] /. z->y[x]^order); eqlist={}; ylist={}; (* normalization done *) (* first order *) AppendTo[eqlist,D[eq,x]]; AppendTo[ylist,Solve[eqlist[[1]],y'[x]][[1,1]]]; term=Cancel[Together[ExpandAll[ylist[[1,2]]/y[x]] /. {y0[[1,1]],y[x]^(-order)->1/y0[[1,1,2]]}]]; If[FreeQ[term,y[x]], Return[Denominator[term] y'[x]-Numerator[term] y[x]==0]]; Print["No differential equation of order ",1," found"]; (* higher order *) (* for n=2 to order *) Do[ AppendTo[eqlist,D[eqlist[[n-1]],x]]; AppendTo[ylist,Solve[eqlist[[n]],Derivative[n][y][x]][[1,1]]]; setting=Sum[A[k] Derivative[k][y][x] /. A[n]->1,{k,0,n}]; intermediate=setting; Do[intermediate=Numerator[Together[intermediate /. ylist[[k]]]], {k,n,1,-1}]; solution=plugin[intermediate,y0,order]; Clear[intermediate]; list=CoefficientList[solution,y[x]]; Clear[solution]; values=Solve[list==Table[0,{k,1,Length[list]}],Table[A[k],{k,0,n-1}]]; If[n==order && values=={},Print["AlgebraicDE: Solve command fails"]]; If[Not[values=={}], Return[Map[Factor,Collect[Numerator[Together[setting /. values[[1]]]],Derivative[_][y][x]]]==0]]; Print["No differential equation of order ",n," found"] , {n,2,order}] ] AlgebraicDEDirect[F_,x_,y_[x_]]:=AlgebraicDEDirect[F,x,y] AlgebraicDEDirect[F_,x_,y_]:=Module[ (* highest order only *) (* Clear as much as possible *) {n,k,l,z}, Clear[list,values]; plugin[expr_,form_,order_]:=Module[{level}, level=Length[CoefficientList[expr,y[x]]]-1; If[level>=order,plugin[Expand[expr /. y[x]^level->y[x]^(level-order)*form[[1,1,2]]],form,order], expr] ]; If[FreeQ[F,y[x]],eq=(F /. y->y[x]),eq=F]; If[SameQ[Head[F],Equal],eq=Expand[eq[[1]]-eq[[2]]]==0,eq=Expand[eq]==0]; order=Length[CoefficientList[eq[[1]],y[x]]]-1; y0=(Solve[eq /. y[x]^order->z,z] /. z->y[x]^order); eqlist={}; ylist={}; (* normalization done *) AppendTo[eqlist,D[eq,x]]; AppendTo[ylist,Solve[eqlist[[1]],y'[x]][[1,1]]]; Do[ AppendTo[eqlist,D[eqlist[[n-1]],x]]; AppendTo[ylist,Solve[eqlist[[n]],Derivative[n][y][x]][[1,1]]], {n,2,order}]; setting=Sum[A[k] Derivative[k][y][x] /. A[order]->1,{k,0,order}]; intermediate=setting; Do[intermediate=Numerator[Together[intermediate /. ylist[[k]]]], {k,order,1,-1}]; solution=plugin[intermediate,y0,order]; Clear[intermediate]; list=CoefficientList[solution,y[x]]; Clear[solution]; values= Solve[list==Table[0,{k,1,Length[list]}],Table[A[k],{k,order-1,0,-1}]]; If[Not[values=={}], Return[DEout[Numerator[Together[setting /. values[[1]]]],y,x]]]; Print["No differential equation of order ",order," found"] ] (* end Algebraic package *) Clear[ComplexFactor,ComplexApart] (* complex factorization and partial fraction decomposition *) ComplexFactor[f_,x_]:=Module[ {knum,kden,ff,p,q,solvenum,solveden,tablenum,tableden, settingnum,settingden,coeffnum,coeffden}, Off[Part::selectform]; ff=Together[f]; p=Numerator[ff]; q=Denominator[ff]; solvenum=Sort[Simplify[Solve[p==0,x]]]; tablenum=Table[x-solvenum[[k,1,2]],{k,1,Length[solvenum]}]; settingnum=Product[tablenum[[k]],{k,1,Length[solvenum]}]; solveden=Sort[Simplify[Solve[q==0,x]]]; tableden=Table[x-solveden[[k,1,2]],{k,1,Length[solveden]}]; settingden=Product[tableden[[k]],{k,1,Length[solveden]}]; coeffnum=Simplify[p/settingnum]; coeffden=Simplify[q/settingden]; (coeffnum*settingnum)/(coeffden*settingden) ] (* complex partial fraction decomposition *) ComplexApart[f_,x_]:=Module[ {ff,p,q,r,pp,solve,setting,k,exponent,list,sol,complex}, ff=Together[f]; p=Numerator[ff]; q=Denominator[ff]; r=PolynomialQuotient[p,q,x]; pp=p-q*r; solve=Sort[Simplify[Solve[q==0,x]]]; setting=coeff[1]/(x-solve[[1,1,2]]); complex=False; If[Length[solve]>1, Do[If[solve[[k,1,2]]==solve[[k-1,1,2]], (exponent=1; While[exponent=2) ComplexApart[f_,x_]:=Module[ {complexapart,g}, complexapart[g_]:=ComplexApart[g,x]; Map[complexapart,Apart[f,x]] ] (* Simplifications of the Pochhammer symbols *) ClearAttributes[Pochhammer,Protected] Pochhammer[1/2,k_-1]:= 2 Pochhammer[1/2,k] / (2k-1) Pochhammer[1/2,k_] := (2k)!/(4^k*k!) Pochhammer[n_,k_] := (n+k-1)!/(n-1)! /; (IntegerQ[n] && n>=0) Pochhammer[n_,k_] := (-1)^k (-n)! / ((-n)-k)! /; (IntegerQ[-n] && (-n)>=0) Pochhammer[a_,k_] := Pochhammer[2*a-1,2k]/ (4^k* Pochhammer[(2*a-1)/2,k]) /; (Head[a]==Rational && IntegerQ[a+1/2] && a>0) Pochhammer/: Pochhammer[a_,k_]*Pochhammer[b_,k_] := Pochhammer[2a,2k]/4^k /; (Simplify[b-a]==1/2) Pochhammer[a_,k_] := Module[{anzahl}, anzahl = -a+1/2; (-1)^anzahl Pochhammer[1-a-anzahl,anzahl] * Pochhammer[a+anzahl,k-anzahl] ] /; (Head[a]==Rational && IntegerQ[a+1/2] && a<0) Pochhammer/: Pochhammer[z_Complex,k_]*Pochhammer[cz_Complex,k_] := Product[(Re[z]+(jj-1))^2+Im[z]^2,{jj,k}] /; SameQ[z,Conjugate[cz]] Pochhammer/: Pochhammer[1/3,k_]*Pochhammer[2/3,k_]:=(3k)!/(k!*27^k) Pochhammer/: Pochhammer[2/3,k_]*Pochhammer[4/3,k_]:= (1 + 3*k)!/(27^k*k!) (* Pochhammer/: Pochhammer[b_,k_]*Pochhammer[c_,k_]:= Pochhammer[3b,3k]/(27^k Pochhammer[b+2/3,k]) /; (Simplify[c-b]==1/3 && IntegerQ[Simplify[b-1/3]] && Not[Simplify[b-1/3]==0]) Pochhammer/: Pochhammer[1/4,k_]*Pochhammer[1/2,k_]*Pochhammer[3/4,k_]:= (4k)!/(k! 64^k) Pochhammer/: Pochhammer[1/5,k_]*Pochhammer[2/5,k_]*Pochhammer[3/5,k_]* Pochhammer[4/5,k_]:=(5k)!/(k! 3125^k) Pochhammer/: Pochhammer[2/5,k_]*Pochhammer[3/5,k_]*Pochhammer[4/5,k_]* Pochhammer[6/5,k_]:=(5*(1/5 + k)*(5*k)!)/(3125^k*k!) Pochhammer/: Pochhammer[3/5,k_]*Pochhammer[4/5,k_]*Pochhammer[6/5,k_]* Pochhammer[7/5,k_]:=(25*(1/5 + k)*(2/5 + k)*(5*k)!)/(2*3125^k*k!) Pochhammer/: Pochhammer[4/5,k_]*Pochhammer[6/5,k_]*Pochhammer[7/5,k_]* Pochhammer[8/5,k_]:=(125*(1/5 + k)*(2/5 + k)*(3/5 + k)*(5*k)!)/ (6*3125^k*k!) Pochhammer/: Pochhammer[6/5,k_]*Pochhammer[7/5,k_]*Pochhammer[8/5,k_]* Pochhammer[9/5,k_]:=(625*(1/5 + k)*(2/5 + k)*(3/5 + k)*(4/5 + k)* (5*k)!)/(24*3125^k*k!) *) Pochhammer/: Pochhammer[a_,k_]/Pochhammer[b_,k_]:=(a+k-1)/(a-1) /; Simplify[a-b]==1 Pochhammer/: Pochhammer[a_,k_]/Pochhammer[b_,k_]:=(b-1)/(b+k-1) /; Simplify[b-a]==1 Protect[Pochhammer] Clear[PowerSeries,PS,AsymptPowerSeries] Series[function_,{x_,x0_}]:=PowerSeries[function,x,x0] Protect[Series] PowerSeries[function_,{x_,x0_}]:=PowerSeries[function,x,x0] PowerSeries[function_,x_]:= PowerSeries[function,x,0] PowerSeries[function_,x_,x0_]:=Module[{}, Print["specfun-info: ",InputForm[x]," is not a valid variable."]; HoldForm[PowerSeries[function,x,x0]]]/;!SameQ[Head[x],Symbol] PowerSeries[function_,x_,x0_]:=Module[{}, Print["specfun-warning: Please Clear[f] before using PowerSeries."]; HoldForm[PowerSeries[function,x,x0]]]/;SpecialFunctionsPrintMessages&& (!SameQ[ToString[Head[Global`f[anything___]]],"f"]|| Not[SameQ["f",ToString[Global`f]]]) PowerSeries[function_,x_,x0_]:=Module[{}, Print["specfun-warning: Please Clear[jj] before using PowerSeries."]; HoldForm[PowerSeries[function,x,x0]]]/; Not[SameQ["jj",ToString[Global`jj]]] (* formal Laurent series at the point zero *) PowerSeries[function_,x_,0]:=Module[ { (* variables are local with respect to the package *) subtemp,init,shift,xpotenz,simplesummand,result,recursfac,recnomil,recdomil, summand,recnomil0,recdomil0,ddff,ex,pmax,nmax,conomi,domi,dep,de, listzero,listvar,difflist,sum,finalsum,testlist,list,equ,lnew,length, aa,j,i,solution,denomil,sollist,mmm,p,(*n,*)errorval,(*a,*) lcm,nn, tempre,subst,de00,re00,recoefflist,varlist,re,re01,reseparation, reanalysis,maxd,reprodsum,findd,higherd,plus1,part12,term,exp,fac,poch,findpoch, restart,tresult,presum,gcd,gcdindex,ninit,redenomi (* *) }, If[SpecialFunctionsPrintMessages, Print[specfuninfo] ]; presum=0; tresult=0; restart=0; subst[g_+h_,x,a_]:=subst[g,x,a]+subst[h,x,a]; subst[c_*g_,x,a_]:=c*subst[g,x,a] /; FreeQ[c,x] && FreeQ[c,f]; subst[diff[f,x,k0_],x,a_]:=Pochhammer[k+1,k0]*a[k+k0]; subst[diff[f,x],x,a_]:=(k+1)*a[k+1]; subst[f,x,a_]:=a[k]; subst[x^j_.*diff[f,x,k0_],x,a_]:=Pochhammer[k+1-j,k0]*a[k+k0-j]; subst[x^j_.*diff[f,x],x,a_]:=(k+1-j)*a[k+1-j]; subst[x^j_.*f,x,a_]:=a[k-j]; subst[g_,x,a_]:=subst[Expand[g],x,a] /; (Head[g]==Times); SetAttributes[ratalgo,HoldFirst]; makecoeff[c_./(d_.x+b___)]:= -c/d (-d/b)^(k+1); anapoly[c_./(d_.x+b1_.+b2_.)]:= Module[{}, If[SameQ[b1+b2,0], {{},c/(d*x)}, {{-c/d (-d/(b1+b2))^(k+1)},0 } ] ]; anapoly[c_.*((d_.x+b1_.+b2_.)^(b3_.))]:= Module[{}, If[SameQ[b1+b2,0], {{},c(d*x)^b3}, {{c(-d)^b3 (-d/(b1+b2))^(k-b3) Binomial[-b3+k-1,k]},0 } ] ]/;IntegerQ[b3] && Negative[b3]; anapoly[p_]:=Module[{ap1,ap2,r1,r2,pr1,pr2}, ap1=First[p];ap2=Rest[p]; {r1,pr1}=anapoly[ap1]; {r2,pr2}=anapoly[ap2]; Return[{Join[r1,r2],pr1+pr2}] ]/;SameQ[Head[p],Plus]; anapoly[pp_] := {{} ,pp}; ratalgo[poly_] := Module[{}, fp=Simplify[Together[poly]]; If[Not[ PolynomialQ[Numerator[fp],x] && PolynomialQ[Denominator[fp],x] ], Return[False] ]; afp0=ComplexApart[poly,x]; If[SameQ[poly,afp0], If[SpecialFunctionsPrintMessages, Print["specfun-info: rational algorithm applied"]], If[SpecialFunctionsPrintMessages, Print["specfun-info: rational algorithm applied (",poly, " = ",afp0,")"]] ]; afp =Map[Simplify,afp0]; {tfp,presum}=anapoly[afp/.introducei]; mfp=Simplify[tfp]; mfp1=Apply[Plus,mfp]; mfp2=complexfactor[mfp1]; mfp3=complexmod[mfp2]; mfp4=Simplify[mfp3 /.introducei]; mfp5=simple[mfp4]; mfp6=simple[Together[mfp5]]; mfp7=complexfactor[Map[simple,Expand[mfp6]]]; simplesummand[1]=Simplify[mfp7]; ex[1]=k; prepprint; (*prettyprint[poly];*) returnval=tresult; Return[True] ]; (* initialisations for pretty-print *) prepprint:=Module[{}, xpotenz[1]=x^ex[1]; tresult= presum + If[SameQ[simplesummand[1],0],0, Global`sum[simplesummand[1] xpotenz[1],{k,0,Infinity}]]; rparts=1; psstart=0; border=Infinity; ]; (* enhanced limit functions *) limit[a_,b_] := Module[{l,r,r2,length}, Off[Limit::nlm,Power::infy,Infinity::indet]; r=a/.b; If[undefined[r], If[asympt, l=Limit[a,b,Direction ->-1], l=Limit[a,b] ]; If[Not[SameQ[Head[l],Limit]], r=l], (* else *) r2= r/.transformspecial1; If[!SameQ[r,r2], If[asympt, l=Limit[a,b,Direction ->-1], l=Limit[a,b] ]; If[Not[SameQ[Head[l],Limit]], r=l] ] ](* if undefined *); On[Limit::nlm,Power::infy,Infinity::indet]; Return[r] ]; Clear[ListOfIndependentTerms]; ListOfIndependentTerms[list1_,xx_]:= Module[{lnew, length,first,fraction,sum,i}, lnew = {}; length = Length[list1]; first = list1[[1]]; sum = first; For[i=2, i<=length, i++, fraction = Factor[Cancel[first/list1[[i]]]]; If [RationalQ[fraction,xx], sum += list1[[i]], (* rat. dependent *) AppendTo[lnew,list1[[i]]] (* rat. indep *) ] (* if *) ]; (* for *) Flatten[{sum,ListOfIndependentTerms[lnew,xx]}] ]/;(Length[list1]>1); ListOfIndependentTerms[list1_,xx_]:= Flatten[{list1}]/;(Length[list1]<2); lcm[{}]:=1; lcm[a_]:=Module[{j}, PolynomialLCM[First[a],lcm[Rest[a]]] ]; (* polynomial expansion with complex zeros *) factorcomplexlist[{e_List,r___List}]:= Module[{}, Join[ factorcomplexlist[e],factorcomplexlist[{r}] ]]; factorcomplexlist[{}]:= {}; factorcomplexlist[{npoly___,expo_}]:={{npoly,expo}}/; (Exponent[npoly,k]<2); factorcomplexlist[{npoly___,expo_}]:= Module[{coeff,list,newpoly,r}, coeff=Coefficient[npoly,k,2]; list={{coeff,expo}}; newpoly=Simplify[npoly/coeff]; r=Join[list,factorcomplexlist[{newpoly,expo}]]; Return[r] ] /; Exponent[npoly,k]==2 && Coefficient[npoly,k,2]!=1; factorcomplexlist[{npoly___,expo_}]:= Module[{sol,r1,r2}, sol=Solve[npoly==0,k]; r1={Simplify[k-sol[[1,1,2]]],expo}; r2={Simplify[k-sol[[2,1,2]]],expo}; Return[{r1,r2}] ] /; Exponent[npoly,k]==2 && Coefficient[npoly,k,2]==1; (* test: are all coefficients of the DE constant? -> True, else -> False *) decoefconst[detest_] := Module[{}, devarl1 = Variables[detest]; devarl2 = Union[Cases[devarl1,f], Cases[devarl1,diff[f,x]], Cases[devarl1,diff[f,x,_]] ]; decoefflist = Coefficient[detest,#]& /@ devarl2; logiclist = Map[freex,decoefflist]; Return[Apply[And,logiclist]] ]; (* pattern for the hypergeometric series *) findpoch[c_.*k+s_.] := {c,s/c}; (* transformation of RE in RE of derivative function *) diffre[re_] := (re/.k->k+redenomi) /.a[k+mx_.]->a[k+mx-redenomi]/(k+mx); (* simplifications of rational expressions *) simple[(Pochhammer[a_,k_])/Pochhammer[b_,k1_]]:= simple[Product[a+ii,{ii,0,k-1}] /(Product[b+ii,{ii,0,k-1}])]/;Equal[k-k1,0]; (* momentan raus simple[e_^(b_*c_)*d_.] := simple[(e^b)^c * d] /; IntegerQ[e] && IntegerQ[b]; *) simple[(-1)^(2 e_)*c_.] := simple[c]; simple[(e__^k__*b__^k__)*c___] := Module[{},ax=Expand[e b]; If[SameQ[ax,e*b],(ax)^k*c, simple[(ax)^k*c] ] ]; simple[(e__^k__/b__^k__)*c___] := simple[(e/b)^k*c]; simple[e_*b_] := e*b /; FreeQ[e,_^k] || FreeQ[b,_^k]; simple[e_./b_] := e/b /; FreeQ[e,_^k] || FreeQ[b,_^k]; simple[Sqrt[b_]*c___] := Sqrt[-b] * I * simple[c] /; IntegerQ[-b]; simple[e_] := e ; (* simple[e_]:=FullSimplify[e]; *) (* CHANGE *) (* bring the RE in canonical form *) reseparation[tempre_]:=Module[{v,c}, v=Cases[Variables[tempre],a[__]]; c=Simplify[Coefficient[Expand[tempre],#]& /@ v]; Return[{c,v}] ]; (* analyse the RE *) reanalysis[coefflist_,varlist_] := Module[{i}, (* normalize and sort the RE: k is smallest index, sum starts with largest index *) l = Length[varlist]; mind = findd[varlist[[1]]]; For [i=2, i<=l, i++, mind= Min[findd[varlist[[i]]],mind]]; nrecoefflist = Simplify[coefflist /. k -> k-mind]; nvarlist = varlist /. k -> k-mind; nrelist = nrecoefflist*nvarlist; nnrelist= Sort[nrelist,higherd]; maxd = findd[nnrelist[[1]]]; leadco = Simplify[nnrelist[[1]]/a[k+maxd]]; reprod = Simplify[-Rest[nnrelist]/leadco]; reprodsum = Factor[Apply[Plus,reprod]]; gcd = PolynomialGCD[Apply[Plus,-Rest[nnrelist]],leadco]; nnrelist = Cancel[nnrelist/gcd]; (* initialization of RE *) rinitsol = Simplify[Solve[leadco==0,k]]; rinitlist0=Map[part12,rinitsol]; rinitlist= Map[plus1,rinitlist0]; For [rri=1;condlist={},rri<=Length[rinitlist],rri++, Which[SameQ[ Head[rinitlist[[rri]]//N], Complex], rinitlist[[rri]]=0, (* complex zero *) Not[NumberQ[ rinitlist[[rri]] //N ]], AppendTo[condlist,rinitlist[[rri]]]; rinitlist[[rri]]=0, (* variable zero *) SameQ[Head[rinitlist[[rri]]],Rational], redenomi=Denominator[rinitlist[[rri]]] ] ]; ninit = If [rinitsol=={}, 0, Max[rinitlist] ]; restart = If [rinitsol=={}, 0, Max[rinitlist] ]; Do [Print["specfun-warning: ",condlist[[rrii]]," < ",ninit+1," is assumed"], {rrii,Length[condlist]} ]; If[SpecialFunctionsPrintMessages, Print["specfun-info: RE for all k >= ",InputForm[restart/.k-> Global`k] ,":"]]; If[SpecialFunctionsPrintMessages, Print[" a[",(Global`k+maxd),"] = ",InputForm[reprodsum/. {k->Global`k,a->Global`a}]]] ]; RE (* global *) = a[k+maxd]==reprodsum; (* invert RE *) reinverse:=Module[{}, (* representation of inverted RE *) ileadco = Simplify[nnrelist[[2]]/a[k]]; ireprod = Simplify[-nnrelist[[1]]/ileadco]; (* initialization of inverted RE *) irinitsol = Solve[ileadco==0,k]; irinitlist= If[SameQ[irinitsol,{{}}], {}, Map[part12,irinitsol]]; For[ll=1,ll<=Length[irinitlist],ll++, lv:=irinitlist[[ll]]; If[Not[NumberQ[lv]] || SameQ[Head[lv],Complex], irinitlist[[ll]]=Infinity ] ]; restop = Min[ Append[irinitlist,Infinity] ] ]; (* auxiliary functions *) findd[c_. * aa_[k]] := 0; findd[c_. * aa_[k+d_.]] := d; higherd[z_,y_] := findd[z] > findd[y]; plus1[pp___]:=pp + 1; part12plus1[pp___]:=Part[pp,1,2] + 1; part12[pp___]:=Part[pp,1,2]; introducei = Sqrt[qq_Integer?Negative] :> Sqrt[-qq] I; introducei2 = sqrt[-1] -> I; introducesqrt = c_Complex -> Re[c] + Im[c] Sqrt[-1]; introducesqrt2 = c_Complex -> Re[c] + Im[c] sqrt[-1]; factor[z_] := Factor[z//.introducesqrt] //. introducei; complexfactor[z_] := Factor[z//.introducesqrt2] //. introducei2; freex[t_] := FreeQ[t,x]; undefined[z_] := SameQ[Head[z],DirectedInfinity] || SameQ[z,Indeterminate] || MemberQ[Map[Head,Level[z,-1]],DirectedInfinity] || MemberQ[Level[z,-1],Indeterminate]; (* internal argument funktion *) arg[z_Real] := 0 /; z > 0; arg[z_Real] := Pi /; z < 0; arg[z_Complex] := Which[SameQ[z,0], Indeterminate, SameQ[Re[z],0], ArcSin[Im[z]/Abs[z]], Re[z] > 0, ArcTan[Im[z]/Re[z]], Re[z] < 0 && Im[z]>0,ArcTan[Im[z]/Re[z]]+Pi, True , ArcTan[Im[z]/Re[z]]-Pi ]; arg[a_.+b_Complex d_.] := Which[SameQ[a,0] && SameQ[Im[b],0], Indeterminate, SameQ[a,0], ArcSin[Im[b] d/abs[a+b d]], True, ArcTan[Im[b] d/a] ] /; SameQ[Re[b],0]; (* arg[y_]:=Arg[y]; *) abs[z_Complex] := Abs[z]; abs[a_.+b_Complex d_.] := Sqrt[a^2+(Im[b] d)^2] /; SameQ[Re[b],0]; abs[y_] := Abs[y]; (* simplification of complex expressions *) complexmod[((z_Complex)^k_ - (y_Complex)^k_) c_.] := Module[{}, c 2 I Abs[z]^k Sin[k arg[z]] ]/; SameQ[z,Conjugate[y]] && Positive[Re[z]] && Not[SameQ[Head[arg[z]],ArcTan]]; complexmod[((z_Complex)^k_ - (y_Complex)^k_) c_.] := Module[{}, (-1)^k c complexmod[(-z)^k - (-y)^k] ]/; SameQ[z,Conjugate[y]] && Negative[Re[z]] && Not[SameQ[Head[arg[-z]],ArcTan]]; complexmod[((a_.+ b1_Complex d_.)^k_ - (a_.+ b2_Complex d_.)^k_) c_.] := c 2 I abs[a+b1 d]^k Sin[k arg[a+b1 d]] /; Positive[a] && SameQ[b1,-b2] && Not[SameQ[Head[arg[a+b1 d]],ArcTan]]; complexmod[((a_.+ b1_Complex d_.)^k_ - (a_.+ b2_Complex d_.)^k_) c_.] := (-1)^k c complexmod[(-a+b1 d)^k - (-a+b2 d)^k] /; Negative[a] && SameQ[b1,-b2] && Not[SameQ[Head[arg[a+b1 d]],ArcTan]]; complexmod[((z_Complex)^k_ + (y_Complex)^k_) c_.] := c 2 abs[z]^k Cos[k arg[z]] /; Not[SameQ[Head[arg[z]],ArcTan]]; complexmod[((a_.+ b1_Complex d_.)^k_ + (a_. + b2_Complex d_.)^k_) c_.] := c 2 abs[a+b1 d]^k Cos[k arg[a+b1 d]] /; SameQ[b1,-b2] && Not[SameQ[Head[arg[a+b1 d]],ArcTan]]; complexmod[z___] := z; (* integration of a sum *) fintegrate[simsum_,xex_,psum_,origin_]:= Module[{(*const,singular,tsimsum,txex,tpsum*)}, {tsimsum,txex,tpsum}={simsum,xex,psum}; singular=Integrate[ tsimsum * x^txex /.k->0 ,x]; const=limit[origin-singular,x->0]; If[presum==0,tpsum = tpsum + singular + const, tpsum = tpsum + singular]; txex=txex+1; tsimsum=tsimsum/txex; tsimsum=Simplify[simple[tsimsum]]; Return[{tsimsum,txex,tpsum}] ]; Recoefconst[dflist1_]:=Module[{ i,i1,i2,i3,i4,form,solve,equlist0,df,length}, length = Length[dflist1]; df[0]=dflist1[[1]]; For[i=1,i<=length+restart-1,++i,df[i] =D[df[i-1],x]]; solve = Solve[Apply[Plus,nnrelist5]==0,x] //. introducei; len = Length[solve] - 1; varlist = Table[ai[i1],{i1,0,len}]; Do[xi[i4] = Simplify[solve[[i4+1,1,2]]]; bi[i4] = limit[df[i4+restart],x->0], {i4,0,len} ]; form = Sum[ai[i2] xi[i2]^k, {i2,0,len}]; equlist0 = {}; equlistr = Table[bi[i3]==(form//.k->i3+restart), {i3,0,len}]; equlist = Join[equlist0,equlistr]; solve2 = Solve[equlist,varlist]; summand[1]= First[form/k! /. solve2] ]; (* pretty print, disabled *) SetAttributes[prettyprint,HoldFirst]; (*prettyprint[fkt_]:=Module[{}, output={" "}; If [Not[SameQ[presum,0]],AppendTo[output,presum]]; For [prlauf=1,prlauf<=rparts,prlauf++, If[ (prlauf>1 || Not[SameQ[presum,0]]) && Not[SameQ[simplesummand[prlauf],0]], AppendTo[output," + "] ]; AppendTo[output, Which [SameQ[simplesummand[prlauf],0], "", True,ColumnForm[{border,"----",">","----", SequenceForm["k = ",psstart," "] }, Left,Center ] ] ]; AppendTo[output, Which [(SameQ[simplesummand[prlauf],0] && (Not[SameQ[presum,0]] || (prlauf>1)) ) || SameQ[simplesummand[prlauf],1], "", True,simplesummand[prlauf] ] ]; AppendTo[output," "]; AppendTo[output, Which [(SameQ[xpotenz[prlauf],1] && Not[SameQ[simplesummand[prlauf],1]] ) || SameQ[simplesummand[prlauf],0],"", True,xpotenz[prlauf] ] ] ]; output = Apply[SequenceForm,output]; If[SpecialFunctionsPrintMessages,Print[output]] ]; *) (* conversion in a power series *) SetAttributes[ps,HoldFirst]; SetAttributes[psint,HoldFirst]; modilist={}; ps[fkt_,max_,nmax0_] := Module[{dfi,dfib,mi}, (* If [ratalgo[fkt],Return[returnval],rat = False]; *) rat=False; {code,returnval}=psint[fkt,max,nmax0]; If[Not[SameQ[code,0]] && Not[SameQ[code,4]], For[dfi=0,dfi<=pmax (*&& dfi=0,dfib--, {simplesummand[1],ex[1],presum}= (* Das hier scheint Bloedsinn zu sein *) fintegrate[simplesummand[1],ex[1],presum,df[dfib]]; (* normalization with startindex=0 *) (* Das hier scheint Bloedsinn zu sein *) presum = presum - ((simplesummand[1] x^ex[1])/.k->0); prepprint; ClearAttributes[prettyprint,HoldFirst]; (*prettyprint[df[dfib]];*) SetAttributes[prettyprint,HoldFirst] ]; SetAttributes[ratalgo,HoldFirst]; Return[tresult] ]; SetAttributes[ratalgo,HoldFirst] ] ]; If[!rat&&SameQ[code,3],Return[HoldForm[PowerSeries[function,x,0]]]]; Which[SameQ[code,0], Return[returnval], SameQ[code,1], For[mi=1,mi<=Length[modilist],mi++, modfkt=Apply[modilist[[mi]],{fkt}]; If[Not[SameQ[modfkt,fkt]], If[SpecialFunctionsPrintMessages, Print["specfun-info: ",fkt," modified to:"]]; If[SpecialFunctionsPrintMessages, Print[" ",modfkt ]]; ClearAttributes[psint,HoldFirst]; {c2,returnval}=psint[modfkt,max,nmax0]; SetAttributes[psint,HoldFirst]; If[c2!=0 || c2!=1 || c2!=4, Return[HoldForm[PowerSeries[function,x,0]]]] ] ], SameQ[code,3], Return[returnval], SameQ[code,4], Return[HoldForm[PowerSeries[function,x,0]]] ]; Return[HoldForm[PowerSeries[function,x,0]]] ]; (* ps *) (* returncodes psint: 0, ok / PS found 1, DE not found 2, no initialization found 3, RE type not supported 4, PS does not exist *) psint[fkt_,max_,nmax0_]:=Module[{(* ff,pmax,Pde,de,dep,p,nn, dflist,co,sum, m,ix,aa0,ifold,rpart,i*)}, errorval=(*SequenceForm["ps[",*) HoldForm[fkt](*, ",", max, "]"]*); pmax = max; nmax = nmax0; df[0] = fkt; DE=de=SimpleDE[df[0],x,F][[1]]; de=de/.{F[x]->f,Derivative[kkk_][F][x]-> diff[f,x,kkk]}; If[SpecialFunctionsPrintMessages,Print["specfun-info: DE:"]]; If[SpecialFunctionsPrintMessages,Pde = de/.{f->Global`f[x],diff[f,x]->Global`f'[x], diff[f,x,o_]->Derivative[o][Global`f][x]}; Print[" ",Pde /.x->Global`x," == 0"]]; Do[df[kkk]=D[df[kkk-1],x],{kkk,1,DEOrder[DE,F,x]}]; dflist=Table[df[kkk],{kkk,0,DEOrder[DE,F,x]}]; (* conversion in a RE *) Clear[n]; re00= subst[de,x,a]; {recoefflist,varlist}=reseparation[re00]; re=re01=Apply[Plus,recoefflist*varlist]; (* functions with fractional exponents *) redenomi=1; reanalysis[recoefflist,varlist]; If[Not[SameQ[redenomi,1]], If[SpecialFunctionsPrintMessages, Print["specfun-info: RE modified to (k -> ", (k/redenomi)/.k->Global`k,")"]]; varlist2=nvarlist /. a[k+mmmm_]->a[k+(mmmm redenomi)]; recoefflist2=Simplify[Expand[nrecoefflist] /. k^e_. -> (k/redenomi)^e]; re=Apply[Plus,recoefflist2*varlist2]; reanalysis[recoefflist2,varlist2]; ]; fmod:=x->x^redenomi; (* initialization of all RE types *) psstart=0; lvarlist=Length[varlist]; (* test for RE type *) Which[ (* functions with finite representation *) lvarlist==1, If[SpecialFunctionsPrintMessages, Print["specfun-info: ps with finite number of non-zero coefficients"]]; If[SameQ[ninit,0], If[SpecialFunctionsPrintMessages,Print["specfun-info: PS does not exist"]]; Return[{4,errorval}] ]; presum = 0; For [ix=0,ix0] *x^exp/ix!; If[undefined[temp], If[SpecialFunctionsPrintMessages,Print["specfun-info: a[",ix,"]=",temp]]; If[SpecialFunctionsPrintMessages,Print["specfun-info: PS does not exist"]]; Return[{4,errorval}], presum = presum+temp; ] ]; initshift=0; tresult=presum; summand[1]=0; simplesummand[1]=0; xpotenz[1]=0; rparts = 1, (* number of parts of the resulting expression *) (* functions of hypergeometric type *) lvarlist==2, mfold = Max[ findd[nvarlist[[1]]], findd[nvarlist[[2]]] ]; If[Not[FreeQ[gcd,k]], solgcd=Solve[gcd==0,k]; If[Length[solgcd]>1,"specfun-info: too difficult recurrence equation"; Return[{fkt,4}] ]; gcdindex=solgcd[[1,1,2]]; presum= limit[(df[0]/.fmod)*x^(-gcdindex),x->0]x^gcdindex; , (* Else *) presum=0; gcdindex=0 ]; If[SpecialFunctionsPrintMessages, Print["specfun-info: function of hypergeometric type"]]; reinverse; (* 1-symmetric functions *) If [mfold==1, If[rinitsol!={}, If[SpecialFunctionsPrintMessages, Print["specfun-info: for all k <= ",restart-1,": a[k]=0"] ]]; If[irinitsol!={}, If[SpecialFunctionsPrintMessages, Print["specfun-info: for all k >= ",restop+1,": a[k]=0"] ]] ]; originfkt=df[0]; (* logarithmic singularities *) integrate=False; tempdenomi= denomi/.transformspecial2; If[(* NEW CONDITION (SameQ[Cases[Variables[de],f],{}] && (SameQ[maxd,dep] || Not[NumberQ[Coefficient[de,diff[f,x,dep]]]])) *) (SameQ[Cases[Variables[de],f],{}] && (Not[NumberQ[Coefficient[de,diff[f,x,maxd]]]])) && limit[tempdenomi,x->0]==0, integrate=True; If[SpecialFunctionsPrintMessages, Print["specfun-info: working with f' = ",df[1]]]; {rec1,rev1}=reseparation[diffre[re]]; reanalysis[rec1,rev1]; reinverse; df[0]=df[1]; psstart=1; If[Not[FreeQ[gcd,k]], solgcd=Solve[gcd==0,k]; If[Length[solgcd]>1,"specfun-info: too difficult recurrence equation"; Return[{fkt,4}] ]; gcdindex=solgcd[[1,1,2]]; presum= limit[(df[0]/.fmod)*x^(-gcdindex),x->0]x^gcdindex, (* Else *) presum=0; gcdindex=0 ] ]; (* essential singularities *) reverse=False; Off[Series::esss]; (*IfHead[Series[df[0],{x,0,0}]]==Series, no more supported *) If[False, reverse=True; If[SpecialFunctionsPrintMessages, Print["specfun-info: working with ",f[x^(-1)]]]; newcoefflist=If[integrate, {rec1[[2]],(-1)^(mfold-1) rec1[[1]]}, {recoefflist[[2]],recoefflist[[1]]}/.k->-k ]; newvarlist=If[integrate,rev1,{varlist[[2]],a[2k-varlist[[1]][[1]]]}]; df[0]=If[integrate,D[originfkt/.x->1/x,x],df[0]/.x->1/x]; reanalysis[newcoefflist,newvarlist] ]; singmod=x->x^(If[reverse,-1,1]); (* initial coefficients *) initshift=0; shift[1]=Null; For [aa0=-restart; ddff[aa0]=Together[((df[0]-presum)/.fmod)*x^(-restart)], aa0<=-restart+nmax, aa0++;ddff[aa0]=ddff[aa0-1], For [aa=0; inter=ddff[aa0] , aa<=mfold+nmax, aa++; inter=D[inter,x], inter = inter/.transformspecial2; init[1] = limit[inter,x->0] / aa!; init[1] = init[1]/.transformspecial2; If [undefined[init[1]], If[SpecialFunctionsPrintMessages, Print["specfun-info: no initialization found for PS (a[",aa,"]=", init[1],")"]]; Break[], If[SpecialFunctionsPrintMessages, Print["specfun-info: a[",aa,"] = ",init[1]]]; If [Not[SameQ[init[1],0]], initindex=shift[1]=aa; Break[] ] ] ]; If [SameQ[shift[1],Null], If[SpecialFunctionsPrintMessages, If[SameQ[ToString[Global`f],"f"], ff=Global`f,ff=f]; Print["specfun-info: for n < ",aa, " no initialization found for PS: ",x^aa0 ff]], initshift=aa0; Break[] ] ]; If [SameQ[shift[1],Null], Return[{2,errorval}]]; border=Infinity; tresult = 0; rparts = mfold; (* number of parts of the resulting expression *) (* initialization of multi-part FPS *) If [mfold>1, For [ifold=2,ifold<=mfold,ifold++, temp = ifold - 1; tempinit = D[ddff[initshift],{x,initindex+temp}]; tempinit = tempinit/.transformspecial2; init[ifold]=limit[tempinit,x->0] / (initindex+temp)!; If[SpecialFunctionsPrintMessages, Print["specfun-info: a[",initindex+temp,"] = ",init[ifold]]]; shift[ifold] = shift[1] + temp ] ]; (* type of symmetry: shift=1 (odd), shift=0 (even) *) If [mfold==2, Which[Not[SameQ[init[2],0]], If[SpecialFunctionsPrintMessages, Print["specfun-info: PS divided into 2 parts", " (non-symmetric 2-fold function)"]], OddQ[initindex+initshift], If[SpecialFunctionsPrintMessages, Print["specfun-info: shifted 2-fold symmetric function", " (e.g. odd)"]], EvenQ[initindex+initshift], If[SpecialFunctionsPrintMessages, Print["specfun-info: 2-fold symmetric function (e.g. even)"]] ] ]; On[Series::esss]; (* calculation of the parts of the resulting expression *) For [rpart=1,rpart<=rparts,rpart++, If[SameQ[init[rpart],0], summand[rpart]=0, (* RE for the coefficients *) recoefflistsort = nnrelist /. a[__]->1; recoefflist1 = recoefflistsort /. k -> mfold*k+shift[rpart]-initshift; recursfac[rpart] = Factor[-(recoefflist1[[2]]/recoefflist1[[1]])]; (* summand in the hypergeometric FPS *) recnomil0[rpart] = FactorList[Numerator[recursfac[rpart]]]; recnomil[rpart] = factorcomplexlist[recnomil0[rpart]]; recdomil0[rpart] = FactorList[Denominator[recursfac[rpart]]]; recdomil[rpart] = factorcomplexlist[recdomil0[rpart]]; nomi = 1; domi = 1; nomifac = 1; domifac = 1; For [i=1,i<=Length[recnomil[rpart]],i++, {term,exp}={First[recnomil[rpart][[i]]],Last[recnomil[rpart][[i]]]}; If [FreeQ[term,k], nomifac = nomifac * term^exp, {fac,poch} = findpoch[term]; nomifac = nomifac * fac^exp; nomi = nomi * Pochhammer[poch,k]^exp ] ]; For [i=1,i<=Length[recdomil[rpart]],i++, {term,exp}={First[recdomil[rpart][[i]]],Last[recdomil[rpart][[i]]]}; If [FreeQ[term,k], domifac = domifac * term^exp, {fac,poch} = findpoch[term]; domifac = domifac * fac^exp; domi = domi * Pochhammer[poch,k]^exp ] (* if freeQ *) ] (* for i *); Off[GreaterEqual::nord]; summand[rpart]= Simplify[(nomifac/domifac)^k*(nomi/domi)] //.introducei; On[GreaterEqual::nord] ] (* if SameQ *); Off[Power::infy,Infinity::indet]; (* sum representation *) If[SameQ[summand[rpart],0], simplesummand[rpart] = 0; ex[rpart] = (shift[rpart]-initshift) / redenomi; If[integrate,init[rpart]=init[rpart]/++ex[rpart]]; If[reverse,ex[rpart]=-ex[rpart]]; xpotenz[rpart] = x^ex[rpart]; result[rpart] = simplesummand[rpart], simplesummand[rpart] = simple[Simplify[summand[rpart] * init[rpart]]]; simplesummand[rpart] = Factor[simplesummand[rpart]]; ex[rpart] = Simplify[(mfold k + shift[rpart] - initshift)/redenomi]; If[integrate, {simplesummand[rpart],ex[rpart],presum}= fintegrate[simplesummand[rpart],ex[rpart],presum,originfkt/.singmod]; ]; (* normalization of the sums with startindex=0 *) If [Not[SameQ[psstart,0]], Off[Power::infy]; norm=Sum[simplesummand[rpart] x^ex[rpart], {k,0,psstart-1}]; On[Power::infy]; If [Not[undefined[norm]], presum=presum-norm; psstart=0] ]; If[reverse,ex[rpart]=-ex[rpart]]; xpotenz[rpart] = x^ex[rpart]; result[rpart] = Global`sum[simplesummand[rpart]*xpotenz[rpart], {k,psstart,border} ] ](* if sameq summand *); On[Power::infy,Infinity::indet]; tresult = tresult + result[rpart] ]; Do[ If[PolynomialQ[nnrelist[[2]]/(a[k]*(k-restart-kkk)),k], presum=presum+limit[D[(df[0]/.fmod)*x^(-restart),{x,kkk}],x->0]* x^(restart+kkk)],{kkk,0,mfold-1}]; tresult = presum + tresult; , (* explike case *) decoefconst[de], If[SpecialFunctionsPrintMessages, Print["specfun-info: DE has constant coefficients"]]; nnrelist2 = nnrelist*k!; nnrelist3 = nnrelist2/. a[k_]->b[k]/k!; nnrelist3 = Simplify[nnrelist3]; If[SpecialFunctionsPrintMessages, Print["specfun-info: modified RE (a[k] -> k! a[k]):"]]; If[SpecialFunctionsPrintMessages, Print[" ",Apply[Plus,nnrelist3]/.{b->Global`a, k->Global`k}," == 0"]]; nnrelist4 = (nnrelist3 /. b[k_]->x^k) / x^k; gap=0; nnrelist5 = nnrelist4 x^gap; recoefconst = Recoefconst[dflist]; simplesummand0 = summand[1] //. introducei; simplesummand1 = complexfactor[Simplify[simplesummand0]]; simplesummand[1] = complexfactor[Simplify[complexmod[simplesummand1]]]; xpotenz[1] = x^(Simplify[k/redenomi]); initshift=0; (* presum = Sum[limit[df[lx],x->0]x^lx/lx!,{lx,0,restart}]; ??? *) presum=0; tresult= presum + Global`sum[simplesummand[1] * xpotenz[1],{k,restart,Infinity}]; rparts = 1; border = Infinity, (* RE not supported *) True, If[SpecialFunctionsPrintMessages,Print["specfun-info: RE type not supported"]]; Return[{3,errorval}] ]; (*prettyprint[fkt];*) Return[{0,tresult}] ]; (* main program *) (* folgendes gelöscht, da GegenbauerC[a,0,b]=0 -> Folkmar Bornemann *) (* If[Not[FreeQ[function,GegenbauerC[kkk_,0,xxx_]]], Gegenbauer0Print[function]; Return[HoldForm[PowerSeries[function,x,0]]] ]; *) If[Not[FreeQ[function,GegenbauerC[kkk_,aaa_,xxx_]]], GegenbauerWarning[function,{}]; ]; If[!FreeQ[fkt,F]||!FreeQ[x,F], If[SpecialFunctionsPrintMessages, Print["specfun-warning: the symbol F is used in the differential equation."] ] ]; (* HERE order could be omitted *) order0 = order = 5; ps[function,order,order0]/.{jj->Global`jj,k->Global`k} ]/;FreeQ[function,Global`k]&&FreeQ[x,Global`k]&&FreeQ[x0,Global`k]&& SameQ["k",ToString[Global`k]] PowerSeries[function_,x_,x0_]:=Module[{}, If[SameQ["k",ToString[Global`k]], Print["specfun-warning: Please unassign k with Clear[k] before using this function."] ]; HoldForm[PowerSeries[function,x,x0]] ]/;!(FreeQ[function,Global`k]&&FreeQ[x,Global`k]&&FreeQ[x0,Global`k]&& SameQ["k",ToString[Global`k]]) PowerSeries[function_,x_,Infinity]:=Module[{temp}, asympt = False; temp = PowerSeries[function/.x->1/x,x,0]; temp/.x->1/x ] (* formal Laurent series at an arbitrary point *) PowerSeries[func_,y_,y0_]:=Module[{temp(*x*)}, If[SpecialFunctionsPrintMessages, funcp = func /.y->x+y0; Print["specfun-info: working with ",funcp /. x->Global`x]]; temp = PowerSeries[(func /. y->x+y0),x,0]; temp/. (x->y-y0) ]/;!SameQ[ToString[y0],"x"] PowerSeries[func_,y_,y0_]:=Module[{}, Print["specfun-warning: Please use another symbol than x as third argument"]; HoldForm[PowerSeries[func,y,y0]] ] (* shortform *) PS[anything___]:=PowerSeries[anything] FPS[anything___]:=PowerSeries[anything] AsymptPowerSeries[function_,x_]:=Module[{}, Print[InputForm[x]," is not a valid variable."]; HoldForm[AsymptPowerSeries[function,x]]]/;!SameQ[Head[x],Symbol] AsymptPowerSeries[function_,x_]:= AsymptPowerSeries[function,x] AsymptPowerSeries[function_,x_]:=Module[{temp}, asympt = True; temp = PowerSeries[function/.x->1/x,x,0]; asympt = False; temp/.x->1/x ]/;FreeQ[function,Global`k]&&FreeQ[x,Global`k]&&FreeQ[x0,Global`k]&& SameQ["k",ToString[Global`k]] AsymptPowerSeries[function_,x_]:=Module[{}, If[SameQ["k",ToString[Global`k]], Print["specfun-warning: Please unassign k with Clear[k] before using this function."] ]; HoldForm[AsymptPowerSeries[function,x]] ]/;!(FreeQ[function,Global`k]&&FreeQ[x,Global`k]&&FreeQ[x0,Global`k]&& SameQ["k",ToString[Global`k]]) (* SDE and FR *) (* begin identity.m *) Clear[DEOut,SumDE,DESum,ProductDE,DEProduct,PowerDE,DEPower] CompositionDE[f___]:=DEComposition[f] DEOut[de_,F_,x_]:=Module[{X,DE,delist,k,n}, If[SameQ[Head[de],Equal],DE=Expand[de[[1]]-de[[2]]],DE=Expand[de]]; DE=(DE /. F[x]->1); DE=(DE /. Derivative[n_][F][x]->X^n); delist=CoefficientList[DE,X]; Sum[Factor[delist[[k]]] Derivative[k-1][F][x], {k,Length[delist],2,-1}]+Factor[delist[[1]]] F[x]==0 ] DEComposition[de1_,F_,x_,r_]:=Module[ {order,j,xx,list,sol,de,fde,h}, If[SameQ[Head[de1],Equal],fde=de1[[1]]-de1[[2]],fde=de1]; order=DEOrder[fde,F,x]; list=Table[D[h[x]==F[r],{x,j}],{j,0,order}]; sol=Solve[list,Table[Derivative[j][F][r],{j,0,order}]]; de=(fde /. x->r) /. sol[[1]]; DEOut[Numerator[Together[de]],h,x]/.h->F ] SumDE[f___]:=DESum[f] DESum[de1_,de2_,F_[x_]]:=DESum[de1,de2,F,x] DESum[de1_,de2_,F_,x_]:=Module[ {i,jj,k,fde,flist,gde,glist,forder,gorder,frule,grule,done, delist,variab,variablist,solution,h,f,g,HH,X}, If[SpecialFunctionsPrintMessages, Print["specfun-info: DESum entered"]]; (* normalization of differential equations *) If[SameQ[Head[de1],Equal],fde=de1[[1]]-de1[[2]],fde=de1]; If[SameQ[Head[de2],Equal],gde=de2[[1]]-de2[[2]],gde=de2]; fde=(fde /. F[x]->1); fde=(fde /. Derivative[jj_][F][x]->X^jj); flist=CoefficientList[fde,X]; fde=(fde /. X^(Length[flist]-1)->term); fde=Derivative[Length[flist]-1][f][x]== Sum[-Derivative[jj][f][x]*flist[[jj+1]]/flist[[Length[flist]]], {jj,0,Length[flist]-2}]; fde=Map[Together,fde]; gde=(gde /. F[x]->1); gde=(gde /. Derivative[jj_][F][x]->X^jj); glist=CoefficientList[gde,X]; gde=(gde /. X^(Length[glist]-1)->term); gde=Derivative[Length[glist]-1][g][x]== Sum[-Derivative[jj][g][x]*glist[[jj+1]]/glist[[Length[glist]]], {jj,0,Length[glist]-2}]; gde=Map[Together,gde]; (* initial orders *) forder=DEOrder[fde,f,x]; gorder=DEOrder[gde,g,x]; (* generating replacements rules for derivatives of f *) frule={}; Do[frule=Append[frule,fde /. Equal->Rule]; fde=Map[Together,D[fde,x] //. frule] ,{k,forder,forder+gorder}]; (* generating replacements rules for derivatives of g *) grule={}; Do[grule=Append[grule,gde /. Equal->Rule]; gde=Map[Together,D[gde,x] //. grule] ,{k,gorder,forder+gorder}]; (* iterative search for DE of sum *) done=False; For[k=Max[forder,gorder],k<=forder+gorder && Not[done],k++, delist=Table[D[h[x]==f[x]+g[x],{x,jj}],{jj,0,k}]; delist=(delist /. frule); delist=(delist /. grule); delist=MapAll[Together,delist]; variab=Flatten[Union[ Table[Derivative[i][f][x],{i,0,forder-1}], Table[Derivative[jj][g][x],{jj,0,gorder-1}]]]; variablist=Table[variab[[jj]]->var[jj],{jj,1,Length[variab]}]; (* NEW for Mathematica 8. Otherwise the next replacement might fail *) delist=Map[Expand,delist]; delist=(delist /. variablist); delist= Table[delist[[jj,1]]-delist[[jj,2]],{jj,1,Length[delist]}]; delist=Map[Together,delist]; delist=Map[Numerator,delist]; delist=(delist /. {Derivative[jj_][h][x]->HH[jj],h[x]->HH[0]}); Off[Solve::svars]; solution=Solve[delist==Table[0,{jj,1,Length[delist]}], Table[HH[jj],{jj,0,Length[delist]-1}], Table[var[jj],{jj,1,Length[variab]}]]; On[Solve::svars]; If[Not[SameQ[solution,{{}}]], solution=Numerator[Together[ solution[[1,1,1]]-solution[[1,1,2]]]]; done=True] ]; solution=(solution //. {HH[0]->F[x],HH[jj_]->Derivative[jj][F][x]}); DEOut[solution,F,x] ] ProductDE[f___]:=DEProduct[f] DEProduct[de1_,de2_,F_[x_]]:=DEProduct[de1,de2,F,x] DEProduct[de1_,de2_,F_,x_]:=Module[ {i,jj,k,fde,flist,gde,glist,forder,gorder,frule,grule,done, delist,variab,variablist,solution,h,f,g,HH,X}, If[SpecialFunctionsPrintMessages, Print["specfun-info: DEProduct entered"]]; (* normalization of differential equations *) If[SameQ[Head[de1],Equal],fde=de1[[1]]-de1[[2]],fde=de1]; If[SameQ[Head[de2],Equal],gde=de2[[1]]-de2[[2]],gde=de2]; fde=(fde /. F[x]->1); fde=(fde /. Derivative[jj_][F][x]->X^jj); flist=CoefficientList[fde,X]; fde=(fde /. X^(Length[flist]-1)->term); fde=Derivative[Length[flist]-1][f][x]== Sum[-Derivative[jj][f][x]*flist[[jj+1]]/flist[[Length[flist]]], {jj,0,Length[flist]-2}]; fde=Map[Together,fde]; gde=(gde /. F[x]->1); gde=(gde /. Derivative[jj_][F][x]->X^jj); glist=CoefficientList[gde,X]; gde=(gde /. X^(Length[glist]-1)->term); gde=Derivative[Length[glist]-1][g][x]== Sum[-Derivative[jj][g][x]*glist[[jj+1]]/glist[[Length[glist]]], {jj,0,Length[glist]-2}]; gde=Map[Together,gde]; (* initial orders *) forder=DEOrder[fde,f,x]; gorder=DEOrder[gde,g,x]; (* generating replacements rules for derivatives of f *) frule={}; Do[frule=Append[frule,fde /. Equal->Rule]; fde=Map[Together,D[fde,x] //. frule] ,{k,forder,forder*gorder}]; grule={}; (* generating replacements rules for derivatives of g *) grule={}; Do[grule=Append[grule,gde /. Equal->Rule]; gde=Map[Together,D[gde,x] //. grule] ,{k,gorder,forder*gorder}]; (* iterative search for DE of product *) done=False; For[k=Max[forder,gorder],k<=forder*gorder && Not[done],k++, delist=Table[D[h[x]==f[x]*g[x],{x,jj}],{jj,0,k}]; delist=(delist /. frule); delist=(delist /. grule); delist=MapAll[Together,delist]; variab=Flatten[Table[Derivative[i][f][x]*Derivative[jj][g][x], {i,0,forder-1},{jj,0,gorder-1}]]; variablist=Table[variab[[jj]]->var[jj],{jj,1,Length[variab]}]; (* NEW for Mathematica 8. Otherwise the next replacement might fail *) delist=Map[Expand,delist]; delist=(delist /. variablist); delist= Table[delist[[jj,1]]-delist[[jj,2]],{jj,1,Length[delist]}]; delist=Map[Together,delist]; delist=Map[Numerator,delist]; delist=(delist /. {Derivative[jj_][h][x]->HH[jj],h[x]->HH[0]}); Off[Solve::svars]; solution=Solve[delist==Table[0,{jj,1,Length[delist]}], Table[HH[jj],{jj,0,Length[delist]-1}], Table[var[jj],{jj,1,Length[variab]}]]; On[Solve::svars]; If[Not[SameQ[solution,{{}}]], solution=Numerator[Together[ solution[[1,1,1]]-solution[[1,1,2]]]]; done=True] ]; (* HIER!!! bisher: X,H lokal in DESum und DEProduct und Ersetzen von H in HH *) solution=(solution /. {HH[0]->F[x]}); solution=(solution /. {HH[jj_]->Derivative[jj][F][x]}); (* solution=(solution /. {H[0]->F[x],H[jj_]->Derivative[jj][F][x]}); *) DEOut[solution,F,x] ] PowerDE[f___]:=DEPower[f] DEPower[de_,F_,x_,1]:=de DEPower[de_,F_,x_,n_]:=Module[{}, DEProduct[DEPower[de,F,x,n-1],de,F,x] ] /; IntegerQ[n] && n>1 && OddQ[n] DEPower[de_,F_,x_,n_]:=Module[{tmp}, tmp=DEPower[de,F,x,n/2]; DEProduct[tmp,tmp,F,x] ] /; IntegerQ[n] && n>1 && EvenQ[n] Clear[SumRE,RESum,ProductRE,REProduct,PowerRE,REPower] SumRE[f___]:=RESum[f] RESum[de1_,de2_,F_[x_]]:=RESum[de1,de2,F,x] RESum[re1_,re2_,A_,k_]:=Module[ {i,jj,fre,flist,gre,glist,forder,gorder,frule,grule,done, relist,variab,variablist,solution,kk,c,numberlist,min,max,X,a,b}, If[SpecialFunctionsPrintMessages, Print["specfun-info: RESum entered"]]; (* normalization of recurrence equations *) If[SameQ[Head[re1],Equal],fre=re1[[1]]-re1[[2]],fre=re1]; If[SameQ[Head[re2],Equal],gre=re2[[1]]-re2[[2]],gre=re2]; fre=Expand[fre]; numberlist=Union[Map[Plus[#,-k]&,Cases[Cases[fre,A[k+_.],2],k+_.,2]]]; min=Min[numberlist]; max=Max[numberlist]; fre=A[k+max]==Solve[fre==0,A[k+max]][[1,1,2]]; fre=fre/.A->a; fre=(fre /. k->k-min); fre=Map[Together,fre]; forder=max-min; gre=Expand[gre]; numberlist=Union[Map[Plus[#,-k]&,Cases[Cases[gre,A[k+_.],2],k+_.,2]]]; min=Min[numberlist]; max=Max[numberlist]; gre=A[k+max]==Solve[gre==0,A[k+max]][[1,1,2]]; gre=gre/.A->b; gre=(gre /. k->k-min); gre=Map[Together,gre]; gorder=max-min; (* generating replacements rules for shifts of f *) frule={}; Do[frule=Append[frule,fre /. Equal->Rule]; fre=Map[Together,(fre/.k->k+1) //. frule] ,{jj,forder,forder+gorder}]; (* generating replacements rules for shifts of g *) grule={}; Do[grule=Append[grule,gre /. Equal->Rule]; gre=Map[Together,(gre/.k->k+1) //. grule] ,{jj,gorder,forder+gorder}]; (* iterative search for RE of sum *) done=False; For[kk=Max[forder,gorder],kk<=forder+gorder && Not[done],kk++, relist=Table[c[k+jj]==a[k+jj]+b[k+jj],{jj,0,kk}]; relist=(relist /. frule); relist=(relist /. grule); variab=Flatten[Union[ Table[a[k+i],{i,0,forder-1}], Table[b[k+jj],{jj,0,gorder-1}]]]; variablist=Table[variab[[jj]]->var[jj],{jj,1,Length[variab]}]; relist=(relist /. variablist); relist= Table[relist[[jj,1]]-relist[[jj,2]],{jj,1,Length[relist]}]; relist=Map[Together,relist]; relist=Map[Numerator,relist]; relist=(relist /. c[k+jj_.]->H[jj]); Off[Solve::svars]; solution=Solve[relist==Table[0,{jj,1,Length[relist]}], Table[H[jj],{jj,0,Length[relist]-1}], Table[var[jj],{jj,1,Length[variab]}]]; On[Solve::svars]; If[Not[SameQ[solution,{{}}]], solution=Numerator[Together[ solution[[1,1,1]]-solution[[1,1,2]]]]; done=True] ]; solution=(solution /. H[jj_]->X^jj); solution=CoefficientList[solution,X]; solution=Map[Factor,solution]; solution=Sum[solution[[jj]] A[k-1+jj],{jj,1,Length[solution]}]==0 ] ProductRE[f___]:=REProduct[f] REProduct[de1_,de2_,F_[x_]]:=REProduct[de1,de2,F,x] REProduct[re1_,re2_,A_,k_]:=Module[ {i,jj,fre,flist,gre,glist,forder,gorder,frule,grule,done, relist,variab,variablist,solution,kk,c,numberlist,min,max,X,a,b}, If[SpecialFunctionsPrintMessages, Print["specfun-info: REProduct entered"]]; (* normalization of recurrence equations *) If[SameQ[Head[re1],Equal],fre=re1[[1]]-re1[[2]],fre=re1]; If[SameQ[Head[re2],Equal],gre=re2[[1]]-re2[[2]],gre=re2]; fre=Expand[fre]; numberlist=Union[Map[Plus[#,-k]&,Cases[Cases[fre,A[k+_.],2],k+_.,2]]]; min=Min[numberlist]; max=Max[numberlist]; fre=A[k+max]==Solve[fre==0,A[k+max]][[1,1,2]]; fre=fre/.A->a; fre=(fre /. k->k-min); fre=Map[Together,fre]; forder=max-min; gre=Expand[gre]; numberlist=Union[Map[Plus[#,-k]&,Cases[Cases[gre,A[k+_.],2],k+_.,2]]]; min=Min[numberlist]; max=Max[numberlist]; gre=A[k+max]==Solve[gre==0,A[k+max]][[1,1,2]]; gre=gre/.A->b; gre=(gre /. k->k-min); gre=Map[Together,gre]; gorder=max-min; (* generating replacements rules for shifts of f *) frule={}; Do[frule=Append[frule,fre /. Equal->Rule]; fre=Map[Together,(fre/.k->k+1) //. frule] ,{jj,forder,forder*gorder}]; (* generating replacements rules for shifts of g *) grule={}; Do[grule=Append[grule,gre /. Equal->Rule]; gre=Map[Together,(gre/.k->k+1) //. grule] ,{jj,gorder,forder*gorder}]; (* iterative search for RE of product *) done=False; For[kk=Max[forder,gorder],kk<=forder*gorder && Not[done],kk++, relist=Table[c[k+jj]==a[k+jj]*b[k+jj],{jj,0,kk}]; relist=(relist /. frule); relist=(relist /. grule); relist=MapAll[Expand,relist]; variab=Flatten[Table[a[k+i]*b[k+jj], {i,0,forder-1},{jj,0,gorder-1}]]; variablist=Table[variab[[jj]]->var[jj],{jj,1,Length[variab]}]; relist=(relist /. variablist); relist= Table[relist[[jj,1]]-relist[[jj,2]],{jj,1,Length[relist]}]; relist=Map[Together,relist]; relist=Map[Numerator,relist]; relist=(relist /. c[k+jj_.]->H[jj]); Off[Solve::svars]; solution=Solve[relist==Table[0,{jj,1,Length[relist]}], Table[H[jj],{jj,0,Length[relist]-1}], Table[var[jj],{jj,1,Length[variab]}]]; On[Solve::svars]; If[Not[SameQ[solution,{{}}]], solution=Numerator[Together[ solution[[1,1,1]]-solution[[1,1,2]]]]; done=True] ]; solution=(solution /. H[jj_]->X^jj); solution=CoefficientList[solution,X]; solution=Map[Factor,solution]; solution=Sum[solution[[jj]] A[k-1+jj],{jj,1,Length[solution]}]==0 ] PowerRE[f___]:=REPower[f] REPower[re_,A_,k_,1]:=re REPower[re_,A_,k_,n_]:=Module[{}, REProduct[REPower[re,A,k,n-1],re,A,k] ] /; IntegerQ[n] && n>1 && OddQ[n] REPower[re_,A_,k_,n_]:=Module[{tmp}, tmp=REPower[re,A,k,n/2]; REProduct[tmp,tmp,A,k] ] /; IntegerQ[n] && n>1 && EvenQ[n] Clear[theta,backsubst] theta[f_,x_]:=x D[f,x] backsubst[eq1_+eq2_,n_,f_,x_]:=backsubst[eq1,n,f,x]+backsubst[eq2,n,f,x] backsubst[c_*eq_,n_,f_,x_]:=c*backsubst[eq,n,f,x] /; (FreeQ[c,n] && FreeQ[c,f] && FreeQ[c,x]) backsubst[a_[n_+m_.],n_,f_,x_]:=f[x]/x^m backsubst[n_^j_.*a_[n_+m_.],n_,f_,x_]:=theta[backsubst[n^(j-1)*a[n+m],n,f,x],x] backsubst[p_*a_[n_+m_.],n_,f_,x_]:= backsubst[Expand[p*a[n+m]],n,f,x] /; PolynomialQ[p,n] (* Fri Apr 29 10:29:04 MET DST 1994 Unprotect[REtoDE] Clear[REtoDE] REtoDE[f_,a_,k_,F_,x_]:=RETODE[f,a,k,F,x] REtoDE[f_,a_,k_]:= RETODE[f,a,k,F,x] *) RETODE[re_,a_,k_]:=RETODE[re,a,k,Global`f,Global`x] RETODE[re_,a_,k_,F_,x_]:=Module[ {recursion,containsk,recursionfactor,recursionpart,jj,de,n}, If[SameQ[Head[re],Equal],recursion=re[[1]]-re[[2]],recursion=re]; recursion = Collect[recursion,a[k]]; (* recursionfactor=1; Do[ recursionpart[jj]=(recursion[[jj]]/(recursion[[jj]] /. a[anything_]->1))[[1]]; containsk[jj]=recursionpart[jj] , {jj,2,Length[recursion]}]; recursionfactor=Product[containsk[jj],{jj,2,Length[recursion]}]; recursion=Collect[recursion*recursionfactor,a[k]]; *) de = backsubst[(recursion/.k->n),n,F,x]; de = Numerator[Together[de]]; While[NumberQ[Denominator[Together[de/x]]],de= Expand[de/x]]; DEOut[de,F,x] ] Clear[SymbolicSumDE,SymbolicSumRE,ConvolutionRE] (* SymbolicSumRE[a,k,n] gibt eine RE fuer Sum[b[k],{k,0,n}] aus *) SymbolicSumRE[b_,k_,n_,a_]:=Module[ {re,de1,de2,de,x}, re=FindRecursion[b,k,a]; de1=RETODE[re,a,k,F,x]; de2=F[x]+(-1+x)*F'[x]; (* SimpleDE[1/(1-z),z] *) de=DEProduct[de1,de2,F,x]; re=DEtoRE[de,F,x,a,n] ] ConvolutionRE[b_,c_,a_[k_],n_]:=ConvolutionRE[b,c,k,n,a] ConvolutionRE[b_,c_,k_,n_,a_]:=Module[ {G,x,rec1,rec2,de1,de2,de}, rec1=FindRecursion[b,k,a]; rec2=FindRecursion[c,k,a]; de1=REtoDE[rec1,a,k,F,x]; de2=REtoDE[rec2,a,k,F,x]; de=DEProduct[de1,de2,F,x]; DEtoRE[de,F,x,a,n] ] ConvolutionRE[b_,c_,k_,n_]:=ConvolutionRESum[b,c,k,n,a] Clear[VerifyDE,SymbolicDerivativeRE,RationalQ,VerifyIdentity,RodriguesDE] Off[General::spell1] RationalQ[f_,x_]:=Module[{fac}, fac:=Factor[f]; PolynomialQ[Numerator[fac],x] && PolynomialQ[Denominator[fac],x] ] On[General::spell1] SymbolicDerivativeRE[re_,a_,k_,n_]:=SymbolicDerivativeRE[re,a,k,n,a] SymbolicDerivativeRE[re_,a_,k_,n_,c_]:=Module[ {re1,nn,mfold,REPRODSUM,newreprodsum,new,EQ}, If[SameQ[Head[re],Equal],re1=(Expand[re[[1]]-re[[2]]] /. k->nn), re1=(Expand[re] /. k->nn)]; (* hypergeometric type ? *) If[Not[Length[Union[Cases[re1,a[nn_],2]]]==2], Print[f," is not of hypergeometric type"];Null, (* else *) (*sol=Solve re1,*) mfold=Max[(Cases[re1,a[nn_],3] /. a[nn_]->nn)-nn]; re1=a[nn+mfold]==Solve[re1==0,a[nn+mfold]][[1,1,2]]; REPRODSUM=Simplify[re1[[2]]/a[nn]]; newreprodsum=REPRODSUM /. nn->nn+n; new=Together[Simplify[Pochhammer[nn+n+1,mfold]/ Pochhammer[nn+1,mfold]*newreprodsum]]; num=Numerator[new]; den=Denominator[new]; EQ=den*c[nn+mfold]-num*c[nn]; (EQ==0 /. nn->k) ] ] RodriguesDE[f_,x_,n_,F_]:=Module[ {de1,re1,re2,de2,c,k,a}, de1=SDE[f,x,F]; re1=DEtoRE[de1,F,x,a,k]; If[Not[Length[Union[Cases[re1[[1]],a[nn_],2]]]==2], Print[f," is not of hypergeometric type"]; de2=HoldForm[RodriguesDE[f,x,n]], (* else *) re2=SymbolicDerivativeRE[re1,a,k,n,c]; de2=DEOut[RETODE[re2,c,k,F,x],F,x] ]; de2 ] Clear[HypergeometricDR, HypergeometricRE, HypergeometricDE] HypergeometricDR[P_,Q_,x_,n_]:=Module[ {var,subst}, If[FreeQ[P,n]&&FreeQ[Q,n],Return[]]; If[Not[FreeQ[P,n]]&&Not[FreeQ[Q,n]],Return[]]; If[Not[FreeQ[Q,n]],var=n-1;subst=n-1]; If[Not[FreeQ[P,n]],var=n;subst=n+1]; Derivative[1][pFq[P,Q,x]]== var/x*pFq[P/.n->subst,Q/.n->subst,x]-var/x*pFq[P,Q,x] ] /; SameQ[Head[n],Symbol] HypergeometricRE[P_,Q_,x_]:=HypergeometricRE[P,Q,x,P[[1]]] HypergeometricRE[P_,Q_,x_,n_]:=HypergeometricRE[P,Q,x,n,a] HypergeometricRE[P_,Q_,x_,n_,a_]:=Module[ {DE,DEList,RE,t,th,plist,qlist,max,result,avar,bvar, y,nn,xxx,jj,num,den,len}, plist=P; qlist=Q; DE=Expand[t*Product[t+qlist[[j]]-1,{j,1,Length[qlist]}]- x*Product[t+plist[[j]],{j,1,Length[plist]}]]; DEList=CoefficientList[DE,t]; If[Not[FreeQ[P,n]], max=Max[Length[plist],Length[qlist]+1]; th[F[avar_, y_]]:=-avar*F[avar, y]+avar*F[1 + avar, y]; th[avar_*bvar_]:=avar*th[bvar] /; FreeQ[avar,y]; th[avar_+bvar_]:=th[avar]+th[bvar] ]; If[Not[FreeQ[Q,n]], max=0; th[F[avar_, y_]]:=-(avar-1)*F[avar, y]+(avar-1)*F[avar-1, y]; th[avar_*bvar_]:=avar*th[bvar] /; FreeQ[avar,y]; th[avar_+bvar_]:=th[avar]+th[bvar] ]; If[FreeQ[P,n]&&FreeQ[Q,n],Return[]]; If[Not[FreeQ[P,n]]&&Not[FreeQ[Q,n]],Return[]]; RE=Sum[DEList[[j]] Nest[th[#]&,F[n,x],j-1],{j,1,Length[DEList]}]; RESULT=result= Map[Simplify,Solve[RE==0,F[n+max,x]][[1,1]] /. {Rule->Equal}]; len=Min[Map[#[[1]]-n&,Cases[{result[[2]]},F[nn_,xxx_],Infinity]]]; result=result /. F[nn_,xxx_]->X^(nn-n-len); result=Map[Together,result]; num=CoefficientList[Numerator[result[[2]]],X]; den=Factor[Denominator[result[[2]]]]; (* pFq[P,Q,x]== Sum[Factor[num[[jj]]/den]* pFq[P/.n->jj+n+len-1,Q/.n->jj+n+len-1,x],{jj,1,Length[num]}] *) Factor[den/.n->n-len]*a[n+max-len]+ Sum[Factor[-num[[jj]]/.n->n-len]* a[jj+n-1],{jj,1,Length[num]}] == 0 ] /; SameQ[Head[n],Symbol] theta[f_,x_]:=x D[f,x] HypergeometricDE[P_,Q_,x_]:=HypergeometricDE[P,Q,x,F] HypergeometricDE[P_,Q_,x_,F_]:=Module[ {plist,qlist,n,DE,DEList}, plist=P; qlist=Q; DE=Expand[t*Product[t+qlist[[j]]-1,{j,1,Length[qlist]}]- x*Product[t+plist[[j]],{j,1,Length[plist]}]]; DEList=CoefficientList[DE,t]; DEOut[ Sum[DEList[[j]] Nest[theta[#,x]&,F[x],j-1]/x,{j,1,Length[DEList]}], F,x] ] (* Here we define SimpleDE new by descent *) Clear[SDE] SDE[f_,x_]:=SDE[f,x,F] (* constants *) SDE[a_,x_,F_]:=F'[x] == 0 /; FreeQ[a,x] (* elementary functions *) SDE[x_^n_,x_,F_]:=-(n F[x]) + x F'[x] == 0 /; FreeQ[n,x] SDE[r_,x_,F_]:=Module[{p,q,tmp,X,coefflist}, tmp=Together[r]; p=Numerator[tmp]; q=Denominator[tmp]; tmp=(D[p,x]/p-D[q,x]/q) -X; tmp=Numerator[Together[tmp]]; coefflist=Factor[CoefficientList[tmp,X]]; coefflist[[1]] F[x] + coefflist[[2]] F'[x] == 0 ] /; RationalQ[r,x] SDE[a_^x_,x_,F_]:=-(F[x] Log[a]) + F'[x] == 0 /; FreeQ[a,x] SDE[Log[x_],x_,F_]:=F'[x] + x F''[x] == 0 SDE[Sin[x_],x_,F_]:=F[x] + F''[x] == 0 SDE[Cos[x_],x_,F_]:=F[x] + F''[x] == 0 SDE[ArcSin[x_],x_,F_]:=x F'[x] + (-1 + x^2) F''[x] == 0 SDE[ArcCos[x_],x_,F_]:=x F'[x] + (-1 + x^2) F''[x] == 0 SDE[ArcTan[x_],x_,F_]:=2 x F'[x] + (1 + x^2) F''[x] == 0 SDE[ArcCot[x_],x_,F_]:=2 x F'[x] + (1 + x^2) F''[x] == 0 SDE[Sinh[x_],x_,F_]:=-F[x] + F''[x] == 0 SDE[Cosh[x_],x_,F_]:=-F[x] + F''[x] == 0 SDE[ArcSinh[x_],x_,F_]:=x F'[x] + (1 + x^2) F''[x] == 0 SDE[ArcCosh[x_],x_,F_]:=x F'[x] + (-1 + x^2) F''[x] == 0 SDE[ArcTanh[x_],x_,F_]:=2 x F'[x] + (-1 + x^2) F''[x] == 0 SDE[ArcCoth[x_],x_,F_]:=2 x F'[x] + (-1 + x ^2) F''[x] == 0 SDE[Erf[x_],x_,F_]:=2 x F'[x] + F''[x] == 0 SDE[Erfc[x_],x_,F_]:=2 x F'[x] + F''[x] == 0 SDE[ExpIntegralEi[x_],x_,F_]:=(1 - x) F'[x] + x F''[x] == 0 SDE[SinIntegral[x_],x_,F_]:=x F'[x] + 2 F''[x] + x F'''[x] SDE[CosIntegral[x_],x_,F_]:=x F'[x] + 2 F''[x] + x F'''[x] == 0 SDE[AiryAi[x_],x_,F_]:=-(x F[x]) + F''[x] == 0 SDE[AiryAiPrime[x_],x_,F_]:= -2*F[x] - x*Derivative[1][F][x] + Derivative[3][F][x] == 0 SDE[AiryBi[x_],x_,F_]:=-(x F[x]) + F''[x] == 0 SDE[AiryBiPrime[x_],x_,F_]:= -2*F[x] - x*Derivative[1][F][x] + Derivative[3][F][x] == 0 (* special functions *) SDE[ExpIntegralE[n_,x_],x_,F_]:= (1 - n) F[x] + (2 - n + x) F'[x] + x F''[x] == 0 /; FreeQ[n,x] SDE[Gamma[n_,x_],x_,F_]:=(1 - n + x) F'[x] + x F''[x] == 0 /; FreeQ[n,x] SDE[Erfc[n_,x_],x_,F_]:=-2 n F[x] + 2 x F'[x] + F''[x] == 0 /; FreeQ[n,x] SDE[BesselJ[n_,x_],x_,F_]:=(-n^2 + x^2) F[x] + x F'[x] + x^2 F''[x] == 0 /; FreeQ[n,x] SDE[BesselY[n_,x_],x_,F_]:=(-n^2 + x^2) F[x] + x F'[x] + x^2 F''[x] == 0 /; FreeQ[n,x] SDE[BesselI[n_,x_],x_,F_]:=(-n^2 - x^2) F[x] + x F'[x] + x^2 F''[x] == 0 /; FreeQ[n,x] SDE[BesselK[n_,x_],x_,F_]:=(-n^2 - x^2) F[x] + x F'[x] + x^2 F''[x] == 0 /; FreeQ[n,x] SDE[Hankel1[n_,x_],x_,F_]:= (-n^2 + x^2) F[x] + x F'[x] + x^2 F''[x] == 0 /; FreeQ[n,x] SDE[Hankel2[n_,x_],x_,F_]:= (-n^2 + x^2) F[x] + x F'[x] + x^2 F''[x] == 0 /; FreeQ[n,x] SDE[KummerM[n_,m_,x_],x_,F_]:= -(n F[x]) + (m - x) F'[x] + x F''[x] == 0 /; FreeQ[n,x] && FreeQ[m,x] SDE[KummerU[n_,m_,x_],x_,F_]:= -(n F[x]) + (m - x) F'[x] + x F''[x] == 0 /; FreeQ[n,x] && FreeQ[m,x] SDE[WhittakerM[n_,m_,x_],x_,F_]:= (1 - 4 m^2 + 4 n x - x^2) F[x] + 4 x^2 F''[x] == 0 /; FreeQ[n,x] && FreeQ[m,x] SDE[WhittakerW[n_,m_,x_],x_,F_]:= (1 - 4 m^2 + 4 n x - x^2) F[x] + 4 x^2 F''[x] == 0 /; FreeQ[n,x] && FreeQ[m,x] SDE[LegendreP[a_,b_,x_],x_,F_]:=(a + a^2 - b^2 - a x^2 - a^2 x^2) F[x] + 2 x (-1 + x^2) F'[x] + (-1 + x^2)^2 F''[x] == 0 /; FreeQ[a,x] && FreeQ[b,x] SDE[LegendreQ[a_,b_,x_],x_,F_]:=(a + a^2 - b^2 - a x^2 - a^2 x^2) F[x] + 2 x (-1 + x^2) F'[x] + (-1 + x^2)^2 F''[x] == 0 /; FreeQ[a,x] && FreeQ[b,x] SDE[JacobiP[n_,a_,b_,x_],x_,F_]:=n (n + a + b + 1) F[x] + (b - a - (a + b + 2) x) F'[x] + (1 - x^2) F''[x] == 0 /; FreeQ[n,x] && FreeQ[a,x] && FreeQ[b,x] SDE[GegenbauerC[n_,0,x_],x_,F_]:= SDE[ChebyshevT[n,x],x,F] /; FreeQ[n,x] SDE[GegenbauerC[n_,a_,x_],x_,F_]:= (-2 a n - n^2) F[x] + (x + 2 a x) F'[x] + (-1 + x^2) F''[x] == 0 /; FreeQ[n,x] && FreeQ[a,x] SDE[ChebyshevT[n_,x_],x_,F_]:= -(n^2 F[x]) + x F'[x] + (-1 + x^2) F''[x] == 0 /; FreeQ[n,x] SDE[ChebyshevU[n_,x_],x_,F_]:= (-2 n - n^2) F[x] + 3 x F'[x] + (-1 + x^2) F''[x] == 0 /; FreeQ[n,x] SDE[LegendreP[n_,x_],x_,F_]:= (-n - n^2) F[x] + 2 x F'[x] + (-1 + x^2) F''[x] == 0 /; FreeQ[n,x] SDE[LaguerreL[n_,a_,x_],x_,F_]:=n F[x] + (1 + a - x) F'[x] + x F''[x] == 0 /; FreeQ[n,x] && FreeQ[a,x] SDE[LaguerreL[n_,x_],x_,F_]:=n F[x] + (1 - x) F'[x] + x F''[x] == 0 /; FreeQ[n,x] SDE[HermiteH[n_,x_],x_,F_]:=2 n F[x] - 2 x F'[x] + F''[x] == 0 /; FreeQ[n,x] SDE[EllipticK[x_],x_,F_]:=-F[x] + 4 (1 - 2 x) F'[x] + 4 (1 - x) x F''[x] == 0 SDE[EllipticE[x_],x_,F_]:=F[x] + 4 (1 - x) F'[x] + 4 (1 - x) x F''[x] == 0 SDE[Hypergeometric0F1[a_,x_],x_,F_]:=F[x] - a F'[x] - x F''[x] == 0 /; FreeQ[a,x] SDE[Hypergeometric1F0[a_,x_],x_,F_]:=a F[x] + (-1 + x) F'[x] == 0 /; FreeQ[a,x] SDE[HypergeometricU[a_,b_,x_],x_,F_]:= -(a F[x]) + (b - x) F'[x] + x F''[x] == 0 /; FreeQ[a,x] && FreeQ[b,x] SDE[Hypergeometric1F1[a_,b_,x_],x_,F_]:= -(a F[x]) + (b - x) F'[x] + x F''[x] == 0 /; FreeQ[a,x] && FreeQ[b,x] SDE[Hypergeometric2F0[a_,b_,x_],x_,F_]:= -(a b F[x]) + (1 - x - a x - b x) F'[x] - x^2 F''[x] == 0 /; FreeQ[a,x] && FreeQ[b,x] SDE[Hypergeometric2F1[a_,b_,c_,x_],x_,F_]:= -(a b F[x]) + (c - x - a x - b x) F'[x] + (1 - x) x F''[x] == 0 /; FreeQ[a,x] && FreeQ[b,x] && FreeQ[c,x] SDE[Hypergeometric3F2[a_,b_,c_,d_,e_,x_],x_,F_]:=-(a b c F[x]) + (d e - x - a x - b x - a b x - c x - a c x - b c x) F'[x] + x (1 + d + e - 3 x - a x - b x - c x) F''[x] + (1 - x) x^2 F'''[x] == 0 /; FreeQ[a,x] && FreeQ[b,x] && FreeQ[c,x] && FreeQ[d,x] && FreeQ[e,x] SDE[Hypergeometric2F3[a_,b_,c_,d_,e_,x_],x_,F_]:=-(a b F[x]) + (c d e - x - a x - b x) F'[x] + (1 + c + d + c d + e + c e + d e - x) x F''[x] + (3 + c + d + e) x^2 F'''[x] + x^3 F''''[x] == 0 /; FreeQ[a,x] && FreeQ[b,x] && FreeQ[c,x] && FreeQ[d,x] && FreeQ[e,x] SDE[HypergeometricPFQ[P_,Q_,x_],x_,F_]:=Module[ {plist,qlist,n,DE,DEList}, plist=P; qlist=Q; DE=Expand[t*Product[t+qlist[[j]]-1,{j,1,Length[qlist]}]- x*Product[t+plist[[j]],{j,1,Length[plist]}]]; DEList=CoefficientList[DE,t]; DEOut[ Sum[DEList[[j]] Nest[theta[#,x]&,F[x],j-1]/x,{j,1,Length[DEList]}], F,x] ] /; FreeQ[P,x] && FreeQ[Q,x] SDE[StruveH[n_,x_],x_,F_]:=(n^2 + n^3 + x^2 - n x^2) F[x] + x (-n - n^2 + x^2) F'[x] + (2 - n) x^2 F''[x] + x^3 F'''[x] == 0 /; FreeQ[n,x] SDE[StruveL[n_,x_],x_,F_]:=(3 n^2 - n^3 + x^2 - n x^2) F[x] + x (-2 + n - n^2 - x^2) F'[x] + n x^2 F''[x] + x^3 F'''[x] == 0 /; FreeQ[n,x] SDE[Ai[n_,x_],x_,F_]:= (-1 - n) F[x] - x F'[x] + F'''[x] == 0 /; FreeQ[n,x] SDE[Abramowitz[n_,x_],x_,F_]:=2 F[x] + (1 - n) F''[x] + x F'''[x] == 0 /; FreeQ[n,x] SDE[NormalIntegral[n_,x_],x_,F_]:=-(n F[x]) + x F'[x] + F''[x] == 0 /; FreeQ[n,x] SDE[KnuthA[n_,x_],x_,F_]:=(-2 + 7 n - n^2 - x^3 + 2 n x^3) F[x] + (6 x + 4 n x + 2 x^4) F'[x] + 8 x^2 F''[x] + 8 F'''[x] == 0 /; FreeQ[n,x] SDE[KnuthB[n_,x_],x_,F_]:= (-10 + 7 n - n^2) F[x] + (-18 x + 4 n x) F'[x] - 4 x^2 F''[x] + 8 F'''[x] == 0 /; FreeQ[n,x] SDE[ParabolicU[n_,x_],x_,F_]:=(-4 n - x^2) F[x] + 4 F''[x] == 0 /; FreeQ[n,x] SDE[ParabolicD[n_,x_],x_,F_]:=(2 + 4 n - x^2) F[x] + 4 F''[x] == 0 /; FreeQ[n,x] SDE[ParabolicV[n_,x_],x_,F_]:=(-4 n - x^2) F[x] + 4 F''[x] == 0 /; FreeQ[n,x] SDE[Bateman[n_,x_],x_,F_]:=(2 n - x) F[x] + x F''[x] == 0 /; FreeQ[n,x] SDE[Krawtchouk[n_,N_,p_,x_],p_,F_]:= n (-1 + n - N) F[p] + (-1 + n + 2 p - 2 n p + N p - x) F'[p] + (-1 + p) p F''[p] == 0 /; FreeQ[n,p] && FreeQ[N,p] && FreeQ[x,p] SDE[Charlier[n_,mu_,x_],mu_,F_]:=-(n x F[mu]) + mu (-1 + mu - n - x) F'[mu] - mu^2 F''[mu] == 0 /; FreeQ[n,mu] && FreeQ[x,mu] SDE[Meixner[n_,gamma_,mu_,x_],mu_,F_]:=-(n x F[mu]) + mu (-1 + mu + gamma mu - n + mu n - x + mu x) F'[mu] + (-1 + mu) mu^2 F''[mu] == 0 /; FreeQ[n,mu] && FreeQ[x,mu] && FreeQ[gamma,mu] SDE[DiscreteLaguerre[n_,rho_,alpha_,x_],rho_,F_]:= n (alpha + x) F[rho] + (-n - rho - alpha rho + n rho + x - rho x) F'[rho] + (1 - rho) rho F''[rho] == 0 /; FreeQ[n,rho] && FreeQ[alpha,rho] && FreeQ[x,rho] (* descent programming *) (* Rodrigues type *) SDE[Derivative[n_][f_][x_],x_,F_]:=RodriguesDE[f[x],x,n,F] SDE[Derivative[0,n_][f_][a_,x_],x_,F_]:=RodriguesDE[f[a,x],x,n,F] SDE[D[f_,{x_,n_}],x_,F_]:=RodriguesDE[f,x,n,F] SDE[Derivative[null1___,n_,null2___][f_][a___,y_,b___],x_,F_]:= RodriguesDE[f[a,y,b],x,n,F] /; Module[{null1list,null2list,kkkk}, Off[ReplaceAll::argr]; Off[ReplaceAll::argrx]; FreeQ[{a},x] && FreeQ[{b},x] && SameQ[null1list={null1},Table[0,{kkkk,1,Length[null1list]}]] && SameQ[null2list={null2},Table[0,{kkkk,1,Length[null2list]}]] ] (* power series type *) SDE[Global`sum[expr_.*x_^k_,{k_,0,Infinity}],x_,F_]:= SumtoDE[Global`sum[expr*x^k,{k,0,Infinity}],x,F] (* SDE[Global`sum[expr_.*x_^(m_.k_+b_.),{k_,0,Infinity}],x_,F_]:=Module[ {comp}, comp=DEComposition[SumtoDE[Global`sum[expr*x^k,{k,0,Infinity}],x,F],F,x,x^m]; DEProduct[comp,SDE[x^b,x,F],F,x] ] /; IntegerQ[m] *) (* SimpleDE[Sum[1/k! x^k,{k,0,Infinity}],x,F] SimpleDE[Sum[1/k! x^k,{k,1,Infinity}],x,F] SimpleDE[D[JacobiP[n,a,b,1-1/x],{x,k}],x,F] Beachte: SimpleDE[Sum[1/k! x^k,{k,-1,Infinity}],x,F] ist KEIN vernuenftiger Input ! *) (* infinity sums *) SDE[Global`sum[expr_.*r_^(m_.k_+b_.),{k_,0,Infinity}],x_,F_]:=Module[ {comp}, comp=DEComposition[SumtoDE[ Global`sum[expr*x^k,{k,0,Infinity}],x,F],F,x,r^m]; DEProduct[comp,SDE[r^b,x,F],F,x] ] /; IntegerQ[m] && RationalQ[r,x] SDE[Global`sum[expr_.*r_^(m_.k_+b_.),{k_,k0_,Infinity}],x_,F_]:=Module[{tmp}, tmp=(expr/.k->k+k0); SDE[r^(m*k0+b)*Global`sum[tmp*r^(m*k),{k,0,Infinity}],x,F] ] /; IntegerQ[m] && RationalQ[r,x] && IntegerQ[k0] && Not[SameQ[k0,0]] (* voruebergehend *) (* SDE[Sum[expr_.*r_^(m_.k_+b_.),{k_,k0_,Infinity}],x_,F_]:= SDE[Sum[expr*r^(m k+b),{k,0,Infinity}]- Sum[expr*r^(m k+b),{k,0,k0-1}],x,F] /; IntegerQ[m] && RationalQ[r,x] && IntegerQ[k0] && k0>=1 *) (* sum algorithm *) (* old SDE[f_+g_,x_,F_]:=SumDE[SDE[f,x,F],SDE[g,x,F],F,x] *) SDE[f_+g_,x_,F_]:=Module[{fde,gde,result}, fde=SDE[f,x,F]; gde=SDE[g,x,F]; If[Not[SameQ[Head[fde],HoldForm] || SameQ[Head[gde],HoldForm] || SameQ[Head[fde],SDE] || SameQ[Head[gde],SDE]], result=SumDE[fde,gde,F,x], result=HoldForm[SDE[f+g,x,F]]]; result ] (* linearity *) SDE[a_*f_,x_,F_]:=SDE[f,x,F] /; FreeQ[a,f] && FreeQ[a,x] (* product algorithm *) (* old SDE[f_*g_,x_,F_]:=ProductDE[SDE[f,x,F],SDE[g,x,F],F,x] *) SDE[f_*g_,x_,F_]:=Module[{fde,gde,result}, fde=SDE[f,x,F]; gde=SDE[g,x,F]; If[Not[SameQ[Head[fde],HoldForm] || SameQ[Head[gde],HoldForm] || SameQ[Head[fde],SDE] || SameQ[Head[gde],SDE]], result=ProductDE[fde,gde,F,x], result=HoldForm[SDE[f*g,x,F]]]; result ] (* iterative products *) SDE[f_^n_,x_,F_]:=PowerDE[SDE[f,x,F],F,x,n] /; IntegerQ[n] && n>0 (* composition algorithm *) (* composition with rational functions *) SDE[f_^r_,x_,F_]:=CompositionDE[SDE[f^x,x,F],F,x,r] /; Not[FreeQ[r,x]] && RationalQ[r,x] && Not[SameQ[r,x]] SDE[f_[a___,r_,b___],x_,F_]:=CompositionDE[SDE[f[a,x,b],x,F],F,x,r] /; Not[FreeQ[r,x]] && RationalQ[r,x] && Not[SameQ[r,x]] (* other compositions *) SDE[f_[a___,r_,b___],x_,F_]:=simpleDE[f[a,r,b],x,5,F] /; Not[FreeQ[r,x]] && Not[RationalQ[r,x]] SDE[f_^r_,x_,F_]:=simpleDE[f^r,x,5,F] /; Not[FreeQ[r,x]] && Not[RationalQ[r,x]] (* derivatives and antiderivatives *) SDE[Integrate[f_,x_],x_,F_]:=Module[{tmp}, tmp=SDE[f,x,F]; tmp=tmp /. Derivative[n_][F][x]->Derivative[n+1][F][x]; tmp=tmp /. F[x]->F'[x] ] SDE[Integrate[f_,{t_,a_,x_}],x_,F_]:=Module[{tmp}, tmp=SDE[f,t,F]/.t->x; tmp=tmp /. Derivative[n_][F][x]->Derivative[n+1][F][x]; tmp=tmp /. F[x]->F'[x] ] /; FreeQ[a,x] && FreeQ[a,t] SDE[Integrate[f_,{t_,x_,b_}],x_,F_]:=Module[{tmp}, tmp=SDE[f,t,F]/.t->x; tmp=tmp /. Derivative[n_][F][x]->Derivative[n+1][F][x]; tmp=tmp /. F[x]->F'[x] ] /; FreeQ[b,x] && FreeQ[b,t] SDE[f___]:=HoldForm[HolonomicDE[f]]; SimpleDE[expr_,f_[x_]]:=SDE[expr,x,f] SimpleDE[f_,x_]:=SDE[f,x,Global`f] SimpleDE[f_,x_,F_]:=Module[{solutionde}, If[SpecialFunctionsPrintMessages, Print[specfuninfo]]; solutionde=SDE[f,x,F]; If[SpecialFunctionsPrintMessages,Print["specfun-info: DE:"]]; solutionde ] (* Module SimpleDE *) (* alias for SpecialFunctions`Private`simpleDE *) holonomicDE[term_,F_[x_],max_]:=Map[Factor,SpecialFunctions`Private`simpleDE[term,x,max,F][[1]]]==0 holonomicDE[term_,F_[x_]]:=holonomicDE[term,F[x],5] (* Here we define FindRecursion new by descent *) Clear[FR] FR[f_,n_]:=FR[f,n,a] Off[Sin::argx] Off[Cos::argx] (* Bastelei *) FR[Sin[n_,x_],n_,a_]:=a[n+2]+a[n]==0 /; FreeQ[x,n] FR[Cos[n_,x_],n_,a_]:=a[n+2]+a[n]==0 /; FreeQ[x,n] (* standard first order functions *) (* constants *) FR[f_,n_,a_]:=a[n] - a[n+1] == 0 /; FreeQ[f,n] (* powers *) FR[m_^(b_.*n_+c_.),n_,a_]:=m^b a[n] - a[1 + n] == 0 /; FreeQ[b,n] && FreeQ[m,n] && FreeQ[c,n] (* rational functions *) FR[r_,n_,a_]:=Module[{den}, den=Denominator[Together[r]]; den=den*(den /. n->n+1); Factor[den*(r /. n->n+1)]*a[n] - Factor[den*r]*a[n+1] == 0 ] /; RationalQ[r,n] (* all kinds of factorial expressions *) (* advanced case (p/q n + b)! for p>0 *) FR[(m_. n_ + b_.)!^order_.,n_,a_]:=Module[{p,q,result}, If[SameQ[Head[m],Rational], p=Numerator[m];q=Denominator[m], p=m;q=1 ]; result=Pochhammer[m n + b + 1,p]^order a[n] - a[n + q]; result=Map[Times[q^(p order),#]&,result]; Map[Factor,result] == 0 ] /; FreeQ[b,n] && (order>0) && ((SameQ[Head[m],Rational] && m>0) || (IntegerQ[m] && m>=1)) FR[(m_. n_ + b_.)!^order_.,n_,a_]:=Module[{p,q,result}, If[SameQ[Head[m],Rational], p=Numerator[m];q=Denominator[m], p=m;q=1 ]; result=a[n] - Pochhammer[m n + b + 1,p]^(-order) a[n + q]; result=Map[Times[q^(-p order),#]&,result]; Map[Factor,result] == 0 ] /; FreeQ[b,n] && (order<0) && ((SameQ[Head[m],Rational] && m>0) || (IntegerQ[m] && m>=1)) (* advanced case (p/q n + b)! for p<0 *) FR[(m_. n_ + b_.)!^order_.,n_,a_]:=Module[{p,q,result}, If[SameQ[Head[m],Rational], p=Numerator[m];q=Denominator[m], p=m;q=1 ]; result=a[n] - Pochhammer[b + m n + p + 1,-p]^order a[n + q]; result=Map[Times[1/q^(p order),#]&,result]; Map[Factor,result] == 0 ] /; (order>0) && ((SameQ[Head[m],Rational] && m<0) || (IntegerQ[m] && m<=-1)) FR[(m_. n_ + b_.)!^order_.,n_,a_]:=Module[{p,q,result}, If[SameQ[Head[m],Rational], p=Numerator[m];q=Denominator[m], p=m;q=1 ]; result=Pochhammer[b + m n + p + 1,-p]^(-order) a[n] - a[n + q]; result=Map[Times[1/q^(-p order),#]&,result]; Map[Factor,result] == 0 ] /; (order<0) && ((SameQ[Head[m],Rational] && m<0) || (IntegerQ[m] && m<=-1)) (* nonstandardized input *) FR[Factorial[expr_]^order_.,n_,a_]:=FR[Factorial[Expand[expr]]^order,n,a] /; PolynomialQ[expr,n] && Exponent[expr,n]<2 (* Gamma expressions *) FR[Gamma[f_]^order_.,n_,a_]:=FR[(f-1)!^order,n,a] FR[1/Gamma[f_]^order_.,n_,a_]:=FR[1/(f-1)!^order,n,a] (* Binomial expressions *) FR[Binomial[b_,c_]^order_.,n_,a_]:= FR[Simplify[b!^order*(1/c!^order)*1/(b-c)!^order],n,a] FR[1/Binomial[b_,c_]^order_.,n_,a_]:= FR[Simplify[(1/b!^order)*c!^order*(b-c)!^order],n,a] (* Pochhammer expressions *) FR[Pochhammer[b_,c_]^order_.,n_,a_]:=FR[ Simplify[(b+c-1)!^order*(1/(b-1)!)^order],n,a] FR[1/Pochhammer[b_,c_]^order_.,n_,a_]:=FR[ Simplify[(1/(b+c-1)!^order)*(b-1)!^order],n,a] (* special functions *) FR[PolyGamma[0,n_],n_,a_]:= n*a[n] - (2*n+1)*a[n+1] + (n+1)*a[n+2] == 0 FR[ExpIntegralE[n_,x_],n_,a_]:= -(x a[n]) + (-n + x) a[1 + n] + (1 + n) a[2 + n] == 0 /; FreeQ[x,n] (* AS 5.1.45) *) FR[ExpIntegralE[N_,x_],n_,a_]:=FR[x^(N-1)*Gamma[1-N,x],n,a] FR[Gamma[n_,x_],n_,a_]:=-(n x) a[n] + (1 + n + x) a[1 + n] - a[2 + n] == 0 /; FreeQ[x,n] (* AS (6.5.12) *) FR[Gamma[N_,x_],n_,a_]:=FR[(N-1)!-x^N/N*HypergeometricPFQ[{1},{1+N},x],n,a] FR[Erfc[n_,x_],n_,a_]:=-a[n] + 2 x a[1 + n] + 2 (2 + n) a[2 + n] == 0 /; FreeQ[x,n] (* AS (7.2.12) *) FR[Erfc[N_,x_],n_,a_]:= FR[1/(2^N*Gamma[N/2+1])*HypergeometricPFQ[{(N+1)/2},{1/2},x^2]- x/(2^(N-1)*Gamma[(N+1)/2])*HypergeometricPFQ[{N/2+1},{3/2},x^2],n,a] FR[BesselJ[n_,x_],n_,a_]:=x a[n] - 2 (1 + n) a[1 + n] + x a[2 + n] == 0 /; FreeQ[x,n] (* AS (9.1.69) *) FR[BesselJ[N_,x_],n_,a_]:=FR[(x/2)^N/N!*HypergeometricPFQ[{},{N+1},-x^2/4],n,a] FR[BesselY[n_,x_],n_,a_]:=x a[n] - 2 (1 + n) a[1 + n] + x a[2 + n] == 0 /; FreeQ[x,n] FR[BesselI[n_,x_],n_,a_]:=-(x a[n]) + 2 (1 + n) a[1 + n] + x a[2 + n] == 0 /; FreeQ[x,n] (* AS (9.6.47) *) FR[BesselI[N_,x_],n_,a_]:=FR[(x/2)^N/N!*HypergeometricPFQ[{},{N+1},x^2/4],n,a] FR[BesselK[n_,x_],n_,a_]:=-(x a[n]) - 2 (1 + n) a[1 + n] + x a[2 + n] == 0 /; FreeQ[x,n] (* AS (9.6.48) *) FR[BesselK[N_,x_],n_,a_]:=FR[WhittakerW[0,N,2x],n,a] FR[Hankel1[n_,x_],n_,a_]:= x a[n] - 2 (1 + n) a[1 + n] + x a[2 + n] == 0 /; FreeQ[x,n] FR[Hankel2[n_,x_],n_,a_]:= x a[n] - 2 (1 + n) a[1 + n] + x a[2 + n] == 0 /; FreeQ[x,n] FR[KummerM[n_,m_,x_],n_,a_]:= (1 - m + n) a[n] + (-2 + m - 2 n - x) a[1 + n] + (1 + n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] FR[KummerM[n_,m_,x_],m_,a_]:= m (1 + m) a[m] -((1 + m) (m + x)) a[1 + m] + (1 + m - n) x a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] FR[KummerM[N_,M_,x_],n_,a_]:=FR[Hypergeometric1F1[N,M,x],n,a] FR[KummerU[n_,m_,x_],n_,a_]:= -a[n] + (2 - m + 2 n + x) a[1 + n] + (-2 + m - n) (1 + n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] (* AS (13.4.16) *) FR[KummerU[n_,m_,x_],m_,a_]:= (m - n) a[m] + (-m - x) a[1 + m] + x a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] FR[KummerU[N_,M_,x_],n_,a_]:= FR[Gamma[1-M]*Gamma[M]*(KummerM[N,M,x]/(Gamma[1+N-M]*Gamma[M]) - x^(1-M)*KummerM[1+N-M,2-M,x]/(Gamma[N]*Gamma[2-M])),n,a] FR[WhittakerM[n_,m_,x_],n_,a_]:=(1 - 2 m + 2 n) a[n] + 2 (-2 - 2 n + x) a[1 + n] + (3 + 2 m + 2 n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] FR[WhittakerM[n_,m_,x_],m_,a_]:= 16*(1 + m)*(2 + m)*(1 + 2*m)*(3 + 2*m)^2*x*a[m] + 16*(1 + m)*(2 + m)*(3 + 2*m)*(-3 - 8*m - 4*m^2 + 2*n*x)*a[1 + m] + (1 + 2*m)*(-3 - 2*m + 2*n)*(3 + 2*m + 2*n)*x*a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] (* AS (13.1.32) *) FR[WhittakerM[N_,M_,x_],n_,a_]:= FR[x^M*HypergeometricPFQ[{1/2+M-N},{1+2M},x],n,a] (* AS (13.4.29) *) FR[WhittakerW[n_,m_,x_],n_,a_]:=(1 - 2 m + 2 n) (1 + 2 m + 2 n) a[n] + 4 (2 + 2 n - x) a[1 + n] + 4 a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] (* AS (13.1.34), combined methods *) FR[WhittakerW[n_,m_,x_],m_,a_]:=(3 + 2*m)*(1 + 2*m + 2*n)*x*a[m] + 4*(1 + m)*(3 + 8*m + 4*m^2 - 2*n*x)*a[1 + m] + (1 + 2*m)*(-3 - 2*m + 2*n)*x*a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] (* AS (13.1.34) *) FR[WhittakerW[N_,M_,x_],n_,a_]:= FR[Gamma[-2M]/Gamma[1/2-M-N]*WhittakerM[N,M,x]+ Gamma[2M]/Gamma[1/2+M-N]*WhittakerM[N,-M,x],n,a] FR[LegendreP[n_,m_,x_],n_,a_]:= -((1 + m + n) a[n]) + (3 + 2 n) x a[1 + n] + (-2 + m - n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] (* Gautschi p. 55, (6.1) *) (* FR[LegendreP[n_,m_,x_],m_,a_]:=(m - n) (1 + m + n) a[m] + 2 (1 + m) x a[1 + m]/Sqrt[-1 + x^2] + a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] *) (* AS (8.1.2) *) FR[LegendreP[N_,M_,x_],n_,a_]:=FR[((x+1)/(x-1))^(M/2)/Gamma[1-M]* HypergeometricPFQ[{-N,N+1},{1-M},(1-x)/2],n,a] FR[LegendreQ[n_,m_,x_],n_,a_]:= -((1 + m + n) a[n]) + (3 + 2 n) x a[1 + n] + (-2 + m - n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] (* Gautschi p. 55, (6.1) *) (* FR[LegendreQ[n_,m_,x_],m_,a_]:=(m - n) (1 + m + n) a[m] + 2 (1 + m) x a[1 + m]/Sqrt[-1 + x^2] + a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] *) (* AS (8.1.3) *) FR[LegendreQ[N_,M_,x_],n_,a_]:= FR[E^(I M Pi)*2^(-N-1)*Gamma[N+M+1]/Gamma[N+3/2]*x^(-N-M-1)*(x^2-1)^(M/2)* HypergeometricPFQ[{1+N/2+M/2,1/2+N/2+M/2},{N+3/2},1/x^2],n,a] FR[JacobiP[n_,A_,B_,x_],n_,a_]:= 2 (1 + A + n) (1 + B + n) (4 + A + B + 2 n) a[n] + (3 + A + B + 2 n) (-A^2 + B^2 - 8 x - 6 A x - A^2 x - 6 B x - 2 A B x - B^2 x - 12 n x - 4 A n x - 4 B n x - 4 n^2 x) a[1 + n] + 2 (2 + n) (2 + A + B + n) (2 + A + B + 2 n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[A,n] && FreeQ[B,n] FR[JacobiP[n_,A_,B_,x_],A_,a_]:= 2 (1 + A + n) a[A] + (-4 - 3 A - B - 2 n + 2 x + A x + B x + 2 n x) a[1 + A] + (2 + A + B + n) (1 - x) a[2 + A] == 0 /; FreeQ[x,A] && FreeQ[n,A] && FreeQ[B,A] FR[JacobiP[n_,A_,B_,x_],B_,a_]:=2 (1 + B + n) a[B] + (-4 - A - 3 B - 2 n - 2 x - A x - B x - 2 n x) a[1 + B] + (2 + A + B + n) (1 + x) a[2 + B] == 0 /; FreeQ[x,B] && FreeQ[n,B] && FreeQ[A,B] (* hypergeometric representation *) FR[JacobiP[N_,alpha_,beta_,x_],n_,a_]:=FR[Binomial[N+alpha,N]* Hypergeometric2F1[-N,N+alpha+beta+1,alpha+1,(1-x)/2],n,a] FR[GegenbauerC[n_,m_,x_],n_,a_]:= (2 m + n) a[n] - 2 (1 + m + n) x a[1 + n] + (2 + n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] FR[GegenbauerC[n_,m_,x_],m_,a_]:=(2 m + n) (1 + 2 m + n) a[m] + 2 m (-3 - 4 m - 2 n + 2 x^2 + 2 m x^2 + 2 n x^2) a[1 + m] + 4 m (1 + m) (1 - x) (1 + x) a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] (* hypergeometric representation *) FR[GegenbauerC[N_,lambda_,x_],n_,a_]:=FR[Pochhammer[2*lambda,N]/N!* Hypergeometric2F1[-N,N+2*lambda,lambda+1/2,(1-x)/2],n,a] FR[ChebyshevT[n_,x_],n_,a_]:=a[n] - 2 x a[1 + n] + a[2 + n] == 0 /; FreeQ[x,n] (* hypergeometric representation *) FR[ChebyshevT[N_,x_],n_,a_]:=FR[Hypergeometric2F1[-N,N,1/2,(1-x)/2],n,a] FR[Cos[m_.*Pi*n_],n_,a_]:=FR[Exp[I m Pi]^n,n,a] /; IntegerQ[m] FR[Cos[n_*x_],n_,a_]:=a[n] - 2 Cos[x] a[1 + n] + a[2 + n] == 0 /; FreeQ[x,n] FR[ChebyshevU[n_,x_],n_,a_]:=a[n] - 2 x a[1 + n] + a[2 + n] == 0 /; FreeQ[x,n] (* hypergeometric representation *) FR[ChebyshevU[N_,x_],n_,a_]:=FR[(N+1)*Hypergeometric2F1[-N,N+1,3/2,(1-x)/2],n,a] FR[Sin[m_.*Pi*n_],n_,a_]:=a[n]-a[n-1] == 0 /; IntegerQ[m] FR[Sin[n_*x_.],n_,a_]:=a[n] - 2 Cos[x] a[1 + n] + a[2 + n] == 0 /; FreeQ[x,n] FR[LegendreP[n_,x_],n_,a_]:= (1 + n) a[n] - (3 + 2 n) x a[1 + n] + (2 + n) a[2 + n] == 0 /; FreeQ[x,n] (* hypergeometric representation *) FR[LegendreP[N_,x_],n_,a_]:=FR[Hypergeometric2F1[-N,N+1,1,(1-x)/2],n,a] FR[LaguerreL[n_,m_,x_],n_,a_]:= (1 + m + n) a[n] + (-3 - m - 2 n + x) a[1 + n] + (2 + n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] FR[LaguerreL[n_,m_,x_],m_,a_]:=(1 + m + n) a[m] + (-1 - m - x) a[1 + m] + x a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] FR[LaguerreL[n_,x_],n_,a_]:= (1 + n) a[n] + (-3 - 2 n + x) a[1 + n] + (2 + n) a[2 + n] == 0 /; FreeQ[x,n] (* hypergeometric representation *) FR[LaguerreL[N_,alpha_,x_],n_,a_]:=FR[Binomial[N+alpha,N]* Hypergeometric1F1[-N,alpha+1,x],n,a] FR[LaguerreL[N_,x_],n_,a_]:=FR[Hypergeometric1F1[-N,1,x],n,a] FR[HermiteH[n_,x_],n_,a_]:=2 (1 + n) a[n] - 2 x a[1 + n] + a[2 + n] == 0 /; FreeQ[x,n] (* hypergeometric representation *) FR[HermiteH[N_,x_],n_,a_]:=FR[(-1)^(N/2)/(N/2)!*N!* Hypergeometric1F1[-N/2,1/2,x^2],n,a] FR[factor_.*HypergeometricPFQ[plist_,qlist_,x_],n_,a_]:=Module[{k,j}, FR[Global`sum[factor*Product[Pochhammer[plist[[j]],k],{j,1,Length[plist]}]/ (k!*Product[Pochhammer[qlist[[j]],k],{j,1,Length[qlist]}])*x^k, {k,0,Infinity}],n,a]] FR[Hypergeometric0F1[n_,x_],n_,a_]:= -(n (1 + n) a[n]) + n (1 + n) a[1 + n] + x a[2 + n] == 0 /; FreeQ[x,n] FR[factor_.*Hypergeometric0F1[N_,x_],n_,a_]:= FR[factor*HypergeometricPFQ[{},{N},x],n,a] FR[Hypergeometric1F0[n_,x_],n_,a_]:=a[n] + (-1 + x) a[1 + n] == 0 /; FreeQ[x,n] FR[factor_.*Hypergeometric1F0[N_,x_],n_,a_]:= FR[factor*HypergeometricPFQ[{N},{},x],n,a] FR[Hypergeometric1F1[-n_,n_+B_,x_],n_,a_]:= (1 + n)*(B + n)*(1 + B + n)*(B + 2*n)*(1 + B + 2*n)*(2 + n - x)*a[n] + (1 + B + n)*(B + 2*n)*(1 + B + 2*n)* (-2*B - 2*n - 3*B*n - 3*n^2 - B*n^2 - n^3 - 6*x - 9*n*x - 3*n^2*x + 6*x^2 + B*x^2 + 5*n*x^2 - x^3)*a[1 + n] + (B + 2*n)*(1 + B + 2*n)*(2 + B + 2*n)*(3 + B + 2*n)*(1 + n - x)*x* a[2 + n] == 0 FR[Hypergeometric1F1[-n_,-n_+B_,x_],n_,a_]:= (1 + n)*x*a[n] + (1 - B + n)*(-2 + B - n - x)*a[1 + n] + (1 - B + n)*(2 - B + n)*a[2 + n] == 0 FR[Hypergeometric1F1[n_,m_,x_],n_,a_]:= (1 - m + n) a[n] + (-2 + m - 2 n - x) a[1 + n] + (1 + n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] FR[Hypergeometric1F1[n_,m_,x_],m_,a_]:= m (1 + m) a[m] -((1 + m) (m + x)) a[1 + m] + (1 + m - n) x a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] FR[factor_.*Hypergeometric1F1[N_,M_,x_],n_,a_]:= FR[factor*HypergeometricPFQ[{N},{M},x],n,a] FR[HypergeometricU[n_,m_,x_],n_,a_]:= -a[n] + (2 - m + 2 n + x) a[1 + n] + (-2 + m - n) (1 + n) a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] (* AS (13.4.16) *) FR[HypergeometricU[n_,m_,x_],m_,a_]:= (m - n) a[m] + (-m - x) a[1 + m] + x a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] FR[HypergeometricU[N_,M_,x_],n_,a_]:=FR[KummerU[N,M,x],n,a] FR[Hypergeometric2F0[n_,m_,x_],n_,a_]:= a[n] + (-1 - x + m x - n x) a[1 + n] + (1 + n) x a[2 + n] == 0 /; FreeQ[x,n] && FreeQ[m,n] FR[Hypergeometric2F0[n_,m_,x_],m_,a_]:= a[m] + (-1 - x + n x - m x) a[1 + m] + (1 + m) x a[2 + m] == 0 /; FreeQ[x,m] && FreeQ[n,m] FR[factor_.*Hypergeometric2F0[N_,M_,x_],n_,a_]:= FR[factor*HypergeometricPFQ[{N,M},{},x],n,a] FR[Hypergeometric2F1[n_,m_,o_,x_],n_,a_]:=(-1 - n + o) a[n] + (2 + 2 n - o - x + m x - n x) a[n + 1] + (1 + n) (-1 + x) a[n + 2] == 0 /; FreeQ[x,n] && FreeQ[m,n] && FreeQ[o,n] FR[Hypergeometric2F1[n_,m_,o_,x_],m_,a_]:=(-1 - m + o) a[m] + (2 + 2 m - o - x + n x - m x) a[m + 1] + (1 + m) (-1 + x) a[m + 2] == 0 /; FreeQ[x,m] && FreeQ[n,m] && FreeQ[o,m] FR[Hypergeometric2F1[n_,m_,o_,x_],o_,a_]:=o (1 + o) (1 - x) a[o] + (1 + o) (-o + x - m x - n x + 2 o x) a[1 + o] + (-1 + m - o) (1 - n + o) x a[2 + o] == 0 /; FreeQ[x,o] && FreeQ[n,o] && FreeQ[m,o] FR[Hypergeometric2F1[-n_,-n_+A_.,B_,x_],n_,a_]:= (-1 + A - n)*(A - B - n)*(1 + n)*(B + n)*(3 - A + B + 2*n)*(-1 + x)^2* a[n] + (-2 + A - B - 2*n)*(A - B - n)*(B + n)* (-2 + 2*A - B + A*B - B^2 - 4*n + 2*A*n - 2*B*n - 2*n^2 - x + 2*A*x - A^2*x - 3*B*x + A*B*x - 4*n*x + 2*A*n*x - 2*B*n*x - 2*n^2*x)*a[1 + n]\ + (-1 + A - B - 2*n)*(-1 + A - B - n)*(B + n)*(1 + B + n)*(-A + B + n)* a[2 + n] == 0 FR[Hypergeometric2F1[-n_,n_+A_.,B_,x_],n_,a_]:= (-1 - A + B - n)*(1 + n)*(A + n)*(B + n)*(3 + A + 2*n)*a[n] + (A + n)*(B + n)*(2 + A + 2*n)* (2 + 2*A - B + A*B + 4*n + 2*A*n + 2*n^2 - 3*x - 4*A*x - A^2*x - 8*n*x - 4*A*n*x - 4*n^2*x)*a[1 + n] - (A + n)*(1 + A + n)*(B + n)*(1 + B + n)*(1 + A + 2*n)*a[2 + n] == 0 FR[factor_.*Hypergeometric2F1[A_,B_,C_,x_],n_,a_]:= FR[factor*HypergeometricPFQ[{A,B},{C},x],n,a] FR[Hypergeometric2F3[A_,b_,c_,d_,e_,x_],A_,a_]:= (-1 - A + c)*(-1 - A + d)*(1 + A - e)*a[A] + (-8 - 19*A - 15*A^2 - 4*A^3 + 4*c + 7*A*c + 3*A^2*c + 4*d + 7*A*d + 3*A^2*d - 2*c*d - 2*A*c*d + 4*e + 7*A*e + 3*A^2*e - 2*c*e - 2*A*c*e - 2*d*e - 2*A*d*e + c*d*e + x + A*x - b*x)*a[1 + A] + (1 + A)*(19 + 21*A + 6*A^2 - 5*c - 3*A*c - 5*d - 3*A*d + c*d - 5*e - 3*A*e + c*e + d*e - x)*a[2 + A] + (1 + A)*(2 + A)*(-9 - 4*A + c + d + e)*a[3 + A] + (1 + A)*(2 + A)*(3 + A)*a[4 + A] == 0 /; FreeQ[x,A] && FreeQ[b,A] && FreeQ[c,A] && FreeQ[d,A] && FreeQ[e,A] FR[Hypergeometric2F3[A_,b_,c_,d_,e_,x_],b_,a_]:= (-1 - b + c)*(-1 - b + d)*(1 + b - e)*a[b] + (-8 - 19*b - 15*b^2 - 4*b^3 + 4*c + 7*b*c + 3*b^2*c + 4*d + 7*b*d + 3*b^2*d - 2*c*d - 2*b*c*d + 4*e + 7*b*e + 3*b^2*e - 2*c*e - 2*b*c*e - 2*d*e - 2*b*d*e + c*d*e + x - A*x + b*x)*a[1 + b] + (1 + b)*(19 + 21*b + 6*b^2 - 5*c - 3*b*c - 5*d - 3*b*d + c*d - 5*e - 3*b*e + c*e + d*e - x)*a[2 + b] + (1 + b)*(2 + b)*(-9 - 4*b + c + d + e)*a[3 + b] + (1 + b)*(2 + b)*(3 + b)*a[4 + b] == 0 /; FreeQ[x,b] && FreeQ[A,b] && FreeQ[c,b] && FreeQ[d,b] && FreeQ[e,b] FR[Hypergeometric2F3[A_,b_,c_,d_,e_,x_],c_,a_]:= c*(1 + c)*(2 + c)*(3 + c)*a[c] + (1 + c)*(2 + c)*(3 + c)*(-5 - 3*c + d + e)*a[1 + c] + (2 + c)*(3 + c)*(14 + 13*c + 3*c^2 - 4*d - 2*c*d - 4*e - 2*c*e + d*e - x)*a[2 + c] + (3 + c)*(-18 - 21*c - 8*c^2 - c^3 + 6*d + 5*c*d + c^2*d + 6*e + 5*c*e + c^2*e - 2*d*e - c*d*e + 5*x - A*x - b*x + 2*c*x)*a[3 + c] + (-3 + b - c)*(3 - A + c)*x*a[4 + c] == 0 /; FreeQ[x,c] && FreeQ[A,c] && FreeQ[b,c] && FreeQ[d,c] && FreeQ[e,c] FR[Hypergeometric2F3[A_,b_,c_,d_,e_,x_],d_,a_]:= d*(1 + d)*(2 + d)*(3 + d)*a[d] + (1 + d)*(2 + d)*(3 + d)*(-5 + c - 3*d + e)*a[1 + d] + (2 + d)*(3 + d)*(14 - 4*c + 13*d - 2*c*d + 3*d^2 - 4*e + c*e - 2*d*e - x)*a[2 + d] + (3 + d)*(-18 + 6*c - 21*d + 5*c*d - 8*d^2 + c*d^2 - d^3 + 6*e - 2*c*e + 5*d*e - c*d*e + d^2*e + 5*x - A*x - b*x + 2*d*x)* a[3 + d] + (-3 + b - d)*(3 - A + d)*x*a[4 + d] == 0 /; FreeQ[x,d] && FreeQ[A,d] && FreeQ[b,d] && FreeQ[c,d] && FreeQ[e,d] FR[Hypergeometric2F3[A_,b_,c_,d_,e_,x_],e_,a_]:= e*(1 + e)*(2 + e)*(3 + e)*a[e] + (-5 + c + d - 3*e)*(1 + e)*(2 + e)*(3 + e)*a[1 + e] + (2 + e)*(3 + e)*(14 - 4*c - 4*d + c*d + 13*e - 2*c*e - 2*d*e + 3*e^2 - x)*a[2 + e] + (3 + e)*(-18 + 6*c + 6*d - 2*c*d - 21*e + 5*c*e + 5*d*e - c*d*e - 8*e^2 + c*e^2 + d*e^2 - e^3 + 5*x - A*x - b*x + 2*e*x)*a[3 + e] + (-3 + b - e)*(3 - A + e)*x*a[4 + e] == 0 /; FreeQ[x,e] && FreeQ[A,e] && FreeQ[b,e] && FreeQ[c,e] && FreeQ[d,e] FR[factor_.*Hypergeometric2F3[N_,M_,O_,P_,Q_,x_],n_,a_]:= FR[factor*HypergeometricPFQ[{N,M},{O,P,Q},x],n,a] FR[Hypergeometric3F2[A_,b_,c_,d_,e_,x_],A_,a_]:= (-1 - A + d) (-1 - A + e) a[A] + (-4 - 7 A - 3 A^2 + 2 d + 2 A d + 2 e + 2 A e - d e + x + 2 A x + A^2 x - b x - A b x - c x - A c x + b c x) a[1 + A] + (1 + A) (5 + 3 A - d - e - 3 x - 2 A x + b x + c x) a[2 + A] + (1 + A) (2 + A) (-1 + x) a[3 + A] == 0 /; FreeQ[x,A] && FreeQ[b,A] && FreeQ[c,A] && FreeQ[d,A] && FreeQ[e,A] FR[Hypergeometric3F2[A_,b_,c_,d_,e_,x_],b_,a_]:= (-1 - b + d) (-1 - b + e) a[b] + (-4 - 7 b - 3 b^2 + 2 d + 2 b d + 2 e + 2 b e - d e + x - A x + 2 b x - A b x + b^2 x - c x + A c x - b c x) a[1 + b] + (1 + b) (5 + 3 b - d - e - 3 x + A x - 2 b x + c x) a[2 + b] + (1 + b) (2 + b) (-1 + x) a[3 + b] == 0 /; FreeQ[x,b] && FreeQ[A,b] && FreeQ[c,b] && FreeQ[d,b] && FreeQ[e,b] FR[Hypergeometric3F2[A_,b_,c_,d_,e_,x_],c_,a_]:= (-1 - c + d) (-1 - c + e) a[c] + (-4 - 7 c - 3 c^2 + 2 d + 2 c d + 2 e + 2 c e - d e + x - A x - b x + A b x + 2 c x - A c x - b c x + c^2 x) a[1 + c] + (1 + c) (5 + 3 c - d - e - 3 x + A x + b x - 2 c x) a[2 + c] + (1 + c) (2 + c) (-1 + x) a[3 + c] == 0 /; FreeQ[x,c] && FreeQ[A,c] && FreeQ[b,c] && FreeQ[d,c] && FreeQ[e,c] FR[Hypergeometric3F2[A_,b_,c_,d_,e_,x_],d_,a_]:= d (1 + d) (2 + d) (1 - x) a[d] + (1 + d) (2 + d) (-2 - 2 d + e + 3 x - A x - b x - c x + 3 d x) a[1 + d] + (2 + d) (2 + 3 d + d^2 - e - d e - 7 x + 3 A x + 3 b x - A b x + 3 c x - A c x - b c x - 9 d x + 2 A d x + 2 b d x + 2 c d x - 3 d^2 x) a[2 + d] + (-2 + A - d) (-2 + c - d) (2 - b + d) x a[3 + d] == 0 /; FreeQ[x,d] && FreeQ[A,d] && FreeQ[b,d] && FreeQ[c,d] && FreeQ[e,d] FR[Hypergeometric3F2[A_,b_,c_,d_,e_,x_],e_,a_]:= e (1 + e) (2 + e) (1 - x) a[e] + (1 + e) (2 + e) (-2 + d - 2 e + 3 x - A x - b x - c x + 3 e x) a[1 + e] + (2 + e) (2 - d + 3 e - d e + e^2 - 7 x + 3 A x + 3 b x - A b x + 3 c x - A c x - b c x - 9 e x + 2 A e x + 2 b e x + 2 c e x - 3 e^2 x) a[2 + e] + (-2 + A - e) (-2 + c - e) (2 - b + e) x a[3 + e] == 0 /; FreeQ[x,e] && FreeQ[A,e] && FreeQ[b,e] && FreeQ[c,e] && FreeQ[d,e] FR[factor_.*Hypergeometric3F2[A_,B_,C_,D_,E_,x_],n_,a_]:= (* Module[{k}, FR[Sum[factor*Pochhammer[A,k]*Pochhammer[B,k]*Pochhammer[C,k]/( k!*Pochhammer[D,k]*Pochhammer[E,k])*x^k,{k,0,Infinity}],n,a]] *) FR[factor*HypergeometricPFQ[{A,B,C},{D,E},x],n,a] FR[StruveH[n_,x_],n_,a_]:=-(x^2 a[n]) + (7 + 4 n) x a[1 + n] - (20 + 18 n + 4 n^2 + x^2) a[2 + n] + (5 + 2 n) x a[3 + n] == 0 /; FreeQ[x,n] (* AS (12.1.3) *) FR[StruveH[N_,x_],n_,a_]:=Module[{k}, FR[(x/2)^(N+1)*Sum[(-1)^k*(x/2)^(2k)/(Gamma[k+3/2]*Gamma[k+N+3/2]), {k,0,Infinity}],n,a] ] FR[StruveL[n_,x_],n_,a_]:=x^2 a[n] - (7 + 4 n) x a[1 + n] + (20 + 18 n + 4 n^2 - x^2) a[2 + n] + (5 + 2 n) x a[3 + n] == 0 /; FreeQ[x,n] (* AS (12.2.1) *) FR[StruveL[N_,x_],n_,a_]:=Module[{k}, FR[(x/2)^(N+1)*Sum[(x/2)^(2k)/(Gamma[k+3/2]*Gamma[k+N+3/2]), {k,0,Infinity}],n,a] ] FR[Ai[n_,x_],n_,a_]:=(-1 - n) a[n] - x a[1 + n] + a[3 + n] == 0 /; FreeQ[x,n] FR[Abramowitz[n_,x_],n_,a_]:= -(x a[n]) + (-2 - n) a[1 + n] + 2 a[3 + n] == 0 /; FreeQ[x,n] FR[NormalIntegral[n_,x_],n_,a_]:= -a[n] + x a[1 + n] + (2 + n) a[2 + n] == 0 /; FreeQ[x,n] (* AS (26.2.40) *) (* NormalIntegral[n_,x_]==1/Sqrt[2 Pi]*E^(-x^2/4)*ParabolicU[n+1/2,x] *) FR[NormalIntegral[N_,x_],n_,a_]:=FR[ParabolicU[N+1/2,x],n,a] FR[KnuthA[n_,x_],n_,a_]:=-a[n] - x a[1 + n] + (1 + n) a[3 + n] == 0 /; FreeQ[x,n] FR[KnuthB[n_,x_],n_,a_]:=-a[n] - x a[1 + n] + (1 + n) a[3 + n] == 0 /; FreeQ[x,n] (* hypergeometric representation of Knuth functions, p. 49 FR[KnuthB[N_,x_],n_,a_]:= FR[1/(3^((N+1)/3)*Gamma[(N+1)/3])* HypergeometricPFQ[{(2-N)/6,(5-N)/6},{1/3,2/3},x^3/6]+ 1/(3^((N-1)/3)*Gamma[(N-1)/3])*x/2* HypergeometricPFQ[{(4-N)/6,(7-N)/6},{2/3,4/3},x^3/6]+ 1/(3^((N-3)/3)*Gamma[(N-3)/3])*x^2/8* HypergeometricPFQ[{(6-N)/6,(9-N)/6},{4/3,5/3},x^3/6],n,a] *) FR[ParabolicU[n_,x_],n_,a_]:= -2 a[n] + 2 x a[1 + n] + (3 + 2 n) a[2 + n] == 0 /; FreeQ[x,n] (* AS (19.12.2) FR[ParabolicU[N_,x_],n_,a_]:= FR[2^(-N/2)*WhittakerW[-N/2,-1/4,x^2/2],n,a] *) (* AS (19.12.3) *) FR[ParabolicU[N_,x_],n_,a_]:= FR[2^(-1/4-N/2)/Gamma[3/4+N/2]*HypergeometricPFQ[{N/2+1/4},{1/2},x^2/2]- 2^(1/4-N/2)/Gamma[1/4+N/2]* HypergeometricPFQ[{N/2+3/4},{3/2},x^2/2],n,a] FR[ParabolicD[n_,x_],n_,a_]:=(1 + n) a[n] - x a[1 + n] + a[2 + n] == 0 /; FreeQ[x,n] (* AS (19.3.7) *) FR[ParabolicD[N_,x_],n_,a_]:=FR[ParabolicU[-N-1/2,x],n,a] FR[ParabolicV[n_,x_],n_,a_]:=-((1 + 2 n) a[n]) - 2 x a[1 + n] + 2 a[2 + n] == 0 /; FreeQ[x,n] (* AS (19.4.2) *) FR[ParabolicV[N_,x_],n_,a_]:=FR[ Gamma[1/2+N]*(Pi/(Gamma[N]*Gamma[1-N])*ParabolicU[N,x]+ParabolicU[N,-x]),n,a] FR[Bateman[n_,x_],n_,a_]:= n a[n] + 2 (1 + n - x) a[1 + n] + (2 + n) a[2 + n] == 0 /; FreeQ[x,n] FR[Bateman[N_,x_],n_,a_]:=FR[-2*E^(-x)* HypergeometricPFQ[{1-N},{2},2x],n,a] FR[Krawtchouk[n_,N_,p_,x_],n_,a_]:= (n - N) (-1 + p) p a[n] + (1 + n - 2 p - 2 n p + N p - x) a[1 + n] + (2 + n) a[2 + n] == 0 /; FreeQ[N,n] && FreeQ[x,n] && FreeQ[p,n] FR[Krawtchouk[n_,N_,p_,x_],N_,a_]:= (1 + N - x) a[N] + (-3 + n - 2 N + 2 p + N p + x) a[1 + N] + (2 - n + N) (1 - p) a[2 + N] == 0 /; FreeQ[n,N] && FreeQ[x,N] && FreeQ[p,N] FR[Krawtchouk[n_,N_,p_,x_],x_,a_]:= (-1 + p) (1 + x) a[x] + (1 - n - 2 p + N p + x - 2 p x) a[1 + x] + p (1 - N + x) a[2 + x] == 0 /; FreeQ[n,x] && FreeQ[N,x] && FreeQ[p,x] FR[Krawtchouk[n_,N_,p_,x_],m_,a_]:= FR[(-1)^n*Binomial[N,n]*p^n*Hypergeometric2F1[-n,-x,-N,1/p],m,a] FR[Charlier[n_,mu_,x_],n_,a_]:= (1 + n) a[n] + (-1 - mu - n + x) a[1 + n] + mu a[2 + n] == 0 /; FreeQ[mu,n] && FreeQ[x,n] FR[Charlier[n_,mu_,x_],x_,a_]:= (-1 - x) a[x] + (1 + mu - n + x) a[1 + x] - mu a[2 + x] == 0 /; FreeQ[mu,x] && FreeQ[n,x] FR[Charlier[n_,mu_,x_],m_,a_]:= FR[Hypergeometric2F0[-n,-x,-1/mu],m,a] FR[Meixner[n_,gamma_,mu_,x_],n_,a_]:= (1 + n) (gamma + n) a[n] + (-1 - mu - gamma mu - n - mu n + x - mu x) a[1 + n] + mu a[2 + n] == 0 /; FreeQ[gamma,n] && FreeQ[mu,n] && FreeQ[x,n] FR[Meixner[n_,gamma_,mu_,x_],gamma_,a_]:=(gamma + n) a[gamma] + (-1 - 2 gamma + mu + gamma mu - n + mu n - x + mu x) a[1 + gamma] + (1 - mu) (1 + gamma + x) a[2 + gamma] == 0 /; FreeQ[n,gamma] && FreeQ[mu,gamma] && FreeQ[x,gamma] FR[Meixner[n_,gamma_,mu_,x_],x_,a_]:= (1 + x) a[x] + (-1 - mu - gamma mu + n - mu n - x - mu x) a[1 + x] + mu (1 + gamma + x) a[2 + x] == 0 /; FreeQ[n,x] && FreeQ[mu,x] && FreeQ[gamma,x] FR[Meixner[n_,gamma_,mu_,x_],m_,a_]:= FR[Pochhammer[gamma,n]*Hypergeometric2F1[-n,-x,gamma,1-1/mu],m,a] FR[DiscreteChebyshev[n_,N_,x_],n_,a_]:=FR[Hahn[n,N,0,0,x],n,a] /; FreeQ[N,n] && FreeQ[x,n] FR[DiscreteChebyshev[n_,N_,x_],N_,a_]:=FR[Hahn[n,N,0,0,x],N,a] /; FreeQ[n,N] && FreeQ[x,N] FR[DiscreteChebyshev[n_,N_,x_],x_,a_]:=FR[Hahn[n,N,0,0,x],x,a] /; FreeQ[n,x] && FreeQ[N,x] FR[DiscreteChebyshev[n_,N_,x_],m_,a_]:= R[Hahn[n,N,0,0,x],m,a] FR[DiscreteLaguerre[n_,rho_,alpha_,x_],n_,a_]:=(1 + alpha + n) rho a[n] + (-2 - n - rho - alpha rho - n rho + x - rho x) a[1 + n] + (2 + n) a[2 + n] == 0 /; FreeQ[rho,n] && FreeQ[alpha,n] && FreeQ[x,n] FR[DiscreteLaguerre[n_,rho_,alpha_,x_],alpha_,a_]:=(1 + alpha + n) a[alpha] + (-2 - 2 alpha - n + rho + alpha rho + n rho - x + rho x) a[1 + alpha] + (1 - rho) (1 + alpha + x) a[2 + alpha] == 0 /; FreeQ[rho,alpha] && FreeQ[n,alpha] && FreeQ[x,alpha] FR[DiscreteLaguerre[n_,rho_,alpha_,x_],x_,a_]:= x a[x] + (n - rho - alpha rho - n rho - x - rho x) a[1 + x] + rho (1 + alpha + x) a[2 + x] == 0 /; FreeQ[n,x] && FreeQ[rho,x] && FreeQ[alpha,x] FR[DiscreteLaguerre[n_,rho_,alpha_,x_],m_,a_]:=FR[ Pochhammer[1+alpha,n]*rho^n/n!* Hypergeometric2F1[-n,-x+1,1+alpha,1-1/rho],m,a] FR[Hahn[n_,N_,alpha_,beta_,x_],n_,a_]:= (N - n - 1) (n + 1 + alpha) (beta + 1 + n) (2 n + 4 + beta + alpha)* (n + 1 + alpha + beta + N) a[n] - (3+2*n+beta+alpha)*(4+6*n+8*x+5*beta+alpha+2*alpha*x*beta-2*n*N*beta- alpha*N*beta+4*x*n*alpha-2*alpha*N*n+6*x*alpha-4*N+x*alpha^2-n*alpha^2+ 4*n*x*beta+2*beta^2-6*N*n+6*x*beta+12*x*n+5*n*beta+2*n^2-3*N*beta-alpha^2- 2*N*n^2+4*x*n^2+n^2*beta-alpha*n^2-N*beta^2+x*beta^2+n*beta^2-alpha*n+ alpha*beta-3*alpha*N)*a[n+1]+ (n + 2) (n + 2 + alpha + beta) (2 n + 2 + beta + alpha) a[n+2] ==0 /; FreeQ[N,n] && FreeQ[alpha,n] && FreeQ[beta,n] && FreeQ[x,n] FR[Hahn[n_,N_,alpha_,beta_,x_],N_,a_]:= (1 + alpha + beta + n + N) (N - x) a[N] + (-1 - alpha + n + alpha n + beta n + n^2 - 3 N - 2 alpha N - beta N - 2 N^2 + 2 x + alpha x + beta x + 2 N x) a[1 + N] + (-1 + n - N) (-1 - alpha - N + x) a[2 + N] == 0 /; FreeQ[n,N] && FreeQ[alpha,N] && FreeQ[beta,N] && FreeQ[x,N] FR[Hahn[n_,N_,alpha_,beta_,x_],alpha_,a_]:= (1 + alpha + n) (1 + alpha + beta + n + N) a[alpha] + (-3 - 5 alpha - 2 alpha^2 - 2 beta - 2 alpha beta - 3 n - 3 alpha n - beta n - n^2 - 3 N - 2 alpha N - beta N - 2 n N + 2 x + alpha x + beta x + 2 n x) a[1 + alpha] + (2 + alpha + beta + n) (1 + alpha + N - x) a[2 + alpha] == 0 /; FreeQ[n,alpha] && FreeQ[N,alpha] && FreeQ[beta,alpha] && FreeQ[x,alpha] FR[Hahn[n_,N_,alpha_,beta_,x_],beta_,a_]:= (1 + beta + n) (1 + alpha + beta + n + N) a[beta] + (-5 - 3 alpha - 6 beta - 2 alpha beta - 2 beta^2 - 5 n - alpha n - 3 beta n - n^2 - N - beta N - 2 x - alpha x - beta x - 2 n x) a[1 + beta] + (2 + alpha + beta + n) (2 + beta + x) a[2 + beta] == 0 /; FreeQ[n,beta] && FreeQ[N,beta] && FreeQ[alpha,beta] && FreeQ[x,beta] FR[Hahn[n_,N_,alpha_,beta_,x_],x_,a_]:=(-1 + alpha + N - x) (1 + x) a[x] + (5 - alpha + 2 beta + n + alpha n + beta n + n^2 - 3 N - beta N + 6 x - alpha x + beta x - 2 N x + 2 x^2) a[1 + x] + (-2 + N - x) (2 + beta + x) a[2 + x] == 0 /; FreeQ[n,x] && FreeQ[N,x] && FreeQ[alpha,x] && FreeQ[beta,x] FR[Hahn[n_,N_,alpha_,beta_,x_],m_,a_]:= FR[(-1)^n/n!*Pochhammer[beta+x+1,n]*Pochhammer[N-x-n,n]* HypergeometricPFQ[{-n,-x,alpha+N-x},{N-x-n,-beta-x-n},1],m,a] (* indefinite and infinite sums *) FR[Global`sum[expr_,{k_,0_,n_+m_}],n_,a_]:=Module[{fr,kk}, fr=FR[Global`sum[expr,{k,0,n}],n,a][[1]]; fr=fr/.n->n+m; Map[Factor,fr/.a[kk_]->a[kk-m]] == 0 ] FR[Global`sum[expr_,{k_,k1_,k2_}],n_,a_]:= FR[Global`sum[expr/.k->k+k1,{k,0,k2-k1}],n,a] /; FreeQ[expr,n] && FreeQ[k1,n] && Not[SameQ[k1,0]] Off[Sum::itform] MaxZeilbergerOrder=5 (* FR[factor_.*Sum[expr_,{k_,k1_,k2_}],n_,a_]:=Module[ {aaa,re,de1,de2,de,x,F,zb,order,X,eq1,eq2,coefflist,jj,aa,tmpexpr,kk}, zb={}; tmpexpr=factor*expr /. Pochhammer[aa_,jj_]->Gamma[aa+jj]/Gamma[aa]; tmpexpr=tmpexpr /. Gamma[aa_]->(aa-1)!; order=1; If[Not[FreeQ[expr,n]], While[SameQ[zb,{}]&&order<=MaxZeilbergerOrder, If[SpecialFunctionsPrintMessages, Print["specfun-info: Zeilberger algorithm entered, order = ",order]]; zb=Simplify[fastZeil`Zb[tmpexpr,{k,k1,k2},n,order]];order=order+1], (* End If *) zb="Zeilberger algorithm not applicable"]; If[(SameQ[order,MaxZeilbergerOrder+1] || (FreeQ[expr,n] && (* SameQ[zb,"input not interpretable"]*) SameQ[Head[zb],String] )) && FreeQ[expr,n], (* second try, currently Koepf *) If[SameQ[k2,n] && FreeQ[k1,n], If[SpecialFunctionsPrintMessages, Print["specfun-info: Zeilberger algorithm fails"]; Print["specfun-info: Koepf algorithm entered"]]; re=FR[tmpexpr,k,aaa]; re=Map[Times[k+1-k1,#]&,re[[1]]]==0; de1=RETODE[re,aaa,k,F,x]; de2=F[x]+(-1+x)*F'[x]; (* SimpleDE[1/(1-z),z] *) de=DEProduct[de1,de2,F,x]; (* here assumed k2=n, and k1 independent of n *) zb=DEtoRE[de,F,x,aaa,n], Return[HoldForm[FR[factor*Sum[expr,{k,k1,k2}],n,a]]]]; (* Return[] *), (* Else *) If[SameQ[Head[zb],String], Return[HoldForm[FR[factor*Sum[expr,{k,k1,k2}],n,a]]]]; If[SameQ[order,1],Return[FR[zb[[1,2]],n,a]]]; zb=(zb/.fastZeil`Delta[kk_,nn_]->0); zb=(zb/.fastZeil`F[kk_,nn_]->a[nn]); If[SameQ[zb[[1,2]],0],zb=(zb[[1,1]]/.fastZeil`SUM->a) == 0, If[SpecialFunctionsPrintMessages, Print["specfun-info: inhomogeneous RE encountered: ",zb]]; eq1=zb[[1]]; eq1=(eq1/.fastZeil`F[k, kk_]->fastZeil`SUM[kk]); eq2=zb[[1]]/.n->n+1; zb=eq2[[1]]-eq2[[2]] eq1[[1]]/eq1[[2]]; (* Achtung: Hier muss noch ausgebaut werden: FindRecursion[eq1,n,a] zeigt, welche Linearkombination zum Ziel fuehrt... *) zb=Numerator[Together[zb]]; (* zb=(zb/.fastZeil`SUM[n+kk_.]->X^kk); *) zb=(zb/.fastZeil`F[k,n+kk_.]->X^kk); coefflist=CoefficientList[zb,X]; zb=Sum[Factor[coefflist[[jj]]] a[n+jj-1],{jj,1,Length[coefflist]}] == 0 ]; (* End If *) ]; (* End Else *) zb/.aaa->a ] *) FR[factor_.*Global`sum[expr_,{k_,k1_,k2_}],n_,a_]:=Module[ {aaa,re,de1,de2,de,x,F,zb,order,X,eq1,eq2,coefflist,jj,aa,tmpexpr,kk}, zb={}; tmpexpr=factor*expr /. Pochhammer[aa_,jj_]->Gamma[aa+jj]/Gamma[aa]; tmpexpr=tmpexpr /. Gamma[aa_]->(aa-1)!; order=1; If[Not[FreeQ[expr,n]], While[SameQ[zb,{}]&&order<=MaxZeilbergerOrder, If[SpecialFunctionsPrintMessages, Print["specfun-info: Zeilberger algorithm entered, order = ",order]]; zb=fastZeil`Zb[tmpexpr,{k,k1,k2},n,order];order=order+1], (* End If *) zb="Zeilberger algorithm not applicable"]; If[(SameQ[order,MaxZeilbergerOrder+1] || (FreeQ[expr,n] && (* SameQ[zb,"input not interpretable"]*) SameQ[Head[zb],String] )) && FreeQ[expr,n], (* second try, currently Koepf *) If[SameQ[k2,n] && FreeQ[k1,n], If[SpecialFunctionsPrintMessages, Print["specfun-info: Zeilberger algorithm fails"]; Print["specfun-info: Koepf algorithm entered"]]; re=FR[tmpexpr,k,aaa]; re=Map[Times[k+1-k1,#]&,re[[1]]]==0; de1=RETODE[re,aaa,k,F,x]; de2=F[x]+(-1+x)*F'[x]; (* SimpleDE[1/(1-z),z] *) de=DEProduct[de1,de2,F,x]; (* here assumed k2=n, and k1 independent of n *) zb=DEtoRE[de,F,x,aaa,n], Return[HoldForm[FR[factor*Sum[expr,{k,k1,k2}],n,a]]]]; (* Return[] *), (* Else *) If[SameQ[Head[zb],String], Return[HoldForm[FR[factor*Sum[expr,{k,k1,k2}],n,a]]]]; If[SameQ[order,1],Return[FR[zb[[1,2]],n,a]]]; (* in Mathematica 4 gibt es hier eine andere Reihenfolge! If[SameQ[zb[[1,2]],0],zb=(zb[[1,1]]/.fastZeil`SUM->a) == 0, *) If[SameQ[zb[[1,2]],0],zb=(zb[[1,1]]/.fastZeil`SUM->a) == 0, If[SpecialFunctionsPrintMessages, Print["specfun-info: inhomogeneous RE encountered: ",zb]]; eq1=zb[[1]]; eq2=zb[[1]]/.n->n+1; zb=eq2[[1]]-eq2[[2]] eq1[[1]]/eq1[[2]]; (* Achtung: Hier muss noch ausgebaut werden: FindRecursion[eq1,n,a] zeigt, welche Linearkombination zum Ziel fuehrt... *) zb=Numerator[Together[zb]]; zb=(zb/.fastZeil`SUM[n+kk_.]->X^kk); coefflist=CoefficientList[zb,X]; zb=Sum[Factor[coefflist[[jj]]] a[n+jj-1],{jj,1,Length[coefflist]}] == 0 ]; (* End If *) ]; (* End Else *) zb/.aaa->a ] (* sum algorithm *) (* old FR[f_+g_,n_,a_]:=SumRE[FR[f,n,a],FR[g,n,a],a,n] *) FR[f_+g_,n_,a_]:=Module[{fre,gre,result}, fre=FR[f,n,a]; gre=FR[g,n,a]; If[Not[SameQ[Head[fre],HoldForm] || SameQ[Head[gre],HoldForm] || SameQ[Head[fre],FR] || SameQ[Head[gre],FR]], result=SumRE[fre,gre,a,n], result=HoldForm[FR[f+g,n,a]]]; result ] (* product algorithm *) (* old FR[f_*g_,n_,a_]:=ProductRE[FR[f,n,a],FR[g,n,a],a,n] *) FR[f_*g_,n_,a_]:=Module[{fre,gre,result}, fre=FR[f,n,a]; gre=FR[g,n,a]; If[Not[SameQ[Head[fre],HoldForm] || SameQ[Head[gre],HoldForm] || SameQ[Head[fre],FR] || SameQ[Head[gre],FR]], result=ProductRE[fre,gre,a,n], result=HoldForm[FR[f*g,n,a]]]; result ] (* iterative products *) FR[f_^m_,n_,a_]:=PowerRE[FR[f,n,a],a,n,m] /; IntegerQ[m] && m>0 FR[f_^m_,n_,a_]:=PowerRE[FR[1/f,n,a],a,n,-m] /; IntegerQ[m] && m<0 (* shifts *) (* HypergeometricPFQ fehlt *) FR[f_[b___,n_+n0_,c___],n_,a_]:=Module[{tmp,kk}, tmp=FR[f[b,n,c],n,a][[1]]; tmp=(tmp /. n->n+n0); tmp=(tmp /. a[kk_]->a[kk-n0]); tmp=(tmp /. a[kk_]->a[Hold[Simplify[kk]]]); tmp=(tmp /. Hold[kk_]->kk); Map[Factor,tmp] == 0 ] /; Module[{tmp}, Off[FreeQ::level]; tmp=FreeQ[{b},n] && FreeQ[{c},n] && FreeQ[n0,n]; On[FreeQ::level]; tmp] (* /; FreeQ[b,n] && FreeQ[c,n] && FreeQ[n0,n] *) FR[f_[b___,-n_,c___],n_,a_]:=Module[{tmp,kk,numberlist,max}, tmp=FR[f[b,n,c],n,a][[1]]; numberlist=Union[Map[Plus[#,-n]&,Cases[Cases[tmp,a[n+_.],3],n+_.,2]]]; max=Max[numberlist]; tmp=(tmp /. n->-n); tmp=(tmp /. a[kk_]->a[-kk]); tmp=(tmp /. a[kk_]->a[Hold[Simplify[kk]]]); tmp=(tmp /. Hold[kk_]->kk); Map[Factor,tmp /. n->n+max] == 0 ] /; Module[{tmp}, Off[FreeQ::level]; tmp=FreeQ[{b},n] && FreeQ[{c},n]; On[FreeQ::level]; tmp] (* currently eliminated FR[f_[b___,-n_+n0_,c___],n_,a_]:=Module[{tmp,kk,numberlist,max}, tmp=FR[f[b,-n,c],n,a][[1]]; numberlist=Union[Map[Plus[#,-n]&,Cases[Cases[tmp,a[n+_.],3],n+_.,2]]]; max=Max[numberlist]; tmp=(tmp /. n->n-n0); tmp=(tmp /. a[kk_]->a[kk+n0]); tmp=(tmp /. a[kk_]->a[Hold[Simplify[kk]]]); tmp=(tmp /. Hold[kk_]->kk); Map[Factor,tmp] == 0 ] /; Module[{tmp}, Off[FreeQ::level]; tmp=FreeQ[{b},n] && FreeQ[{c},n] && FreeQ[n0,n]; On[FreeQ::level]; tmp] *) FR[f___]:=HoldForm[HolonomicRE[f]]; Null (* end identity.m *) Clear[simpleDE,DEtoRE,SimpleRE] (* simpleDE[fkt_,x_]:=simpleDE[fkt,x,5,Global`f] simpleDE[fkt_,x_,max_]:=simpleDE[fkt,x,max,Global`f]/; SameQ[Head[max],Integer]||SameQ[Head[max],DirectedInfinity] simpleDE[fkt_,x_,F_]:=simpleDE[fkt,x,5,F]/; SameQ[Head[F],Symbol] simpleDE[fkt_,x_,max_,F_]:=Module[{}, Print["specfun-info: ",x," is not a valid variable"]; HoldForm[simpleDE[fkt,x,max,F]]]/;!SameQ[Head[x],Symbol] simpleDE[fkt_,x_,max_,f_]:=Module[{}, Print["specfun-warning: Please Clear[f], or use another symbol as fourth argument of FindRecursion."]; HoldForm[simpleDE[fkt,x,max,f]]]/;(!SameQ[Head[f],Symbol]|| !SameQ[ToString[Head[f[anything___]]],"f"]) *) simpleDE[fkt_,x_,max_,F_]:=Module[ {init,shift,xpotenz,simplesummand,result,recursfac,recnomil,recdomil, summand,recnomil0,recdomil0,ddff,df,ex,pmax,conomi,domi,dep,de, listzero,listvar,difflist,sum,finalsum,testlist,list,equ,lnew,length, j,i,solution,denomil,sollist,m,p,de0,n,errorval,a,newlist, lcm,nn}, (* If[SpecialFunctionsPrintMessages,Print[specfuninfo]]; *) ListOfIndependentTerms[list1_,xx_]:= Module[{lnew, length,first,fraction,sum,i}, lnew = {}; length = Length[list1]; first = list1[[1]]; sum = first; For[i=2, i<=length, i++, fraction = Factor[Cancel[first/list1[[i]]]]; If [RationalQ[fraction,xx], sum += list1[[i]], (* rat. dependent *) AppendTo[lnew,list1[[i]]] (* rat. indep *) ] (* if *) ]; (* for *) Flatten[{sum,ListOfIndependentTerms[lnew,xx]}] ]/;(Length[list1]>1); ListOfIndependentTerms[list1_,xx_]:= Flatten[{list1}]/;(Length[list1]<2); lcm[{}]:=1; lcm[a_]:=Module[{j}, PolynomialLCM[First[a],lcm[Rest[a]]] ]; (* main *) dep=pmax; (* init for search of rat. derivative *) If[Not[FreeQ[fkt,GegenbauerC[kkk_,0,xxx_]]], Gegenbauer0Print[fkt]; Return[HoldForm[simpleDE[fkt,x,max,F]]] ]; If[Not[FreeQ[fkt,GegenbauerC[kkk_,aaa_,xxx_]]], GegenbauerWarning[fkt,{}]]; If[!FreeQ[fkt,F]||!FreeQ[x,F], Print[ "specfun-warning: the symbol F is used in the differential equation."]]; errorval=(*SequenceForm["ps[",*) HoldForm[fkt](*, ",", max, "]"]*); pmax = max; df[0] = fkt/.transformspecial1; If[SameQ[df[0],0], co[0]=0, (* search for a differential equation of maximal order pmax (default=5) *) (* search for a differential equation of order 1 *) df[1] = D[df[0],x]; sum = df[1] + a[0] * df[0]; length = Length[reclist]; For[i= 1,i<=length,++i, If[Not[FreeQ[sum,Head[reclist[[i,1]]]]], sum = SimpByRecursion[sum,reclist[[i]] ]; ]; (* if not *) ]; (* for *) co[0] = Together[Expand[ -df[1]/df[0] ]] ]; nomi=Numerator[co[0]]; domi=Denominator[co[0]]; dep=pmax; (*init fuer rat. derivative search*) If [RationalQ[co[0],x], de = diff[f,x]*domi + nomi * f; dep= 1, (* search for a differential equation of higher order *) de = Null; listzero = {0}; listvar = {a[0]}; difflist = {f,diff[f,x,1]}; For [p=2, p<=pmax, p++, df[p] = D[df[p-1],x]; (* formal setting of differential equation *) sum = df[p] + Sum[a[ii]*df[ii],{ii,0,p-1}]; length = Length[reclist]; For[i= 1,i<=length,++i, If[Not[FreeQ[sum,Head[reclist[[i,1]]]]], sum = SimpByRecursion[sum,reclist[[i]] ]; ]; (* if not *) ]; (* for *) finalsum = Numerator[Together[sum]]; testlist= Level[Expand[finalsum],1]; list= Level[Expand[finalsum],1]; equ = {}; (* find rational independent terms *) equ = ListOfIndependentTerms[list,x]; equ1[p]= equ; (* find coefficients of differential equation *) listzero=Table[0,{Length[equ]}]; AppendTo [listvar,a[p-1]]; AppendTo [difflist,diff[f,x,p]]; Off[Solve::svars]; solution = Solve[equ==listzero,listvar]; On[Solve::svars]; If [solution!={}, If[SameQ[listzero, Simplify[equ /. solution[[1]]]], denomil={}; sollist = solution[[1]]; For [m=1, m<=p, m++, index = sollist[[m,1]] /. a[in_] -> in; co[index] = Simplify[sollist[[m,2]]]; AppendTo[denomil, Denominator[Together[co[index]]] ] ]; denomi = lcm[denomil]; co[p] = 1; de = co[0] * f; For [m=1, m<=p, m++, de= co[m] * diff[f,x,m] + de]; de = Expand[de]; de = If[SameQ[Head[de],diff], de*denomi, Sum[ de[[si]]*denomi, {si,Length[de]}] ]; de = Simplify[de]; de = Collect[de,difflist]; dep= p; Break[] ] ]] (* for p *); If [Equal[de,Null], If[SpecialFunctionsPrintMessages, Print["specfun-info: DE not found in ",pmax," step(s)"]]; Return[HoldForm[simpleDE[fkt,x,max,F]]] ] (* Equal *) ] (* if rat.Q *); de=(de /. {f->F[x],diff[f,x]->F'[x],diff[f,x,p_]->Derivative[p][F][x]}); DE = (de == 0); de == 0 (* factored form DEOut[de,F,x] *) ] (* simpleDE *) Clear[NonLinear] NonLinear[de_,y_,x_]:=Module[ {pos1,pos2,DE}, If[SameQ[Head[de],Equal],DE=Expand[de[[1]]-de[[2]]],DE=Expand[de]]; DE=(DE /. y[x]->t[0]); DE=(DE /. Derivative[n_][y][x]->t[n]); pos1=Position[DE,a_.*t[b_]*t[c_]]; pos2=Position[DE,a_.*t[b_]^c_]; Not[SameQ[pos1,{}]] || Not[SameQ[pos2,{}]] ] DEtoRE[de_,F_,x_]:=DEtoRE[de,F,x,Global`a,Global`k] DEtoRE[de_,F_[x_]]:=DEtoRE[de,F,x,Global`a,Global`k] DEtoRE[de_,F_[x_],x_]:=DEtoRE[de,F,x,Global`a,Global`k] DEtoRE[de_,F_[x_],a_[k_]]:=DEtoRE[de,F,x,a,k] DEtoRE[de_,F_[x_],x_,a_,k_]:=DEtoRE[de,F,x,a,k] Off[Global`k::shdw] DEtoRE[de_,F_,x_,Global`a,Global`k]:= Module[{}, Print["specfun-warning: Please Clear[a] and Clear[k], or use other symbols as fourth and fifth argument of DEtoRE."]; HoldForm[DEtoRE[de,F,x,Global`a,Global`k]]]/;(!SameQ[Head[Global`a],Symbol]|| Not[SameQ[ToString[Head[Global`a[anything___]]],"a"]])&& !SameQ[Head[Global`k],Symbol] DEtoRE[de_,F_,x_,a_,Global`k]:= Module[{}, Print["specfun-warning: Please use another symbol as fifth argument of DEtoRE."]; HoldForm[DEtoRE[de,F,x,a,Global`k]]]/;!SameQ[Head[Global`k],Symbol] DEtoRE[de_,F_,x_,Global`a,k_]:=Module[{}, Print["specfun-warning: Please Clear[a] or use another symbol as fourth argument.\n"]; HoldForm[DEtoRE[de,F,x,Global`a,k]]]/;(!SameQ[Head[Global`a],Symbol]|| Not[SameQ[ToString[Head[Global`a[anything___]]],"a"]]) DEtoRE[de_,F_,x_,a_,k_]:= Module[{}, Print["specfun-warning: Nonlinear differential equations are not supported."]; HoldForm[DEtoRE[de,F,x,a,k]]]/;NonLinear[de,F,x] DEtoRE[de_,F_,x_,a_,k_]:=Module[ {tempre,subst,de00,f,recoefflist,varlist,re,re00,reseparation, l,i,reanalysis,maxd,reprodsum,findd,higherd,plus1,part12}, (* If[SpecialFunctionsPrintMessages, Print[specfuninfo]]; *) findd[c_. * a[k]] := 0; findd[c_. * a[k+d_.]] := d; findd[c_. * a[k+d_.]] := d; higherd[z_,y_] := findd[z] > findd[y]; plus1[pp___]:=pp + 1; part12[pp___]:=Part[pp,1,2]; If[SameQ[Head[de],Equal],de00=de[[1]]-de[[2]],de00=de]; de00=(de00 /.{F[x]->f,F'[x]->diff[f,x],Derivative[p_][F][x]->diff[f,x,p]}); subst[g_+h_,x]:=subst[g,x]+subst[h,x]; subst[c_*g_,x]:=c*subst[g,x] /; FreeQ[c,x] && FreeQ[c,f]; subst[diff[f,x,k0_],x]:=Pochhammer[k+1,k0]*a[k+k0]; subst[diff[f,x],x]:=(k+1)*a[k+1]; subst[f,x]:=a[k]; subst[x^j_.*diff[f,x,k0_],x]:=Pochhammer[k+1-j,k0]*a[k+k0-j]; subst[x^j_.*diff[f,x],x]:=(k+1-j)*a[k+1-j]; subst[x^j_.*f,x]:=a[k-j]; subst[g_,x]:=subst[Expand[g],x] /; (Head[g]==Times); (* separation of variables and coefficients *) reseparation[tempre_]:=Module[ {v,c}, v=Cases[Variables[tempre],a[__]]; c=Simplify[Coefficient[Expand[tempre],#]&/@ v]; Return[{c,v}] ]; RE=re00= subst[de00,x]; {recoefflist,varlist}=reseparation[re00]; re=Apply[Plus,recoefflist*varlist]; l = Length[varlist]; mind = findd[varlist[[1]]]; For [i=2, i<=l, i++, mind= Min[findd[varlist[[i]]],mind]]; (Map[Factor,re /. k -> k-mind]==0) ] (* DEtoRE *) SimpleRE[fkt_,x_,a_[k_],k_,max_]:=SimpleRE[fkt,x,a,k,max] SimpleRE[fkt_,x_]:=SimpleRE[fkt,x,Global`a,Global`k] SimpleRE[fkt_,x_,a_[k_],k_]:=SimpleRE[fkt,x,a,k,5] SimpleRE[fkt_,x_,a_,k_]:=SimpleRE[fkt,x,a,k,5] SimpleRE[fkt_,x_,a_[k_]]:=SimpleRE[fkt,x,a,k,5] SimpleRE[fkt_,x_,a_,k_,max_]:=Module[{}, Print["specfun-warning: Please Clear[f] before using SimpleRE."]; HoldForm[SimpleRE[fkt,x,a,k,max]]]/;(Not[SameQ[Head[Global`f],Symbol]]|| !SameQ[ToString[Head[Global`f[anything___]]],"f"]) SimpleRE[fkt_,x_,a_,k_,max_]:=Module[{}, Print["specfun-warning: Please Clear[a] or use another symbol as third argument.\n"]; HoldForm[SimpleRE[fkt,x,a,k,max]]]/;(!SameQ[Head[a],Symbol]|| !SameQ[ToString[Head[Global`a[anything___]]],"a"]) SimpleRE[fkt_,x_,a_,k_,max_]:=Module[ {PSP,hold}, If[SpecialFunctionsPrintMessages, Print[specfuninfo]]; PSP = SpecialFunctionsPrintMessages; If[PSP,specfunprintoff]; hold = DEtoRE[SimpleDE[fkt,x,Global`f],Global`f,x,a,k]; If[PSP,specfunprint]; hold ] Off[General::spell1] RationalQ[f_,x_]:=Module[{fac}, fac:=Factor[f]; PolynomialQ[Numerator[fac],x] && PolynomialQ[Denominator[fac],x] ] On[General::spell1] Clear[ FindLowestFirstParameter,SimpByRecursion,SimpByRecursion1,Recursion, AddToNlist] SimpByRecursion[expr_]:= Module[{expr1,expr2,length,i}, expr1 = expr/.transformspecial1; expr2 = expr/.transformspecial1; length = Length[reclist]; For[i= 1,i<=length,++i, If[Not[FreeQ[expr1,Head[reclist[[i,1]]]]], expr1= SimpByRecursion[expr1,reclist[[i]]] ]; (* if not *) ]; (* for *) If[SameQ[expr2,expr],expr1,expr1/.transformspecial2] ] SimpByRecursion[expr1_,norec_]:= Module[{}, Print["specfun-warning: Please call SimpByRecursion with one argument."]; HoldForm[SimpByRecursion[expr1,norec]] ]/;!SameQ[Head[norec],Equal] SimpByRecursion[expr1_,recursion_]:=Module[{A,func,n,low,i,tail,argli, expr2,expr3, aetzi,fetzi,lowlist,highlist,highlist3,lowlist3,reclowlist, rechighlist,reclow,low3,high3,hold}, Recursion[arglist_,arglii_,recursion1_]:= Module[{n,length,recu,i}, length = Length[arglii]; recu = recursion1; For[i = 1, i <= length,++i, recu = recu/. arglii[[i]] -> arglist[[i]] ]; recu ]; SimpByRecursion1[AA_,AA_[arglist_],low1_,range1_,arglii_,recursion1_]:= SimpByRecursion1[AA,Recursion[arglist,arglii,recursion1], low1,range1,arglii,recursion1]/; (arglist[[1]] -low1-1+range1 -1>0); SimpByRecursion1[AA_,expr_,low1_,range1_,arglii_,recursion1_]:=Module[ {p,head,plist,i,length}, length = Length[expr]; plist = {};head = Head[expr]; For[i=1,i<=length,++i, AppendTo[plist,SimpByRecursion1[AA,expr[[i]],low1,range1,arglii,recursion1]] ]; p= plist[[1]]; If[length>1, For[i=2,i<=length,++i, p = head[p,plist[[i]]] ] ]; p ]/;Not[FreeQ[expr,AA]]&&Not[SameQ[Head[expr],AA]]; SimpByRecursion1[AA_,expr_,low1_,range1_,arglii_,recursion1_]:= Module[{}, expr ]; FindLowestFirstParameter[ AA_,AA_[arglist_],arglii_,lowlist2_]:= Module[{i,low1}, low1 = lowlist2[[1]]; (* finds minimal n-value in calls of func and writes this value in global variable low *) If[SameQ[arglist[[1]],arglii[[1]]], If[(low1- arglii[[1]]>0), low1=arglii[[1]], Null(* else do nothing *), (* 1st appearance *) low1=arglii[[1]] ], If[(low1-arglist[[1]]>0), low1=arglist[[1]], Null(* else do nothing *), (* 1st appearance *) low1=arglist[[1]] ] ]; (arglist/.arglist[[1]]->low1) ]/;!SameQ[Head[arglist[[1]]],Integer] (* Module Find... *); FindLowestFirstParameter[ AA_,AA_[arglist_],arglii_,lowlist2_]:= Module[{i,low1}, low1 = lowlist2[[1]]; (* finds minimal n-value in calls of func and writes this value in global variable low *) If[SameQ[arglist[[1]],0], If[(low1>0), low1=0,Null(* else do nothing *),(* 1st appearance *) low1=0 ], If[(low1-arglist[[1]]>0), low1=arglist[[1]], Null(* else do nothing *), (* 1st appearance *) low1=arglist[[1]] ] ]; (arglist/.arglist[[1]]->low1) ]/;SameQ[Head[arglist[[1]]],Integer]; FindLowestFirstParameter[AA_,expr_,arglii_,lowlist2_]:= Module[{i,lowlist1,arglist}, lowlist1 = lowlist2; Table[lowlist1 = FindLowestFirstParameter[AA,expr[[i]],arglii,lowlist1],{i,1,Length[expr]}]; lowlist1 ]/; (Length[expr]>0); FindLowestFirstParameter[AA_,expr_,arglii_,lowlist2_]:=lowlist2; FindHighestFirstParameter[ AA_,AA_[arglist_],arglii_,highlist2_]:= Module[{i,high1}, high1 = highlist2[[1]]; (* finds maximal n-value in calls of func and writes this value in global variable high *) If[SameQ[arglist[[1]],arglii[[1]]], If[(high1- arglii[[1]]<0), high1=arglii[[1]], Null(* else do nothing *), (* 1st appearance *) high1=arglii[[1]] ], If[(high1-arglist[[1]]<0), high1=arglist[[1]], Null(* else do nothing *), (* 1st appearance *) high1=arglist[[1]] ] ]; (arglist/.arglist[[1]]->high1) ]/;!SameQ[Head[arglist[[1]]],Integer](* Module Find... *); FindHighestFirstParameter[ AA_,AA_[arglist_],arglii_,highlist2_]:= Module[{i,high1}, high1 = highlist2[[1]]; (* finds maximal n-value in calls of func and writes this value in global variable high *) If[SameQ[arglist[[1]],0], If[(high1<0), high1=0,Null(* else do nothing *),(* 1st appearance *) high1=0 ], If[(high1-arglist[[1]]<0), high1=arglist[[1]], Null(* else do nothing *), (* 1st appearance *) high1=arglist[[1]] ] ]; (arglist/.arglist[[1]]->high1) ]/;SameQ[Head[arglist[[1]]],Integer]; FindHighestFirstParameter[AA_,expr_,arglii_,highlist2_]:= Module[{i,highlist1,arglist}, highlist1 = highlist2; Table[highlist1 = FindHighestFirstParameter[AA,expr[[i]],arglii,highlist1],{i,1,Length[expr]}]; highlist1 ]/; (Length[expr]>0); FindHighestFirstParameter[AA_,expr_,arglii_,highlist2_]:=highlist2; func = Head[recursion[[1]]]; argli = recursion[[1]]/.func -> List; tail = recursion[[2]]/.func-> A; tail = tail/. A[argl___] -> A[{argl}]; n = argli[[1]]; expr2 = expr1/. func-> A; expr2 = expr2/. A[argl___] -> A[{argl}]; initlist = {aetzi,fetzi}; (* compute the range of n in expr *) lowlist = FindLowestFirstParameter[A,expr2,argli,initlist]; low = lowlist[[1]]; highlist= FindHighestFirstParameter[A,expr2,argli,initlist]; high= highlist[[1]]; range = high - low; (* compute the range of n in recursion *) Arecursion = recursion[[2]] /.func->A; Arecursion = Arecursion/.A[argl___] -> A[{argl}]; reclowlist = FindLowestFirstParameter[A,Arecursion,argli,initlist]; reclow = reclowlist[[1]]; recrange = recursion[[1,1]] - reclow; If[recrange > range+1,Return[expr1]]; expr3 = expr2; expr3 = SimpByRecursion1[A,expr3,low,recrange,argli,tail]; highlist3= FindHighestFirstParameter[A,expr3,argli,initlist]; high3 = highlist3[[1]]; lowlist3 = FindLowestFirstParameter[A,expr3,argli,initlist]; low3 = lowlist3[[1]]; range3 = high3 -low3; expr3 =Expand[expr3]; For[i= low3, i-low3 <=high3-low3,++i, lowpluslist = lowlist3/.low3->i; expr3 = Collect[expr3, A[lowpluslist]]; ] (* for *); length = Length[expr3]; expr3 = expr3/.A[{argl___}]-> A[argl]; expr3 = expr3/.A-> func; For[i=1,i<=length,++i, If[Length[expr3[[i]]]>1, If[SameQ[Head[Last[expr3[[i]]]],func], hold = Expand[expr3[[i]]/Last[expr3[[i]]]]; hold = Together[hold]; expr3 = expr3/.expr3[[i]]->hold * Last[expr3[[i]]] ] (*if SameQ *) ] (* If Length *) ] (*for *); If[(range - range3== 0 )&& (Length[Expand[expr1]]<=Length[Expand[expr3]]), expr1,expr3] ] (* Module SimpByRecursion *) Clear[AbsRules,SimpSqrt] SimpSqrt[Abs[x_]^p_]:=(Abs[x]^Mod[(p/2),2]*x^((p/2)-Mod[(p/2),2])) SimpSqrt[x_^p_]:=(Abs[x]^Mod[(p/2),2]*x^((p/2)-Mod[(p/2),2]))/;IntegerQ[p/2] SimpSqrt[x_]:= Sqrt[x] ArcTanhRule={E^(ArcTanh[xx_]*(yy_.)) -> ((1 + xx)/(1 - xx))^(yy/2)} AbsRules= {Abs[xxx_] Sign[xxx_]->xxx, Abs[xxx_]^2->xxx^2, Sign[xxx_]/Abs[xxx_]->1/xxx, Sqrt[xxx_^2]->Abs[xxx], (xxx_^4)^(1/4)->Abs[xxx], Sqrt[1/xxx_^2]->1/Abs[xxx], 1/Sqrt[xxx_^2]->1/Abs[xxx], Sqrt[xxx_^4]->xxx^2, Sqrt[1/xxx_^4]->1/xxx^2, Sign[xxx_]^2 -> 1, 1/Sqrt[xxx_^4]->1/xxx^2, Sin[yyy_. Abs[xxx_]]->Sign[xxx] Sin[yyy xxx], Cos[yyy_. Abs[xxx_]]->Cos[yyy xxx], Tan[yyy_. Abs[xxx_]]->Sin[yyy Abs[xxx]]/Cos[yyy Abs[xxx]], Cot[yyy_. Abs[xxx_]]->1/Tan[yyy Abs[xxx]], ArcSin[yyy_. Abs[xxx_]]->Sign[xxx] ArcSin[yyy xxx], ArcTan[yyy_. Abs[xxx_]]->Sign[xxx] ArcTan[yyy xxx], ArcCot[yyy_. Abs[xxx_]]->Sign[xxx] ArcCot[yyy xxx], ArcCos[yyy_. Abs[xxx_]]->Pi/2-ArcSin[yyy Abs[xxx]], Sinh[yyy_. Abs[xxx_]]->Sign[xxx] Sinh[yyy xxx], Cosh[yyy_. Abs[xxx_]]->Cosh[yyy xxx], Tanh[yyy_. Abs[xxx_]]->Sinh[yyy Abs[xxx]]/Cosh[yyy Abs[xxx]], Coth[yyy_. Abs[xxx_]]->1/Tanh[yyy Abs[xxx]], ArcSinh[yyy_. Abs[xxx_]]->Sign[xxx] ArcSinh[xxx yyy], ArcTanh[yyy_. Abs[xxx_]]->Sign[xxx] ArcTanh[xxx yyy], ArcCoth[yyy_. Abs[xxx_]]->Sign[xxx] ArcCoth[xxx yyy], E^(n_. Abs[xxx_])-> ((E^(n xxx)+E^(-n xxx)+Sign[xxx] (E^(n xxx)-E^(-n xxx)))/2), Erf[yyy_. Abs[xxx_]]->Sign[xxx] Erf[yyy xxx] } (* everything necessary for SimpI. SimpI saves us from a lot of trouble with complex numbers *) Clear[ExcludeTermsWithNonFactorialDenominators,MFD,MFD1,SimpI] ExcludeTermsWithNonFactorialDenominators[expr___]:= Module[{list,newl,i,jj}, list = Level[expr,1]; newl = {}; For[i=1,i<=Length[list], ++i, If[!FreeQ[Denominator[list[[i]]],Factorial], AppendTo[newl,list[[i]]]] ]; If[(newl == {}), Null, Sum[newl[[jj]],{jj,1,Length[newl]}] ] ]/;!FreeQ[expr,Factorial] ExcludeTermsWithNonFactorialDenominators[expr_]:=Null/;FreeQ[expr,Factorial] (* MFD computes the maximal factorial denominator, i.e MFD[expr] * expr should not contain factorials *) MFD[expr___]:= MFD1[ExcludeTermsWithNonFactorialDenominators[expr]] MFD1[v1_/(w1_)! + expr_] := Module[{expr1}, expr1 = expr*w1!; expr1 = Expand[expr1]; expr1= ExcludeTermsWithNonFactorialDenominators[expr1+v1]; w1!*MFD[expr1] ] MFD1[v1_/(w1_)!]:=w1!; MFD1[Null] := 1 SimpI[expr_]:=Simplify[Simplify[Map[SimpFactorial,Expand[MFD[expr]*expr]]]/MFD[expr]] (* simplifying unpleasent pochhammers, products, and factorials *) Clear[ListOfIndependentTerms1,PPC,SimpProduct1,SimpProduct,QuadraticQ, PochhammerProductCoefficient,SimpPochhammer,FindRecursion,SimpFactorial, SimpPochhammer1] ListOfIndependentTerms1[list1_,x_]:= Module[{lnew, length,first,fraction,sum,i}, lnew = {}; length = Length[list1]; first = list1[[1]]; sum = first; For[i=2, i<=length, i++, fraction = Factor[Cancel[first/list1[[i]]]]; fraction = SimpSinCos[fraction]; (* NEW Thu Mar 17 12:35:52 MET 1994 *) fraction = SimpFactorial[fraction]; If [RationalQ[fraction,x], sum += list1[[i]], (* rat. dependent *) AppendTo[lnew,list1[[i]]] (* rat. indep *) ] (* if *) ]; (* for *) sum = Simplify[sum]; {sum,ListOfIndependentTerms1[lnew,x]} ]/;(Length[list1]>1) ListOfIndependentTerms1[list1_,x_]:= {list1}/;(Length[list1]<2) QuadraticQ[f_,x_]:=Module[{}, Length[CoefficientList[f,x]]==3]/;PolynomialQ[f,x] QuadraticQ[f_,x_]:=False; PPC[term_,j_]:=PochhammerProductCoefficient[term,j] PochhammerProductCoefficient[term_,j_]:=Module[{A,poly,c,yquadrat,x,B}, poly = Expand[term,j]; c= Coefficient[poly,j,2]; poly =poly/c; A=Coefficient[poly,j,1]; B=Coefficient[poly,j,0]; x=Simplify[A/2 +1]; yquadrat=Simplify[B-(A^2)/4]; {c,x,yquadrat} ]/;QuadraticQ[Expand[term,j],j] PochhammerProductCoefficient[term_,j_]:=Null; SimpProduct[f_Plus] := Map[ SimpProduct[#]&,f ] SimpProduct[ expr_/;Length[expr]>1 ] := Module[ {p,sol}, Off[Product::itform]; sol=(expr/.{Product[_,_]:>1}) * SimpProduct1[ Times@@Cases[p PowerExpand[expr], Product[_,_]^_.]]; On[Product::itform]; sol ] /; !FreeQ[expr,Product] SimpProduct[v_] := v SimpProduct1[ Times[v1___,Product[w1_,{jj_,jj1_,jj2_}]^n_.,v2___, product[w2_,{jjj_,jjj1_,jjj2_}]^m_.]]:= SimpProduct1[Times[v1,Product[(w1 /. jj-> jj + jj1 - 1),{jj,jj2-jj1+1}]^n, v2, Product[(w2 /. jjj-> jjj + jjj1-1),{jjj,jjj2-jjj1+1}]^m]] SimpProduct1[ Times[v1___,Product[w1_,{jj_,jj1_,jj2_}]^n_.,v2___, Product[w2_,{jjj_,jjj2_}]^m_.]]:= SimpProduct1[Times[v1,Product[(w1 /. jj-> jj + jj1 - 1),{jj,jj2-jj1+1}]^n, v2, Product[w2,{jjj,jjj2}]^m]] SimpProduct1[ Times[v1___,Product[w1_,{jj_,jj2_}]^n_.,v2___, Product[w2_,{jjj_,jjj1_,jjj2_}]^m_.]]:= SimpProduct1[Times[v1,Product[w1,{jj,jj1,jj2}]^n,v2, Product[(w2 /. jjj-> jjj + jjj1 -1),{jjj,jjj2-jjj1+1}]^m]] SimpProduct1[ Times[v1___,Product[w1_,{j1_,k1_}]^n_.,v2___, Product[w2_,{j2_,k2_}]^m_.] ] := Module[ {p,c1,c2,x1,x2,y2quadrat,y1quadrat}, p = Min[ Abs[n], Abs[m] ]; c1 = PPC[w1,j1][[1]]; c2 = PPC[w2,j2][[1]]; y1quadrat = PPC[w1,j1][[3]]; y2quadrat = PPC[w2,j2][[3]]; x1 = PPC[w1,j1][[2]]; x2 = PPC[w2,j2][[2]]; If [(x1 === x2 )&& (y1quadrat === y2quadrat ), If[ (Simplify[k1-k2]===1), SimpProduct1[v1 v2 Product[w1,{j1,k}]^(n-p) * Product[w2,{j2,k2}]^(m+p)] * Simplify[((x1+k1-1)^2 + y1quadrat ) * c1^k1 * c2^-k2]^p, SimpProduct1[v1 v2 Product[w1,{j1,k}]^(n-p) * Product[w2,{j2,k2}]^(m+p)]* Simplify[ c1^k1 * c2^(-k2) / ((x1+k2-1)^2 + y1quadrat ) ]^p ] (* if Simplify ... *) ,(* else x1 != x2 ... *) If [Simplify[x1 - x2] === Simplify[k2-k1], If[ Simplify[k1-k2] === 1, SimpProduct1[v1 v2 Product[w1,{j1,k}]^(n-p) * Product[w2,{j2,k2}]^(m+p)] * Simplify[(x1^2 + y1quadrat ) * c1^k1 * c2^-k2]^p, SimpProduct1[v1 v2 Product[w1,{j1,k}]^(n-p) * Product[w2,{j2,k2}]^(m+p)]* Simplify[ c1^k1 * c2^-k2 / (x1^2 + y1quadrat ) ]^p ](* if Simplify k1 - k2... *) ] ] ]/;(( Abs[Simplify[k2-k1]]===1) && QuadraticQ[Expand[w1],j1] && (IntegerQ[n]) && (n>0) && QuadraticQ[Expand[w2],j2] && (m<0)) SimpProduct1[v_]:= v (* developed in Package Algebra`SymbolicSum` by Victor S. Adamchik *) SimpPochhammer[f_Plus] := Map[ SimpPochhammer[#]&,f ] SimpPochhammer[ expr_/;Length[expr]>1 ] := Module[ {p}, (expr/.{Pochhammer[_,_]:>1}) * SimpPochhammer1[ Times@@Cases[p PowerExpand[expr], Pochhammer[_,_]^_.]] ] /; !FreeQ[expr,Pochhammer] SimpPochhammer[v_] := v SimpPochhammer1[ Times[v1___,Pochhammer[w1_,v_]^n_.,v2___, Pochhammer[w2_,v_]^m_.] ] := Module[ {p}, p = Min[ Abs[n], Abs[m] ]; If[ (w1-w2)===1, SimpPochhammer1[v1 v2 Pochhammer[w1,v]^(n-p) * Pochhammer[w2,v]^(m+p)] ((w2+v)/w2)^p, SimpPochhammer1[v1 v2 Pochhammer[w1,v]^(n-p) * Pochhammer[w2,v]^(m+p)] (w1/(w1+v))^p ] ]/; Abs[Simplify[w2-w1]]===1 && IntegerQ[n] && n>0 && m<0 SimpPochhammer1[ Times[v1___,Pochhammer[a_,k_]^n_.,v2___, Pochhammer[a_,j_]^m_.] ] := Module[ {p}, p = Min[ Abs[n], Abs[m] ]; If[ Simplify[k-j]>0, SimpPochhammer1[v1 v2 Pochhammer[a,k]^(n-p) * Pochhammer[a,j]^(m+p)] *Pochhammer[Simplify[a+j],Simplify[k-j]], SimpPochhammer1[v1 v2 Pochhammer[a,k]^(n-p) * Pochhammer[a,j]^(m+p)] /Pochhammer[Simplify[a+k],Simplify[j-k]] ] ]/; IntegerQ[Simplify[k-j]]&& IntegerQ[n] && n>0 && m<0 SimpPochhammer1[v_] := v(*//.PochToAlg*) SimpFactorial[ Times[v1___,(w1_)!^n_.,v2___,(w2_)!^m_.] ] := Module[ {p}, p = Min[ Abs[n], Abs[m] ]; If[ Simplify[w2-w1]>0, SimpFactorial[v1 v2 (w1!)^(n-p) (w2!)^(m+p)]/ Factor[Pochhammer[w1+1,Simplify[w2-w1]]^p], SimpFactorial[v1 v2 (w1!)^(n-p) (w2!)^(m+p)]* Factor[Pochhammer[w2+1,Simplify[w1-w2]]^p] ] ]/; IntegerQ[Simplify[w2-w1]] && IntegerQ[n] && n>0 && m<0 SimpFactorial[ v_ ] := v (* end Algebra`SymbolicSum` by Victor S. Adamchik *) Clear[ContainsOtherVariableThanC,AllPartsMultipliedByC, EliminateNegativeBases,SimpConst,SimpConst1,DEout] ContainsOtherVariableThanC[C[k_]]:= False ContainsOtherVariableThanC[expr_]:= Module[{i,contains}, contains = False; For[i=1,(i<=Length[expr]) && !contains, ++i, If[ContainsOtherVariableThanC[expr[[i]]],contains = True] ]; contains ]/; (Length[expr] >0 ) ContainsOtherVariableThanC[expr_]:= (SameQ[Symbol,Head[expr]] && !SameQ[expr,Pi]&& !SameQ[expr,I]&& !SameQ[expr,E])/;Length[expr]==0 AllPartsMultipliedByC[expr_]:=Module[{jj,i,notmultbyC}, For[i=1,i<=Length[expr],++i, If[SameQ[Head[expr[[i]]],Times], notmultbyC=True; For[jj=1,jj<=Length[expr[[i]]],++jj, If [SameQ[Head[expr[[i,jj]]],C], notmultbyC=False] ]; If[notmultbyC,Return[False]], If[!SameQ[Head[expr[[i]]],C],Return[False]] ] ] (*for*); True ] EliminateNegativeBases[(num_+x_)^k_,x_]:=((Abs[num]+ x*Sign[num])^k)/; NumberQ[num] EliminateNegativeBases[(num_-x_)^k_,x_]:=((Abs[num]- x*Sign[num])^k)/; NumberQ[num] EliminateNegativeBases[expr_,x_]:=Module[{i,length,newexpr}, length = Length[expr]; newexpr = Table[EliminateNegativeBases[expr[[i]],x],{i,1,length}]; newexpr/. List -> Head[expr] ]/;((Length[expr]>=2)&&(SameQ[ Head[expr],Times]||SameQ[ Head[expr],Plus])) EliminateNegativeBases[expr_,x_]:=expr Clear[EliminateNegativeLogarithms, ContainsNegativeSumment, EliminateNegativeLogarithms1] EliminateNegativeLogarithms[expr1_]:= Module[{order}, ContainsNegativeSumment[expr2_]:=Module[{(*i,length*)}, If[NumberQ[expr2]&&Negative[expr2], Return[True], If[SameQ[Head[expr2],Plus], length = Length[expr2]; For[i=1,i<=length,++i, If[NumberQ[expr2[[i]]]&&Negative[expr2[[i]]],Return[True]] ] ](*if *) ](*if *); False](*/;(Length[expr2]>0)*); EliminateNegativeLogarithms1[expr_]:=Module[{termlist,term,i,jj,newexpr}, newexpr = expr; If[SameQ[Head[newexpr],Log]&&ContainsNegativeSumment[Expand[newexpr[[1]]]], newexpr = Log[EliminateNegativeLogarithms1[Expand[(-1)*newexpr[[1]]]]]* C[++order], length = Length[newexpr];termlist={}; Do[AppendTo[termlist,EliminateNegativeLogarithms1[newexpr[[i]]]],{i,1,length}]; termlist/.(List->Head[newexpr]) ](* If *) ]/;(Length[expr]>0) ;(* Module *) EliminateNegativeLogarithms1[expr_]:=(expr/;(Length[expr] == 0)); order = COrder[expr1]; EliminateNegativeLogarithms1[expr1] ] (* outer invocation needed to set the global variable kk *) SimpConst[expr_] := SimpConst[expr,x] SimpConst[expr2_,xx_]:=Module[{finalexpr,order1,kk}, SimpConst1[expr_,x_]:=Module[{expr1,expr3,length,head,addconst,varlist,i,j,k, const}, expr1 = expr; expr3=PowerExpand[Map[Together,expr1]]; If[FreeQ[expr3,ArcTanh], expr1 = expr3]; expr1 = expr1 /. Power[E, Times[Complex[0,b_], xxx_]]->Cos[b xxx]+ I*Sin[b xxx]; expr1 = Simplify[expr1]; If[Not[Contains[expr1,C]], Return [expr1], (* else *) varlist ={}; length = Length[expr1]; j=0;const =False;addconst = True; For[i=1,i<=length,++i, subexpr= SimpConst1[expr1[[i]],x]; If[Contains[subexpr,x], needed= True; If[varlist != {}, For[k=1,k<=Length[varlist],++k, If[!ContainsOtherVariableThanC[Together[varlist[[k]]/subexpr]], needed = False]; ] ];(* If varlist *) If[SameQ[Head[subexpr],Plus]&& AllPartsMultipliedByC[subexpr], addconst= False]; If[needed,AppendTo[varlist,subexpr]], (* else Contains*) const = True ](* IF Contains *) ];(* For *) head = Head[expr1]; If[SameQ[head,Plus]&&Not[const],addconst=False]; If[addconst&&const,AppendTo[varlist,C[++kk]]]; If[(Length[varlist] == 1)&&SameQ[head,Power], Return[C[kk]]]; newlist = varlist/. List -> head; If[SameQ[head,Times], newlist=EliminateNegativeBases[newlist,x]]; newlist ] ] /; (Length[expr]>1); SimpConst1[expr_,x_]:=expr; kk=order1; finalexpr = SimpConst1[expr2,xx]; order1=0; finalexpr ] Clear[SimpSinCos,HolonomicDE,HolonomicRE] SimpSinCos[Csc[xx_]]:= 1/SimpSinCos[Sin[xx]] SimpSinCos[Sec[xx_]]:= 1/SimpSinCos[Cos[xx]] SimpSinCos[Sin[xx_]]:=(Sin[Pi*k/4]/;IntegerQ[Simplify[(xx-Pi*k/4)/(2*Pi)]]) SimpSinCos[Sin[xx_]]:=Sqrt[2]/2 * (Sin[Pi*k/4]+ Cos[Pi*k/4])/;IntegerQ[Simplify[(xx-Pi*k/4-Pi/4)/(2*Pi)]] SimpSinCos[Sin[xx_]]:=Cos[Pi*k/4]/;IntegerQ[Simplify[(xx-Pi*k/4-Pi/2)/(2*Pi)]] SimpSinCos[Sin[xx_]]:=Sqrt[2]/2 * (-Sin[Pi*k/4]+ Cos[Pi*k/4])/;IntegerQ[Simplify[(xx-Pi*k/4-3*Pi/4)/(2*Pi)]] SimpSinCos[Sin[xx_]]:=-Sin[Pi*k/4]/;IntegerQ[Simplify[(xx-Pi*k/4-Pi)/(2*Pi)]] SimpSinCos[Sin[xx_]]:=-Sqrt[2]/2 * (Sin[Pi*k/4]+ Cos[Pi*k/4])/;IntegerQ[Simplify[(xx-Pi*k/4-5*Pi/4)/(2*Pi)]] SimpSinCos[Sin[xx_]]:=-Cos[Pi*k/4]/;IntegerQ[Simplify[(xx-Pi*k/4-6*Pi/4)/(2*Pi) ]] SimpSinCos[Sin[xx_]]:=Sqrt[2]/2 * (Sin[Pi*k/4]- Cos[Pi*k/4])/;IntegerQ[Simplify[(xx-Pi*k/4-7*Pi/4)/(2*Pi)]] SimpSinCos[Cos[xx_]]:=Cos[Pi*k/4]/;IntegerQ[Simplify[(xx-Pi*k/4)/(2*Pi)]] SimpSinCos[Cos[xx_]]:=Sqrt[2]/2 * (-Sin[Pi*k/4]+ Cos[Pi*k/4])/;IntegerQ[Simplify[(xx-Pi*k/4-Pi/4)/(2*Pi)]] SimpSinCos[Cos[xx_]]:=-Sin[Pi*k/4]/;IntegerQ[Simplify[(xx-Pi*k/4-Pi/2)/(2*Pi)]] SimpSinCos[Cos[xx_]]:=-Sqrt[2]/2 * (Sin[Pi*k/4]+ Cos[Pi*k/4])/;IntegerQ[Simplify[(xx-Pi*k/4-3*Pi/4)/(2*Pi)]] SimpSinCos[Cos[xx_]]:=-Cos[Pi*k/4]/;IntegerQ[Simplify[(xx-Pi*k/4-Pi)/(2*Pi)]] SimpSinCos[Cos[xx_]]:=Sqrt[2]/2 * (Sin[Pi*k/4]- Cos[Pi*k/4])/;IntegerQ[Simplify[(xx-Pi*k/4-5*Pi/4)/(2*Pi)]] SimpSinCos[Cos[xx_]]:= Sin[Pi*k/4]/;IntegerQ[Simplify[(xx-Pi*k/4-6*Pi/4)/(2*Pi)]] SimpSinCos[Cos[xx_]]:=Sqrt[2]/2 * (Sin[Pi*k/4]+ Cos[Pi*k/4])/;IntegerQ[Simplify[(xx-Pi*k/4-7*Pi/4)/(2*Pi)]] SimpSinCos[expr_]:= (Table[SimpSinCos[expr[[i]]],{i,1,Length[expr]}]/. List->Head[expr])/;(Length[expr]>1) SimpSinCos[expr_]:= expr HolonomicDE[ffff___]:=SimpleDE[ffff] HolonomicDE[ffff___]:=Module[{}, Print["specfun-warning: Please unassign f with Clear[f] to use HolonomicDE."]; HoldForm[HolonomicDE[ffff]]]/;(!SameQ[Head[Global`f],Symbol] !SameQ[ToString[Head[Global`f[anything___]]],"f"]) HolonomicRE[ffff___]:=FindRecursion[ffff] HolonomicDE[ffff___]:=Module[{}, Print["specfun-warning: Please unassign a with Clear[a] to use HolonomicRE."]; HoldForm[HolonomicRE[ffff]]]/;(!SameQ[Head[Global`a],Symbol] !SameQ[ToString[Head[Global`a[anything___]]],"a"]) FindRecursion[fkt_,a_[k_]]:=FindRecursion[fkt,k,a] FindRecursion[fkt_,k_]:=FindRecursion[fkt,k,Global`a] FindRecursion[fkt_,k_,a_]:=Module[{}, Print["specfun-info: ",InputForm[k]," is not a valid variable."]; HoldForm[FindRecursion[fkt,k,a]]]/;!SameQ[Head[k],Symbol] FindRecursion[fkt_,k_,a_]:=Module[{}, Print["specfun-warning: Please unassign a with Clear[a], or use another symbol as fourth argument of FindRecursion."]; HoldForm[FindRecursion[fkt,k,a]]]/;(!SameQ[Head[Global`a],Symbol]|| !SameQ[ToString[Head[Global`a[anything___]]],"a"]) FindRecursion[fkt_,k_,a_]:=Module[{solutionfr}, If[SpecialFunctionsPrintMessages, Print[specfuninfo]]; solutionfr=FR[fkt,k,a]; If[SpecialFunctionsPrintMessages,Print["specfun-info: RE:"]]; solutionfr ](* Module FindRecursion*) (* module convert *) theta[f_,x_]:=x D[f,x] backsubst[eq1_+eq2_,n_,f_,x_]:=backsubst[eq1,n,f,x]+backsubst[eq2,n,f,x] backsubst[c_*eq_,n_,f_,x_]:=c*backsubst[eq,n,f,x] /; (FreeQ[c,n] && FreeQ[c,f] && FreeQ[c,x]) backsubst[a_[n_+m_.],n_,f_,x_]:=f[x]/x^m backsubst[n_^j_.*a_[n_+m_.],n_,f_,x_]:=theta[backsubst[n^(j-1)*a[n+m],n,f,x],x] backsubst[p_*a_[n_+m_.],n_,f_,x_]:= backsubst[Expand[p*a[n+m]],n,f,x] /; PolynomialQ[p,n] REtoDE[re_,a_[k_]]:=REtoDE[re,a,k,Global`f,Global`x] REtoDE[re_,a_[k_],f_[x_]]:=REtoDE[re,a,k,f,x] REtoDE[re_,a_,k_]:=REtoDE[re,a,k,Global`f,Global`x] (* Here is really something new *) (* old REtoDE[re_,a_,k_,F_,x_]:=Module[ {recursion,containsk,recursionfactor,recursionpart,jj,de,anything,n}, If[SameQ[Head[re],Equal],recursion=re[[1]]-re[[2]],recursion=re]; recursion = Collect[recursion,a[k]]; recursionfactor=1; Do[ recursionpart[jj]=(recursion[[jj]]/(recursion[[jj]] /. a[anything_]->1))[[1]]; containsk[jj]=recursionpart[jj] , {jj,2,Length[recursion]}]; recursionfactor=Product[containsk[jj],{jj,2,Length[recursion]}]; recursion=Collect[recursion*recursionfactor,a[k]]; de = backsubst[(recursion/.k->n),n,F,x]; de = Numerator[Together[de]]; While[NumberQ[Denominator[Together[de/x]]],de= Expand[de/x]]; de == 0 ] *) (* Diese Funktion macht ohne Angabe des Bereichs der Rekursion wenig Sinn ! *) (* Annahme k>=0 *) REtoDE[re_,a_,k_,F_,x_]:=Module[ {recursion,containsk,recursionfactor,recursionpart,jj,de,anything,n}, If[SameQ[Head[re],Equal],recursion=re[[1]]-re[[2]],recursion=re]; recursion = Collect[recursion,a[k]]; recursionfactor=1; Do[containsk[jj]=1; recursionpart[jj]=(recursion[[jj]]/(recursion[[jj]] /. a[anything_]->1))[[1]]; If[ Not[SameQ[Simplify[(recursion /. k->-Coefficient[recursionpart[jj],k,0]) /. a[anything_]-> If[anything<0,0,(ak/.k->anything)]],0]], containsk[jj]=recursionpart[jj]] , {jj,2,Length[recursion]}]; recursionfactor=Product[containsk[jj],{jj,2,Length[recursion]}]; recursion=Collect[recursion*recursionfactor,a[k]]; xshift=SmallestZeroOfPolyminal[Last[recursion]/a[k],k]; de = backsubst[recursion,k,F,x]; DE = de = Numerator[Together[de]]; While[NumberQ[Denominator[Together[de/x]]],de= Expand[de/x]]; de == 0 ] SumtoDE[Global`sum[expr_.*x_^k_,{k_,0,Infinity}],x_]:= SumtoDE[Global`sum[expr*x^k,{k,0,Infinity}],x,Global`f] SumtoDE[Global`sum[expr_.*x_^k_,{k_,0,Infinity}],f_[x_]]:= SumtoDE[Global`sum[expr*x^k,{k,0,Infinity}],x,f] SumtoDE[Global`sum[expr_.*x_^k_,{k_,0,Infinity}],x_,f_]:= Module[{}, Print["specfun-warning: Please Clear[f], or use another symbol as fifth argument of SumtoDE."]; HoldForm[SumtoDE[Sum[expr*x^k,{k,0,Infinity}],x,f]]]/; (!SameQ[ToString[Head[Global`f[anything___]]],"f"]|| Not[SameQ["f",ToString[Global`f]]])&&SameQ[f,Global`f] (* no other initial indices supported *) SumtoDE[Global`sum[expr_.*x_^k_,{k_,0,Infinity}],x_,F_]:=Module[ {anything,ak,recursion,de,recursionfactor,containsk,recursionpart,a}, ak=expr; recursion=FindRecursion[expr,k,a][[1]]; (*de = REtoDE[recursion,a,k,F,x]*) recursionfactor=1; Do[containsk[jj]=1; recursionpart[jj]=Together[(recursion[[jj]]/(recursion[[jj]] /. a[anything_]->1))][[1]]; If[ Not[SameQ[Simplify[(recursion /. k->-Coefficient[recursionpart[jj],k,0]) /. a[anything_]-> If[anything<0,0,(ak/.k->anything)]],0]], containsk[jj]=recursionpart[jj]] , {jj,2,Length[recursion]}]; recursionfactor=Product[containsk[jj],{jj,2,Length[recursion]}]; recursion=Collect[recursion*recursionfactor,a[k]]; de = backsubst[recursion,k,F,x]; DE = de = Numerator[Together[de]]; While[NumberQ[Denominator[Together[de/x]]],de= Expand[de/x]]; de == 0 ] (* old recursion= recursion/.Global`a->SpecialFunctions`Private`a; If[SpecialFunctionsPrintMessages&&!SameQ[recursion,1], Print[" ",InputForm[recursion/.{a->Global`a,k->Global`k}]==0]]; recursion = Collect[recursion,a[k]]; recursionfactor=1; Do[containsk[jj]=1; recursionpart[jj]=(recursion[[jj]]/(recursion[[jj]] /. a[anything_]->1))[[1]]; If[Not[SameQ[Simplify[(recursion /. k->-Coefficient[recursionpart[jj],k,0]) /. a[anything_]-> If[anything<0,0,(ak/.k->anything)]],0]], containsk[jj]=recursionpart[jj]] , {jj,2,Length[recursion]}]; recursionfactor=Product[containsk[jj],{jj,2,Length[recursion]}]; recursion=Collect[recursion*recursionfactor,a[k]]; de = backsubst[recursion,k,F,x]; de = Numerator[Together[de]]; While[NumberQ[Denominator[Together[de/x]]],de= Expand[de/x]]; DE0ut[de,F,x] *) solve[eq_]:=DSolve[Simplify[backsubst[eq,n,f,x]]==0,f[x],x] Clear[CRefresh,Contains,COrder,SumToDE,Convert,Convert1,ReverseEx,DEOrder] Unprotect[DEOrder] Contains[expr_,x_]:= Module[{contains,i}, contains = False; If[SameQ[Head[expr],x], contains = True]; For[i=1,(i<=Length[expr]) && !contains, ++i, If[Contains[expr[[i]],x]||SameQ[x,expr],contains = True] ]; contains ]/; (Length[expr] != 0) Contains[expr_,x_]:= SameQ[x,expr] DEOrder[de_,y_[x_]]:=DEOrder[de,y,x] DEOrder[de_,y_,x_]:=Module[{X,DE,delist,k,n}, If[SameQ[Head[de],Equal],DE=Expand[de[[1]]-de[[2]]],DE=Expand[de]]; DE=(DE /. y[x]->1); DE=(DE /. Derivative[n_][y][x]->X^n); delist=CoefficientList[DE,X]; Length[delist]-1]; SmallestZeroOfPolyminal[expr_,k_]:=Module[{zero,max,length,expr1,var}, expr1 = Factor[expr]; length = Length[expr1]; max =0; For[i=1,i<=length,++i, If [!NumberQ[expr1[[i]]], If [ SameQ[Head[expr1[[i]]],Power],var = expr1[[i,1]], var = expr1[[i]] ]; If[ SameQ[Head[expr1[[i]]],Symbol],var = k]; zero = Solve[var==0,k]; If[Not[SameQ[Flatten[zero],{}]], If [Abs[zero[[1,1,2]]]>max, max = Abs[Solve[var==0,k][[1,1,2]]]] ] ] ]; max] COrder[expr1_]:= Module[{max,i,expr,length}, expr =expr1; max = 0; For[i=1,(i<=Length[expr]) , ++i, number = COrder[expr[[i]]]; If[number >max ,max = number] ]; max]/; (Length[expr1]>1) COrder[C[x_]]:=x COrder[t_]:=0 /; Not[SameQ[C,Head[t]]] && (Length[t]<2) DashTimes[k_]:=Module[{join}, join = ""; For[i=1,i<=k,++i, join = StringJoin[join,"'"]]; join ] Clear[InBrackets,LLast,PlusCoeffTimesDeriv] DEout[de_,y_,x_]:=Module[{X,DE(*delist*),k,n}, PlusCoeffTimesDeriv[0,yy_,xx_,kk_,isfirst_]:=""; PlusCoeffTimesDeriv[-1,yy_,xx_,kk_,isfirst_]:=StringJoin[" - ",ToString[yy], DashTimes[kk-1],"[",ToString[xx],"]"]; PlusCoeffTimesDeriv[coeff_,yy_,xx_,kk_,isfirst_]:= StringJoin[" + ",InBrackets[coeff], ToString[yy],DashTimes[kk-1],"[",ToString[xx],"]"]/; !(SameQ[coeff,0]|| SameQ[InBrackets[coeff],"-"]|| isfirst); PlusCoeffTimesDeriv[coeff_,yy_,xx_,kk_,isfirst_]:=StringJoin[InBrackets[coeff], ToString[yy],DashTimes[kk-1],"[",ToString[xx],"]"]/; !(SameQ[coeff,0]|| SameQ[InBrackets[coeff],"-"])&& isfirst; InBrackets[1]:=""; InBrackets[-1]:="-"; InBrackets[expr_]:=Module[{}, LLast[xxx_]:=Last[xxx]/; (Length[xxx]>0); LLast[xxx_]:=xxx/;(Length[xxx]===0); If[(NumberQ[expr]&& (((Re[expr]===0) && (Im[expr]>0))|| Positive[expr]))|| SameQ[Head[expr],Symbol]|| (SameQ[Head[expr],Times]&& (!NumberQ[expr[[1]]]|| !Negative[expr[[1]]]|| (!((Re[expr[[1]]]===0)&&(Im[expr[[1]]]<0))&& SameQ[Head[expr[[1]]],Complex]) )), Return[StringJoin[ToString[InputForm[expr]]," "]], Return[StringJoin["(",ToString[InputForm[expr]],") "]] ] ]; FirstNonZero[liste_]:=Module[{}, length = Length[liste]; For[i=1,i<=length,++i, If[Not[SameQ[liste[[i]],0]],Return[i]] ]; Return[0] ]; If[SameQ[Head[de],Equal],DE=Expand[de[[1]]-de[[2]]],DE=Expand[de]]; DE=(DE /. y[x]->1); DE=(DE /. Derivative[n_][y][x]->X^n); delist=CoefficientList[DE,X]; first = FirstNonZero[delist]; join = ""; Do[join =StringJoin[ PlusCoeffTimesDeriv[Factor[delist[[k]]],y,x,k,(k == first)],join], {k,Length[delist],2,-1}]; join = StringJoin[join," == 0"]; If[first == 1 , join = StringJoin[InBrackets[Factor[delist[[1]]]],ToString[y],"[", ToString[x],"]",join] ]; join ] ComputeQlist[ak_,sol_,order_,xshift_,x_,k_]:=Module[{qlist, eq,makessense, left,right,maxlimitcount, limitcount,islimit,neworder }, undefined[z_] := SameQ[Head[z],DirectedInfinity] || SameQ[z,Indeterminate] || MemberQ[Map[Head,Level[z,-1]],DirectedInfinity] || MemberQ[Level[z,-1],Indeterminate]; (* enhanced limit functions *) limit[a_,b_] := Module[{l,r,r2,length}, Off[Limit::nlm,Power::infy,Infinity::indet]; r=a/.b; If[undefined[r], l=Limit[a,b]; If[Not[SameQ[Head[l],Limit]], r=l], (* else *) r2= r/.transformspecial1; If[!SameQ[r,r2], l=Limit[a,b]; If[Not[SameQ[Head[l],Limit]], r=l] ] ](* if undefined *); On[Limit::nlm,Power::infy,Infinity::indet]; Return[r] ]; neworder = order; limitcount=infcount = 0;maxinfcount=maxlimitcount=2; qlist={}; makessense=True; If[SpecialFunctionsPrintMessages, Print["specfun-info: Calculation of initial values..."]]; If[SameQ[Head[xshift],Integer], inte = True, inte = False]; If[SameQ[Head[xshift],Rational], rat = True; newxshift =xshift; q = Denominator[newxshift]; p = Numerator[newxshift], rat = False ]; Csol={{}}; If[inte,p=xshift]; If[inte||rat, For[ii=0, makessense&&Length[Csol[[1]]]1)); left= limit[Expand[powerfunction],x->0]/ii!; right = If[ii-xshift<0,0,limit[(ak/.k->k-xshift),k->ii]], (* else xshift rational *) powerfunction= Simplify[D[x^p*(sol[[1,1,2]] /. x->x^q),{x,ii}]]; powerfunction2= PowerExpand[Map[Together,powerfunction]]; If[(*FreeQ[powerfunction2,ArcTanh]*)True, powerfunction = powerfunction2]; (* This is somewhat tricky AND dubious *) powerfunction = (powerfunction /. (x^yy_/;Not[SameQ[Variables[yy],{}]]->1)); left= limit[Expand[powerfunction],x->0]/ii!; If[SameQ[Mod[ii,q],Mod[p,q]] && ii>=p,right = limit[(ak/.k->(k-p)/q),k->ii],right = 0] ]; (* If inte *) If[SameQ[left,Indeterminate], Print["specfun-info: Indeterminate encountered"]; ConvertReturnValue=2; Return[sol[[1,1,2]]]]; If[!FreeQ[left,Infinity]|| !FreeQ[left,ComplexInfinity]|| !FreeQ[left,DirectedInfinity]|| !FreeQ[right,Infinity]|| !FreeQ[right,ComplexInfinity]|| !FreeQ[right,DirectedInfinity], ++infcount, islimit= !FreeQ[left,Limit]|| !FreeQ[right,Limit]; If[islimit,AppendTo[limitlist,left];++limitcount]; If[Not[SameQ[Simplify[left-right],0]]&& Not[islimit], eq = (left == right); If[SameQ[eq,False], makessense = False;qlist ={}; If[SpecialFunctionsPrintMessages, Print["specfun-info: wrong limit evaluation"]], If[SpecialFunctionsPrintMessages, Print["specfun-info: ",InputForm[eq]]]; AppendTo[qlist,eq] ](* SameQ[eq,False] *) ](* if !SameQ *) ]; (* if !FreeQ *) (* 3 reasons to stop calculation *) If[(limitcount==maxlimitcount), If[SpecialFunctionsPrintMessages, Print["specfun-info: Mathematica is unable to compute ",limitcount," limit(s)"]; Print[" They can be found in the global variable limitlist"]; Print["specfun-info: unable to compute the following limits: ", InputForm[limitlist]] ]; makessense=False ]; If[(infcount== maxinfcount),makessense=False;qlist ={}; If[SpecialFunctionsPrintMessages, Print["specfun-info: too many (",maxinfcount,") infinities encountered"]] ];(*If(infcount== maxinfcount)*) If[ii>50, makessense=False;qlist={}]; If[Length[qlist] C[i] ]; {nexpr,norder} ](*module *) Clear[LogToArcSin] LogToArcSin[expr_]:=Module[{a,b,r,c,d,length,i,bi,blist}, inbrackets = expr[[1]]; inbrackets = inbrackets /.Power[x_, Rational[1, 2]]->Sqrt1[x]; inbrackets = inbrackets /.Power[x_, Rational[-1,2]]->1/Sqrt1[x]; length = Length[expr[[1]]];a =0; bi =0; If[length<1,Return[expr]]; For[i=1,i<=length,++i, If[FreeQ[inbrackets[[i]],Sqrt1], a += inbrackets[[i]], bi += inbrackets[[i]] ]; ];(*for*) blist = bi/.Head[bi]->List; inb = -1; For[i=1,i<=Length[blist],++i, blist[[i]]= blist[[i]]/.List->Head[bi]; If[SameQ[Head[blist[[i]]],Sqrt1],inb*=blist[[i,1]], inb*=blist[[i]]^2](* if *) ]; b= Sqrt[inb]; r= Simplify[Sqrt[a^2 +b^2]]; c = Together[b/(a+r)]; d = Together[c^2/(1+c^2)]; fin1=+Log[r]-2*I*ArcSin[Simplify[Sqrt[d]]]; fin2=fin1 /. ArcSin[Sqrt[1-xx_^2]]->Pi/2-ArcSin[xx]; fin1 ]/;SameQ[Head[expr],Log] LogToArcSin[expr_]:=Module[{expr2,i,clist,length}, expr2 = expr; clist = {}; length = Length[expr2]; If[length<1,Return[expr]]; For[i=1,i<=length,++i, AppendTo[clist, LogToArcSin[expr2[[i]]]] ](* for *); expr2 = (clist/.List ->Head[expr2]); expr2]/;Not[FreeQ[expr,Log]] LogToArcSin[expr_]:= expr (* Clear[Gegenbauer0Print,GegenbauerWarning] Gegenbauer0Print[GegenbauerC[kkk_,0,xxx_]]:= Module[{}, Print["specfun-info: GegenbauerC[",kkk,",0,",xxx,"] is not supported"]; Return [Null] ] Gegenbauer0Print[expr_]:= Map[Gegenbauer0Print,expr]/; Not[FreeQ[expr,GegenbauerC[kk_,aa_,xx_]]] Gegenbauer0Print[expr_]:= Null GegenbauerWarning[GegenbauerC[n_,a_,x_],list1_]:= Module[{list,length,i,already}, list:= list1;already =False; length= Length[list]; For[i=1,i<=length,++i, If[SameQ[list[[i]],a],already = True]; ] (* For *); If[Not[NumberQ[a]], If[!already,Print["specfun-warning: ", a," is assumed to be non-zero."]]; AppendTo[list,a] ] (* if !already *); list ] GegenbauerWarning[function_,list1_]:=Module[{list,length,i}, list:= list1; length= Length[function]; For[i=1,i<=length,++i, list= GegenbauerWarning[function[[i]],list] ] (* for *) ]/; (Length[function]>0)&&!FreeQ[function,GegenbauerC] GegenbauerWarning[function_,list_]:= list *) Clear[Convert,Convert1] Convert[expr11_,x111_]:=Module[{}, Print["specfun-info: ",InputForm[x111]," is not a valid variable."]; HoldForm[Convert[expr11,x111]]]/;!SameQ[Head[x111],Symbol] Convert[expr11_,x111_]:=Module[{}, Print["specfun-warning: Please unassign a with Clear[a]."]; HoldForm[Convert[expr11,x111]]]/;(!SameQ[Head[Global`a],Symbol]|| !SameQ[ToString[Head[Global`a[anything___]]],"a"]) Convert[expr11_,x111_]:=Module[{(*expr111*)}, (* ConvertReturnValue=4 -> FindRecursion versagt ConvertReturnValue=3 _> DSolve versagt ConvertReturnValue=2 -> Konstanten ungeloest ConvertReturnValue=1 -> Pattern spricht nicht an ConvertReturnValue=0 -> Prozedurverlauf korrekt ConvertReturnValue=-1 -> Prozedur abgebrochen Angabe klappt nur korrekt, falls lediglich eine einzelne Summe konvertiert wird. *) ConvertReturnValue=-1; Convert1[ff_+g_,x_]:=Convert1[ff,x]+Convert1[g,x]; Convert1[a_*ff_,x_]:=a*Convert1[ff,x] /; FreeQ[a,x]; Convert1[ff_,x_]:= ff/;FreeQ[ff,x]; Convert1[x_^m_.,x_]:=x^m; Convert1[Global`sum[expr_.*x_^(m_.*k_+b_.),{k_,n_,Infinity}],x_]:= Convert1[Global`sum[(expr/.k->k+n)*x^(m*k+(n*m+b)),{k,0,Infinity}],x]/;n!=0; Convert1[Global`sum[expr_.*x_^(m_.*k_+b_.),{k_,0,Infinity}],x_]:= Module[{i,j,jj,(*n,*)left,right(*ak,bk,recursion,order, Csol,sol,neworder,containsk,de,xshift*)}, Off[DSolve::dnim,Solve::trace]; limitlist ={}; ak = expr(*/. Sin[Times[Rational[1,n_], k, Pi]]-> (E^(I*k*Pi/n) - E^((-I)*k*Pi/n)); ak = ak /. Cos[Times[Rational[1,n_], k, Pi]]->(E^(I*k*Pi/n) + E^((-I)*k*Pi/n))*); {rectime,recursion} = Timing[FindRecursion[ak,k,Global`a][[1]]]; If[!FreeQ[recursion,FindRecursion], ConvertReturnValue=4; Return[Sum[expr*x^(m*k+b),{k,0,Infinity}]] ]; RE = recursion = SimpSinCos[recursion]; If[SpecialFunctionsPrintMessages&&!SameQ[recursion,1], Print[" ",InputForm[recursion/.{a->Global`a,k->Global`k}]==0]]; If[FreeQ[recursion,k], Return[Sum[expr*x^(m*k+b),{k,0,Infinity}]] , recursion = recursion/.Global`a[anything_]-> SpecialFunctions`Private`a[anything]; (* NEW to do *) recursion = Collect[recursion,a[k]]; recursionfactor=1; Do[containsk[jj]=1; recursionpart[jj]=Together[(recursion[[jj]]/(recursion[[jj]] /. a[anything_]->1))][[1]]; If[ Not[SameQ[Simplify[(recursion /. k->-Coefficient[recursionpart[jj],k,0]) /. a[anything_]-> If[anything<0,0,(ak/.k->anything)]],0]], containsk[jj]=recursionpart[jj]] , {jj,2,Length[recursion]}]; recursionfactor=Product[containsk[jj],{jj,2,Length[recursion]}]; (* naechste Zeile war draussen (warum ?), FINAL, wieder drin *) recursion=Collect[recursion*recursionfactor,a[k]]; (* check whether ak/.k->-1 == 0 *) Off[Infinity::indet]; If[Not[PolynomialQ[Together[recursionfactor/(1+k)],k]], If[Not[Simplify[(ak/.k->-1)]===0], recursion=Map[Times[(1+k),#]&,recursion]; recursion=Collect[recursion,a[k]]; ]]; On[Infinity::indet]; (* recursion=Map[Times[recursionfactor,#]&,recursion]; *) xshift=SmallestZeroOfPolyminal[Last[recursion]/a[k],k]; (* FINAL Versuch: statt de = backsubst[recursion,k,f,x]; *) de = RETODE[recursion,a,k,f,x][[1]]; DE = de = Numerator[Together[de]]; While[NumberQ[Denominator[Together[de/x]]],de= Expand[de/x]]; (* FINAL grade mal raus Wed Sep 18 14:36:43 MET DST 1996 numberlist=Union[Map[Plus[#,-k]&,Cases[Cases[recursion,a[k+_.],2],k+_.,2]]]; reorder=Max[numberlist]-Min[numberlist]; deorder=DEOrder[DE,f,x]; While[deorderGlobal`f,Global`f,x]]; Print["specfun-info: Trying to solve DE ..."]]; sol = DSolve[de == 0, f[x],x]; neworder = COrder[sol[[1,1,2]]]; If[Not[FreeQ[sol[[1,1,2]],DSolve`t]], If[SpecialFunctionsPrintMessages, Print["specfun-info: DSolve`t encountered"]]; sol[[1,1,2]] = (C[++neworder]+(sol[[1,1,2]] /. Integrate[expr3_,{DSolve`t,C[iii_],x}]-> HoldForm[Integrate[HoldForm[expr3/.DSolve`t->x],x]])); sol[[1,1,2]] = sol[[1,1,2]]/. HoldForm->Together; ]; If[Not[FreeQ[sol,DSolve]], If[SpecialFunctionsPrintMessages, Print["specfun-info: DSolve fails"]]; ConvertReturnValue=3; Return[Sum[expr*x^(m*k+b),{k,0,Infinity}]] , If[SpecialFunctionsPrintMessages, Print["specfun-info: DSolve computes "]; Print[" ",InputForm[sol[[1,1,2]]]]]; (* If *); sol = sol/.sol[[1,1,2]]-> Together[sol[[1,1,2]]]; sol = sol/.sol[[1,1,2]]-> Map[Together,sol[[1,1,2]]]; (* twice necessarily*) sol = sol/.sol[[1,1,2]]->EliminateNegativeLogarithms[sol[[1,1,2]]]; (* versagt bei Funktionen mehrerer Variablen, war zwischendurch ausgebaut, ist aber doch noetig, z.B. Convert[Sum[(k!)^2/(2k)!x^k,{k,0,Infinity}],x] *) sol = sol/.sol[[1,1,2]]->SimpConst[sol[[1,1,2]],x]; sol = Simplify[sol/. ArcTanhRule]; neworder = COrder[sol[[1,1,2]]]; {sol[[1,1,2]],neworder} = CRefresh[sol[[1,1,2]],neworder]; If[SpecialFunctionsPrintMessages, Print["specfun-info: expression rearranged:"]; Print[" ",InputForm[sol[[1,1,2]]]]]; If[(* momentan ausgebaut FreeQ[sol,HypergeometricU] && FreeQ[sol,Hypergeometric1F1]*)True, {qtime,qlist}= Timing[ComputeQlist[ak,sol,neworder,xshift,x,k]]; {Csoltime,Csol} = Timing[Solve[qlist,Table[C[jj],{jj,1,neworder}]]], Csol={}; If[SpecialFunctionsPrintMessages, Print["specfun-info: Solve not applied (hypergeometric)"]]; ConvertReturnValue=2 ](* FreeQ[sol,HypergeometricU]*); If[SameQ[Flatten[Csol],{}] || Not[FreeQ[Csol,Solve]]||Not[FreeQ[Csol,DirectedInfinity]], presol=sol, presol=Flatten[sol /.Csol]; ]; On[DSolve::dnim,Solve]; endsol = Map[Together,Simplify[x^b* (Flatten[presol][[1,2]]/.x->x^m)]]; endsol ] (* if Not[FreeQ[sol,DSolve]]*) ] (* If FreeQ[recursion,k] *) ]; (* module Convert1 *) Convert1[expr_,x_]:= expr; (* main *) (* If[Not[FreeQ[expr11,GegenbauerC[kkk_,0,xxx_]]], Gegenbauer0Print[expr11]; Return[HoldForm[Convert[expr11,x111]]] ]; If[Not[FreeQ[expr11,GegenbauerC[kkk_,aaa_,xxx_]]], GegenbauerWarning[expr11,{}]]; *) If[Not[FreeQ[expr11,C]], expr111= expr11/.C->CC; x11 =x111/.C->CC; If[SpecialFunctionsPrintMessages, Print["specfun-info: C renamed to CC"]], expr111 = expr11; x11 =x111]; If[Not[FreeQ[expr11,N]], expr111= expr11/.N->NN; x11 =x111/.N->NN; If[SpecialFunctionsPrintMessages, Print["specfun-info: N renamed to NN"]], expr111 = expr11; x11 =x111]; expr111 = Convert1[expr111,x11]; If[Not[FreeQ[expr111,Convert1]]||Not[FreeQ[expr111,C]],Return[expr111]]; expr1111 =(expr111 //. AbsRules); If[Not[(*FreeQ[expr111,Complex]||*)FreeQ[expr111,Log]], expr111 =Simplify[LogToArcSin[expr111]]]; expr111 = expr111//.Power[Power[xx_,pp_ ], Rational[1, 2]]->Holder[xx^pp]; expr111 = expr111//. Power[Power[xx_,pp_ ], Rational[-1, 2]]->1/Holder[xx^pp]; expr111 = (expr111//.Holder -> SimpSqrt); expr111 = (Expand[expr111]//. AbsRules); expr111 = Together[expr111]; expr111 = (expr111//.AbsRules); expr111 = Together[expr111/. {Cosh[x_]->(E^x+E^(-x))/2,Sinh[x_]->(E^x-E^(-x))/2}]; expr111 = Simplify[expr111]//.AbsRules; expr111 = Expand[expr111]; If[Not[FreeQ[expr111,Complex]],expr111 = (expr111/.ArcSin[Sqrt[x_]]->I ArcSinh[Sqrt[-x]])]; If[Not[FreeQ[expr111,Complex]],expr111 = (expr111/.Times[Complex[0, x_],Power[y_,1/2]]->Power[-y,1/2])]; If[Not[FreeQ[expr111,Complex]],expr111 = (expr111/.Times[Complex[0, x_],Power[y_,-1/2]]->Power[-y,-1/2])]; expr111 = (expr111//.AbsRules); If[Not[FreeQ[expr11,C]], expr111= expr111/.CC>C; If[SpecialFunctionsPrintMessages, Print["specfun-info: CC renamed back to C"]], Null]; If[Not[FreeQ[expr11,N]], expr111= expr111/.NN->N; If[SpecialFunctionsPrintMessages, Print["specfun-info: NN renamed back to N"]], Null]; If[SameQ[ConvertReturnValue,4]||SameQ[ConvertReturnValue,3], Return[HoldForm[Convert[expr11,x111]]]]; ConvertReturnValue=0; If[Length[expr1111]1/x,x,0,order]; temp/.x->1/x ] Clear[SumToHypergeometric,FunctionToHypergeometric] Clear[ArgumentPosition,HyperTerm, SimplifyGamma,SimpComb,Ratio,SimplifyCombinatorial,ToGamma,GammaArgs, Superficious,RemoveIntegerDifferenceElements] HyperTerm[upper_,lower_,x_,k_]:=Module[{j}, Product[Pochhammer[upper[[j]],k],{j,1,Length[upper]}]/ (k!*Product[Pochhammer[lower[[j]],k],{j,1,Length[lower]}])*x^k ] Ratio[term1_,k_]:=SimplifyCombinatorial[(term1/.k->k+1)/term1] SimpComb[term1___]:=SimplifyCombinatorial[term1] SimplifyCombinatorial[term1_]:= SimplifyGamma[ToGamma[term1]] (* converts Binomials, products, pochhammers, and factorials in term1 into gammas, and applies SimplifyGamma to the modified term1*) ToGamma[term2_] := Module[ (*converts Binomials, products, pochhammers, and factorials in term1 into gammas*) {term1, n,k, m1, m2, term}, term1 = term2; term1 = (term1 /. Pochhammer[n_, 0] -> 1); term1 = (term1 /. Pochhammer[0, k_] -> 0); term1 = (term1 /. Pochhammer[n_, k_] -> Gamma[n + k]/Gamma[n]); term1 = (term1 /. Binomial[n_, k_] -> Factorial[n]/(Factorial[n - k]*Factorial[k])); term1 = (term1 /. Factorial[k_] -> Gamma[k + 1]); Return[term1]] SimplifyGamma[term1_] := Module[{term2, highl, lhighl, i, k, j, n}, term2 = term1 /. Gamma[k_] :> Gamma [Expand[k]]; term2 = term2 /. Pochhammer[n_, k_] :> Pochhammer[Expand[n], Expand[k]]; highl = GammaArgs[term2]; highl = RemoveIntegerDifferenceElements[highl]; highl = Map[Expand[#] &, highl]; lhighl = Length[highl]; For[i = 1, i <= lhighl, i++, n = highl[[i]]; term2 = (term2 /. Gamma[k_] -> Hold[k, n]); term2 = (term2 /. Hold -> ShiftGamma); term2 = Evaluate[term2];]; Return[Factor[term2]]] ShiftGamma[xx_, nn_] := Module[{j, x, n}, n = Expand[nn]; x = Expand[xx]; If[! IntegerQ[x - n] || (x - n == 0), Return[Gamma[x]]]; If[x - n > 0, Gamma[n]*Product[n + j, {j, 0, x - n - 1}], Gamma[n]/Product[n + j, {j, x - n, -1}]]] GammaArgs[term1_]:=Module[{term2,highl,lhighl,i}, If[FreeQ[term1,Gamma],RETURN[{}]]; pos= Position[term1,Gamma]; argl:=Map[term1[[ArgumentPosition[#]]]&,pos]; Return[argl] ] ArgumentPosition[list1_]:= Sequence[ Delete[list1,Length[list1]]/.List->Sequence,1] RemoveIntegerDifferenceElements[{}]:={} RemoveIntegerDifferenceElements[list_]:= Module[{length,last,nolast}, length= Length[list]; last= list[[length]]; nolast= Delete[list,length]; If[Superficious[nolast,last], RemoveIntegerDifferenceElements[nolast], Append[RemoveIntegerDifferenceElements[nolast],last]] ] Superficious[list_,element_]:= Or[Evaluate[Map[IntegerQ[#-element]&,list]/.List->Sequence]] SumToHypergeometric[Global`sum[aa_,{k_,0,Infinity}]]:= Module[{a,rat,num,den,numlist,denlist,lcoeff,numfactorlist, denfactorlist,jj,kk,variables,tmp}, a=SimplifyCombinatorial[aa]; rat=(a/.k->k+1)/a*(k+1); rat=SimplifyCombinatorial[rat]; num=Numerator[rat]; den=Denominator[rat]; numlist=CoefficientList[num,k]; denlist=CoefficientList[den,k]; lcoeff=Simplify[numlist[[Length[numlist]]]/denlist[[Length[denlist]]]]; numlist={}; denlist={}; numfactorlist=FactorList[num]; denfactorlist=FactorList[den]; If[Not[SameQ[numfactorlist,{}]], Do[If[Not[FreeQ[numfactorlist[[jj,1]],k]], Do[ AppendTo[numlist,-Solve[numfactorlist[[jj,1]]==0,k][[1,1,2]]], {kk,1,numfactorlist[[jj,2]]}]], {jj,1,Length[numfactorlist]}]]; tmp=numberofzeros[numlist]; If[tmp>0,Return[SumToHypergeometric[Global`sum[a/.k->k-tmp,{k,0,Infinity}]]]]; If[Not[SameQ[denfactorlist,{}]], Do[If[Not[FreeQ[denfactorlist[[jj,1]],k]], Do[ AppendTo[denlist,-Solve[denfactorlist[[jj,1]]==0,k][[1,1,2]]], {kk,1,denfactorlist[[jj,2]]}]], {jj,1,Length[denfactorlist]}]]; tmp=numberofzeros[denlist]; If[tmp>0,Return[SumToHypergeometric[Global`sum[a/.k->k+tmp,{k,0,Infinity}]]]]; SimplifyCombinatorial[ Limit[a,k->0]*Global`hypergeometricPFQ[numlist,denlist,lcoeff]] ] SumToHypergeometric[Global`sum[a_,{k_,k0_,Infinity}]]:= SumToHypergeometric[Global`sum[(a/.k->k+k0),{k,0,Infinity}]] SumToHypergeometric[c_.*Global`sum[a_,{k_,k0_,Infinity}]+ d_.*Global`sum[b_,{k_,k0_,Infinity}]]:= SumToHypergeometric[Global`sum[c*a+d*b,{k,k0,Infinity}]] SumToHypergeometric[expr_]:=SumToHypergeometric[Expand[expr]] /; Not[SameQ[expr,Expand[expr]]] numberofzeros[list_]:=Module[{j,tmp}, tmp=0; Do[If[list[[j]]==0,tmp=tmp+1],{j,1,Length[list]}]; tmp ] FunctionToHypergeometric[fun_,x_]:=SumToHypergeometric[PS[fun,x]] ZTransform[a_,k_,z_]:=Module[{convert,x}, If[SameQ[Head[Global`x],Symbol],x=Global`x]; If[SpecialFunctionsPrintMessages, Print["specfun-info: ",x," = ",1/z]]; convert=Convert[Global`sum[a x^k,{k,0,Infinity}],x]; convert/.x->1/z ] InverseZTransform[f_,z_]:=Module[{ps,x}, ps=PS[f/.z->1/x,x]; If[SameQ[Head[ps],Global`sum]&&FreeQ[ps[[1]]/x^k,x],ps=ps[[1]]/x^k]; ps/.{x->1/z} ] SeriesSolution[DE_,y_[x_],incslist_,maxorder_]:= SeriesSolution[DE,y,x,incslist,maxorder] SeriesSolution[DE_,y_,x_,incslist_,maxorder_]:=Module[ {RE,a,n,min,reorder,deorder,DE1,j,RE1,coeff,numberlist}, (* make homogeneous *) DE1=DE; While[Not[SameQ[DE1[[2]],0]],DE1=D[DE1,x]]; RE=DEtoRE[DE1,y,x,a,n]; numberlist=Union[Map[Plus[#,-n]&,Cases[Cases[RE[[1]], a[n+_.],2],n+_.,2]]]; reorder=Max[numberlist]; DE1=DE; deorder=DEOrder[DE1,y,x]; Do[coeff[j]=incslist[[j+1]]/j!,{j,0,Length[incslist]-1}]; Do[ sol=Solve[DE1,Derivative[j][y][x]][[1,1]]; sol=sol[[2]]/.{Derivative[k_][y][x]->a[k]*k!,y[x]->a[0],x->0}; coeff[j]=sol/j!/.{a[k_]->coeff[k]}; DE1=D[DE1,x], {j,deorder,reorder-1}]; RE1=(Solve[RE,a[n+reorder]][[1,1]]/.n->n-reorder); RE1=(RE1/.a->coeff); Do[ coeff[j]=(RE1[[2]]/.n->j), {j,reorder,maxorder}]; Sum[coeff[k] x^k,{k,0,maxorder}] ] Taylor[f_,x_,n_]:=Module[ {DE,deorder,incslist,y,j}, DE=HolonomicDE[f,x,y]; deorder=DEOrder[DE,y,x]; incslist=Table[D[f,{x,j}],{j,0,deorder-1}]; incslist=incslist/.x->0; SeriesSolution[DE,y,x,incslist,n] ] Taylor[func_,{y_,y0_,n_}]:=Module[{temp(*x*)}, If[SpecialFunctionsPrintMessages, funcp = func /.y->x+y0; Print["specfun-info: working with ",funcp /. x->Global`x]]; temp = Taylor[(func /. y->x+y0),x,n]; temp/. (x->y-y0) ]/;!SameQ[ToString[y0],"x"] Taylor[func_,{y_,y0_,n_}]:=Module[{}, Print["specfun-warning: Please use another symbol than x as third argument"]; HoldForm[Taylor[func,{y,y0,n}]] ] (* PACKAGE *) Protect[ ComplexFactor,ComplexApart,SimpleDE,DEtoRE,SimpleRE,DEOrder, PowerSeries,PS,Convert,SimpByRecursion,FindRecursion, AsymptPowerSeries,Bateman,Hankel1, Hankel2, KummerM, KummerU, WhittakerM,WhittakerW, StruveH, StruveL, Erfc, Abramowitz, NormalIntegral, KnuthA, KnuthB, ParabolicU, ParabolicD, ParabolicV, Hypergeometric0F1, Hypergeometric1F0, HypergeometricU, Hypergeometric1F1, Hypergeometric2F0, Hypergeometric2F1, Hypergeometric2F3, Hypergeometric3F2, specfunprint,specfunprintoff,nospecfunprint,RETODE,REtoDE,SumtoDE, SumDE,DESum,ProductDE,DEProduct,SumRE,RESum,ProductRE,REProduct,ConvolutionRE, SumToHypergeometric,FuncionToHypergeometric, ZTransform,InverseZTransform, SimplifyGamma,ToGamma,SimpComb,SimplifyCombinatorial,Ratio,HyperTerm, SeriesSolution,Taylor ] On[SetDelayed::write] On[TagSetDelayed::write] End[] (*Private *) EndPackage[] (* % Unprotect[HypergeometricPFQ] % Clear[HypergeometricPFQ] % Protect[HypergeometricPFQ] *)