1(* ::Package:: *) 2 3(************************************************************************) 4(* This file was generated automatically by the Mathematica front end. *) 5(* It contains Initialization cells from a Notebook file, which *) 6(* typically will have the same name as this file except ending in *) 7(* ".nb" instead of ".m". *) 8(* *) 9(* This file is intended to be loaded into the Mathematica kernel using *) 10(* the package loading commands Get or Needs. Doing so is equivalent *) 11(* to using the Evaluate Initialization Cells menu command in the front *) 12(* end. *) 13(* *) 14(* DO NOT EDIT THIS FILE. This entire file is regenerated *) 15(* automatically each time the parent Notebook file is saved in the *) 16(* Mathematica front end. Any changes you make to this file will be *) 17(* overwritten. *) 18(************************************************************************) 19 20 21 22(* TimeLimit is the time constraint in seconds on some potentially expensive routines. *) 23If[Not[NumberQ[TimeLimit]], TimeLimit=1.0]; 24 25 26(* Note: Clear[func] also eliminates 2-D display of functions like Integrate. *) 27ClearDownValues[func_Symbol] := ( 28 Unprotect[func]; 29 DownValues[func]={}; 30 Protect[func]) 31 32 33SetDownValues[func_Symbol,lst_List] := ( 34 Unprotect[func]; 35 DownValues[func]=Take[lst,Min[529,Length[lst]]]; 36 Scan[Function[ReplacePart[ReplacePart[#,#[[1,1]],1],SetDelayed,0]],Drop[lst,Min[529,Length[lst]]]]; 37 Protect[func]) 38 39 40(* MoveDownValues[func1,func2] moves func1's DownValues to func2, and deletes them from func1. *) 41MoveDownValues[func1_Symbol,func2_Symbol] := Module[{lst}, 42 SetDownValues[func2,ReplaceAll[DownValues[func1],{func1->func2}]]; 43 ClearDownValues[func1]] 44 45 46Map2[func_,lst1_,lst2_] := 47 ReapList[Do[Sow[func[lst1[[i]],lst2[[i]]]],{i,Length[lst1]}]] 48 49 50ReapList[u_] := 51 Module[{lst=Reap[u][[2]]}, 52 If[lst==={}, lst, lst[[1]]]] 53 54SetAttributes[ReapList,HoldFirst] 55 56 57(* MapAnd[f,l] applies f to the elements of list l until False is returned; else returns True *) 58MapAnd[f_,lst_] := 59 Catch[Scan[Function[If[f[#],Null,Throw[False]]],lst];True] 60 61MapAnd[f_,lst_,x_] := 62 Catch[Scan[Function[If[f[#,x],Null,Throw[False]]],lst];True] 63 64 65(* MapOr[f,l] applies f to the elements of list l until True is return; else returns False *) 66MapOr[f_,lst_] := 67 Catch[Scan[Function[If[f[#],Throw[True],Null]],lst];False] 68 69 70(* If u is a sum, MapSum[f,u,x] applies f to the terms of u; else it applies f to u. *) 71(* MapSum[f_,u_,x_Symbol] := 72 If[SumQ[u], 73 Map[Function[f[#,x]],u], 74 f[u,x]] *) 75 76 77(* NotIntegrableQ[u,x] returns True if u is definitely not integrable wrt x; else it returns 78 False if u is, or might be, integrable wrt x. *) 79NotIntegrableQ[u_,x_Symbol] := 80 MatchQ[u,x^m_*Log[a_+b_.*x]^n_ /; FreeQ[{a,b},x] && IntegersQ[m,n] && m<0 && n<0] || 81 MatchQ[u,f_[x^m_.*Log[a_.+b_.*x]] /; FreeQ[{a,b},x] && IntegerQ[m] && (TrigQ[f] || HyperbolicQ[f])] 82 83 84(* ZeroQ[u1,u2,...] returns True if u1, u2, ... are all 0; else returns False *) 85ZeroQ[u_] := Quiet[PossibleZeroQ[u]] 86NonzeroQ[u_] := Not[Quiet[PossibleZeroQ[u]]] 87 88ZeroQ[u__] := Catch[Scan[Function[If[ZeroQ[#],Null,Throw[False]]],{u}];True] 89 90 91(* OneQ[u1,u2,...] returns True if u1, u2, ... are all 1; else returns False *) 92OneQ[u_] := PossibleZeroQ[u-1] 93 94OneQ[u__] := Catch[Scan[Function[If[OneQ[#],Null,Throw[False]]],{u}];True] 95 96 97(* RealNumericQ[u] returns True if u is a real numeric quantity, else returns False. *) 98RealNumericQ[u_] := NumericQ[u] && PossibleZeroQ[Im[N[u]]] 99 100 101(* ImaginaryNumericQ[u] returns True if u is an imaginary numeric quantity, else returns False. *) 102ImaginaryNumericQ[u_] := 103 NumericQ[u] && PossibleZeroQ[Re[N[u]]] && Not[PossibleZeroQ[Im[N[u]]]] 104 105 106(* PositiveQ[u] returns True if u is a positive numeric quantity, else returns False. *) 107PositiveQ[u_] := 108 Module[{v=Simplify[u]}, 109 RealNumericQ[v] && Re[N[v]]>0] 110 111 112(* PositiveOrZeroQ[u] returns True if u is a nonpositive numeric quantity, else returns False. *) 113PositiveOrZeroQ[u_] := 114 Module[{v=Simplify[u]}, 115 RealNumericQ[v] && Re[N[v]]>=0] 116 117 118(* NegativeQ[u] returns True if u is a negative numeric quantity, else returns False. *) 119NegativeQ[u_] := 120 Module[{v=Simplify[u]}, 121 RealNumericQ[v] && Re[N[v]]<0] 122 123 124(* NegativeQ[u] returns True if u is a negative numeric quantity, else returns False. *) 125NegativeOrZeroQ[u_] := 126 Module[{v=Simplify[u]}, 127 RealNumericQ[v] && Re[N[v]]<=0] 128 129 130(* IntegersQ[m,n,...] returns True if m, n, ... are all explicit integers; else it returns False. *) 131IntegersQ[u__] := Catch[Scan[Function[If[IntegerQ[#],Null,Throw[False]]],{u}]; True]; 132 133 134(* PositiveIntegerQ[m,n,...] returns True if m, n, ... are all explicit positive integers; else it returns False. *) 135PositiveIntegerQ[u__] := Catch[Scan[Function[If[IntegerQ[#] && #>0,Null,Throw[False]]],{u}]; True]; 136 137 138(* NegativeIntegerQ[m,n,...] returns True if m, n, ... are all explicit negative integers; else it returns False. *) 139NegativeIntegerQ[u__] := Catch[Scan[Function[If[IntegerQ[#] && #<0,Null,Throw[False]]],{u}]; True]; 140 141 142(* FractionQ[m,n,...] returns True if m, n, ... are all explicit fractions; else it returns False. *) 143FractionQ[u__] := Catch[Scan[Function[If[Head[#]===Rational,Null,Throw[False]]],{u}]; True] 144 145 146(* RationalQ[m,n,...] returns True if m, n, ... are all explicit integers or fractions; else it returns False. *) 147RationalQ[u__] := Catch[Scan[Function[If[IntegerQ[#] || Head[#]===Rational,Null,Throw[False]]],{u}]; True] 148 149 150(* FractionOrNegativeQ[u] returns True if u is a fraction or negative number; else returns False *) 151FractionOrNegativeQ[u__] := Catch[Scan[Function[If[FractionQ[#] || IntegerQ[#] && #<0,Null,Throw[False]]],{u}]; True] 152 153 154(* SqrtNumberQ[u] returns True if u^2 is a rational number; else it returns False. *) 155SqrtNumberQ[m_^n_] := 156 IntegerQ[n] && SqrtNumberQ[m] || IntegerQ[n-1/2] && RationalQ[m] 157 158SqrtNumberQ[u_*v_] := 159 SqrtNumberQ[u] && SqrtNumberQ[v] 160 161SqrtNumberQ[u_] := 162 RationalQ[u] || u===I 163 164 165SqrtNumberSumQ[u_] := 166 SumQ[u] && SqrtNumberQ[First[u]] && SqrtNumberQ[Rest[u]] || 167 ProductQ[u] && SqrtNumberQ[First[u]] && SqrtNumberSumQ[Rest[u]] 168 169 170(* AlgebraicNumberQ[u] returns True if u is a real-valued algebraic number (a rational number, 171 an algebraic number raised to an integer power, a positive algebraic number raised to a 172 fractional power, or a product or sum of algebraic numbers); else returns False. *) 173(* AlgebraicNumberQ[u_] := 174 MapAnd[AlgebraicNumberQ,u] /; 175ListQ[u] 176 177AlgebraicNumberQ[u_^v_] := 178 AlgebraicNumberQ[u] && (IntegerQ[v] || PositiveQ[u] && FractionQ[v]) 179 180AlgebraicNumberQ[u_*v_] := 181 AlgebraicNumberQ[u] && AlgebraicNumberQ[v] 182 183AlgebraicNumberQ[u_+v_] := 184 AlgebraicNumberQ[u] && AlgebraicNumberQ[v] 185 186AlgebraicNumberQ[u_] := 187 RationalQ[u] *) 188 189 190NiceSqrtQ[u_] := 191 Not[NegativeQ[u]] && NiceSqrtAuxQ[u] 192 193NiceSqrtAuxQ[u_] := 194 If[RationalQ[u], 195 u>0, 196 If[PowerQ[u], 197 EvenQ[u[[2]]], 198 If[ProductQ[u], 199 NiceSqrtAuxQ[First[u]] && NiceSqrtAuxQ[Rest[u]], 200 If[SumQ[u], 201 Function[NonsumQ[#] && NiceSqrtAuxQ[#]] [Simplify[u]], 202 False]]]] 203 204 205(* If u is a rational number whose squareroot is rational or if u is of the form u1^n1 u2^n2 ... 206 and n1, n2, ... are even, PerfectSquareQ[u] returns True; else it returns False. *) 207PerfectSquareQ[u_] := 208 If[RationalQ[u], 209 u>0 && u!=1 && RationalQ[Sqrt[u]], 210 If[PowerQ[u], 211 EvenQ[u[[2]]], 212 If[ProductQ[u], 213 PerfectSquareQ[First[u]] && PerfectSquareQ[Rest[u]], 214 If[SumQ[u], 215 Function[NonsumQ[#] && PerfectSquareQ[#]] [Simplify[u]], 216 False]]]] 217 218 219(* If u is a perfect square, PerfectSquareRoot[u] returns the squareroot of u. *) 220(* PerfectSquareRoot[u_] := 221 If[RationalQ[u], 222 Sqrt[u], 223 If[PowerQ[u], 224 u[[1]]^(u[[2]]/2), 225 If[ProductQ[u], 226 PerfectSquareRoot[First[u]]*PerfectSquareRoot[Rest[u]], 227 If[SumQ[u], 228 PerfectSquareRoot[Simplify[u]], 229 False]]]] *) 230 231 232FalseQ[u_] := 233 u===False 234 235 236NotFalseQ[u_] := 237 u=!=False 238 239 240SumQ[u_] := 241 Head[u]===Plus 242 243NonsumQ[u_] := 244 Head[u]=!=Plus 245 246ProductQ[u_] := 247 Head[u]===Times 248 249PowerQ[u_] := 250 Head[u]===Power 251 252IntegerPowerQ[u_] := 253 PowerQ[u] && IntegerQ[u[[2]]] 254 255PositiveIntegerPowerQ[u_] := 256 PowerQ[u] && IntegerQ[u[[2]]] && u[[2]]>0 257 258FractionalPowerQ[u_] := 259 PowerQ[u] && FractionQ[u[[2]]] 260 261RationalPowerQ[u_] := 262 PowerQ[u] && RationalQ[u[[2]]] 263 264SqrtQ[u_] := 265 PowerQ[u] && u[[2]]===1/2 266 267ExpQ[u_] := 268 PowerQ[u] && u[[1]]===E 269 270ImaginaryQ[u_] :=\ 271 Head[u]===Complex && Re[u]===0 272 273 274FractionalPowerFreeQ[u_] := 275 If[AtomQ[u], 276 True, 277 If[FractionalPowerQ[u] && Not[AtomQ[u[[1]]]], 278 False, 279 Catch[Scan[Function[If[FractionalPowerFreeQ[#],Null,Throw[False]]],u];True]]] 280 281 282ComplexFreeQ[u_] := 283 If[AtomQ[u], 284 Head[u]=!=Complex, 285 Catch[Scan[Function[If[ComplexFreeQ[#],Null,Throw[False]]],u];True]] 286 287 288LogQ[u_] := 289 Head[u]===Log 290 291 292SinQ[u_] := 293 Head[u]===Sin 294 295CosQ[u_] := 296 Head[u]===Cos 297 298TanQ[u_] := 299 Head[u]===Tan 300 301CotQ[u_] := 302 Head[u]===Cot 303 304SecQ[u_] := 305 Head[u]===Sec 306 307CscQ[u_] := 308 Head[u]===Csc 309 310 311SinhQ[u_] := 312 Head[u]===Sinh 313 314CoshQ[u_] := 315 Head[u]===Cosh 316 317TanhQ[u_] := 318 Head[u]===Tanh 319 320CothQ[u_] := 321 Head[u]===Coth 322 323SechQ[u_] := 324 Head[u]===Sech 325 326CschQ[u_] := 327 Head[u]===Csch 328 329 330(* TrigQ[u] returns True if u or the head of u is a trig function; else returns False *) 331TrigQ[u_] := 332 MemberQ[{Sin,Cos,Tan,Cot,Sec,Csc},If[AtomQ[u],u,Head[u]]] 333 334(* InverseTrigQ[u] returns True if u or the head of u is an inverse trig function; else returns False *) 335InverseTrigQ[u_] := 336 MemberQ[{ArcSin,ArcCos,ArcTan,ArcCot,ArcSec,ArcCsc},If[AtomQ[u],u,Head[u]]] 337 338(* HyperbolicQ[u] returns True if u or the head of u is a trig function; else returns False *) 339HyperbolicQ[u_] := 340 MemberQ[{Sinh,Cosh,Tanh,Coth,Sech,Csch},If[AtomQ[u],u,Head[u]]] 341 342(* InverseHyperbolicQ[u] returns True if u or the head of u is an inverse trig function; else returns False *) 343InverseHyperbolicQ[u_] := 344 MemberQ[{ArcSinh,ArcCosh,ArcTanh,ArcCoth,ArcSech,ArcCsch},If[AtomQ[u],u,Head[u]]] 345 346 347SinCosQ[f_] := 348 MemberQ[{Sin,Cos,Sec,Csc},f] 349 350 351SinhCoshQ[f_] := 352 MemberQ[{Sinh,Cosh,Sech,Csch},f] 353 354 355CalculusFunctions={D,Integrate,Sum,Product,Int,Dif,Subst}; 356 357(* CalculusQ[u] returns True if the head of u is a calculus function; else returns False *) 358CalculusQ[u_] := 359 MemberQ[CalculusFunctions,Head[u]] 360 361CalculusFreeQ[u_,x_] := 362 If[AtomQ[u], 363 True, 364 If[CalculusQ[u] && u[[2]]===x || HeldFormQ[u], 365 False, 366 Catch[Scan[Function[If[CalculusFreeQ[#,x],Null,Throw[False]]],u];True]]] 367 368 369HeldFormQ[u_] := 370 If[AtomQ[Head[u]], 371 MemberQ[{Hold,HoldForm,Defer,Pattern},Head[u]], 372 HeldFormQ[Head[u]]] 373 374 375(* InverseFunctionQ[u] returns True if u is a call on an inverse function; else returns False. *) 376InverseFunctionQ[u_] := 377 LogQ[u] || InverseTrigQ[u] && Length[u]==1 || InverseHyperbolicQ[u] || Head[u]===Mods 378 379 380(* If u is free of inverse or calculus functions involving x, 381 InverseFunctionFreeQ[u,x] returns true; else it returns False. *) 382TrigHyperbolicFreeQ[u_,x_Symbol] := 383 If[AtomQ[u], 384 True, 385 If[TrigQ[u] || HyperbolicQ[u] || CalculusQ[u], 386 FreeQ[u,x], 387 Catch[Scan[Function[If[TrigHyperbolicFreeQ[#,x],Null,Throw[False]]],u];True]]] 388 389 390(* If u is free of inverse or calculus functions involving x, 391 InverseFunctionFreeQ[u,x] returns true; else it returns False. *) 392InverseFunctionFreeQ[u_,x_Symbol] := 393 If[AtomQ[u], 394 True, 395 If[InverseFunctionQ[u] || CalculusQ[u], 396(* If[Head[u]===ArcTan && TanQ[u[[1]]] || Head[u]===ArcCot && CotQ[u[[1]]] || 397 Head[u]===ArcTanh && TanhQ[u[[1]]] || Head[u]===ArcCoth && CothQ[u[[1]]], 398 InverseFunctionFreeQ[u[[1,1]],x], *) 399 FreeQ[u,x], 400 Catch[Scan[Function[If[InverseFunctionFreeQ[#,x],Null,Throw[False]]],u];True]]] 401 402 403(* ElementaryExpressionQ[u] returns True if u is a sum, product, or power and all the operands 404 are elementary expressions; or if u is a call on a trig, hyperbolic, or inverse function 405 and all the arguments are elementary expressions; else it returns False. *) 406(* ElementaryFunctionQ[u_] := 407 If[AtomQ[u], 408 True, 409 If[SumQ[u] || ProductQ[u] || PowerQ[u] || TrigQ[u] || HyperbolicQ[u] || InverseFunctionQ[u], 410 Catch[Scan[Function[If[ElementaryFunctionQ[#],Null,Throw[False]]],u];True], 411 False]] *) 412 413 414(* If u is an expression of the form -v, NegativeCoefficientQ[u] returns True; else False. *) 415NegativeCoefficientQ[u_] := 416 If[SumQ[u], 417(* MapAnd[NegativeCoefficientQ,u], *) 418 NegativeCoefficientQ[First[u]], 419 MatchQ[u, m_*v_. /; RationalQ[m] && m<0]] 420 421 422(* Real[u] returns True if u is a real-valued quantity, else returns False. *) 423RealQ[u_] := 424 MapAnd[RealQ,u] /; 425ListQ[u] 426 427RealQ[u_] := 428 PossibleZeroQ[Im[N[u]]] /; 429NumericQ[u] 430 431RealQ[u_^v_] := 432 RealQ[u] && RealQ[v] && (IntegerQ[v] || PositiveOrZeroQ[u]) 433 434RealQ[u_*v_] := 435 RealQ[u] && RealQ[v] 436 437RealQ[u_+v_] := 438 RealQ[u] && RealQ[v] 439 440RealQ[f_[u_]] := 441 If[MemberQ[{Sin,Cos,Tan,Cot,Sec,Csc,ArcTan,ArcCot,Erf},f], 442 RealQ[u], 443 If[MemberQ[{ArcSin,ArcCos},f], 444 LE[-1,u,1], 445 If[f===Log, 446 PositiveOrZeroQ[u], 447 False]]] 448 449RealQ[u_] := 450 False 451 452 453(* If u is not 0 and has a positive form, PosQ[u] returns True, else it returns False. *) 454PosQ[u_] := 455 If[RationalQ[u], 456 u>0, 457 If[NumberQ[u], 458 If[PossibleZeroQ[Re[u]], 459 Im[u]>0, 460 Re[u]>0], 461 If[NumericQ[u], 462 Module[{v=N[u]}, 463 If[PossibleZeroQ[Re[v]], 464 Im[v]>0, 465 Re[v]>0]], 466 If[ProductQ[u], 467 If[PosQ[First[u]], 468 PosQ[Rest[u]], 469 Not[PosQ[Rest[u]]]], 470(* Module[{v=Together[u]}, 471 If[ProductQ[v], 472 If[PosQ[First[v]], 473 PosQ[Rest[v]], 474 Not[PosQ[Rest[v]]]], 475 PosQ[v]]], *) 476 If[SumQ[u], 477 Module[{v=Together[Simplify[Together[u]]]}, 478 If[SumQ[v], 479 PosQ[First[v]], 480 PosQ[v]]], 481 True]]]]] 482 483 484NegQ[u_] := 485 If[PossibleZeroQ[u], 486 False, 487 Not[PosQ[u]]] 488 489 490LeadTerm[u_] := 491 If[SumQ[u], 492 First[u], 493 u] 494 495 496RemainingTerms[u_] := 497 If[SumQ[u], 498 Rest[u], 499 0] 500 501 502(* LeadFactor[u] returns the leading factor of u. *) 503LeadFactor[u_] := 504 If[ProductQ[u], 505 LeadFactor[First[u]], 506 If[ImaginaryQ[u], 507 If[Im[u]===1, 508 u, 509 LeadFactor[Im[u]]], 510 u]] 511 512 513(* RemainingFactors[u] returns the remaining factors of u. *) 514RemainingFactors[u_] := 515 If[ProductQ[u], 516 RemainingFactors[First[u]]*Rest[u], 517 If[ImaginaryQ[u], 518 If[Im[u]===1, 519 1, 520 I*RemainingFactors[Im[u]]], 521 1]] 522 523 524(* LeadBase[u] returns the base of the leading factor of u. *) 525LeadBase[u_] := 526 Module[{v=LeadFactor[u]}, 527 If[PowerQ[v], 528 v[[1]], 529 v]] 530 531 532(* LeadDegree[u] returns the degree of the leading factor of u. *) 533LeadDegree[u_] := 534 Module[{v=LeadFactor[u]}, 535 If[PowerQ[v], 536 v[[2]], 537 1]] 538 539 540(* If v^n is a factor of u, FindFactor[u,v] returns the list {n,u/v^n}; else it returns False. *) 541(* FindFactor[u_,v_] := 542 If[u===1, 543 False, 544 If[LeadBase[u]===v, 545 {LeadDegree[u], RemainingFactors[u]}, 546 Module[{lst=FindFactor[RemainingFactors[u],v]}, 547 If[FalseQ[lst], 548 False, 549 {lst[[1]], LeadFactor[u]*lst[[2]]}]]]] *) 550 551 552(* LT[u,v] returns True if u and v are real-valued numeric quantities and u<v, else returns False *) 553LT[u_,v_] := 554 RealNumericQ[u] && RealNumericQ[v] && Re[N[u]]<Re[N[v]] 555 556LT[u_,v_,w_] := 557 LT[u,v] && LT[v,w] 558 559 560(* LE[u,v] returns True if u and v are real-valued numeric quantities and u<=v, else returns False *) 561LE[u_,v_] := 562 RealNumericQ[u] && RealNumericQ[v] && Re[N[u]]<=Re[N[v]] 563 564LE[u_,v_,w_] := 565 LE[u,v] && LE[v,w] 566 567 568(* GT[u,v] returns True if u and v are real-valued numeric quantities and u>v, else returns False *) 569GT[u_,v_] := 570 RealNumericQ[u] && RealNumericQ[v] && Re[N[u]]>Re[N[v]] 571 572GT[u_,v_,w_] := 573 GT[u,v] && GT[v,w] 574 575 576(* GE[u,v] returns True if u and v are real-valued numeric quantities and u>=v, else returns False *) 577GE[u_,v_] := 578 RealNumericQ[u] && RealNumericQ[v] && Re[N[u]]>=Re[N[v]] 579 580GE[u_,v_,w_] := 581 GE[u,v] && GE[v,w] 582 583 584IndependentQ[u_,x_Symbol] := 585 FreeQ[u,x] 586 587 588(* SplitFreeFactors[u,x] returns the list {v,w} where v is the product of the factors of u free of x 589 and w is the product of the other factors. *) 590(* Compare with the more active function ConstantFactor. *) 591SplitFreeFactors[u_,x_Symbol] := 592 If[ProductQ[u], 593 Map[Function[If[FreeQ[#,x],{#,1},{1,#}]],u], 594 If[FreeQ[u,x], 595 {u,1}, 596 {1,u}]] 597 598 599(* SplitFreeTerms[u,x] returns the list {v,w} where v is the sum of the terms of u free of x 600 and w is the sum of the other terms. *) 601SplitFreeTerms[u_,x_Symbol] := 602 If[SumQ[u], 603 Map[Function[SplitFreeTerms[#,x]],u], 604 If[FreeQ[u,x], 605 {u,0}, 606 {0,u}]] 607 608 609(* If u (x) is a sum of the form a+b*v+c*w+..., SplitFactorsOfTerms[u,x] returns the list 610 {{1,a},{b,v},{c,w},...}, where v, w, ... are regularized wrt x. *) 611SplitFactorsOfTerms[u_,x_Symbol] := 612 Module[{lst=SplitFreeTerms[u,x],v,w}, 613 v=lst[[1]]; 614 w=lst[[2]]; 615 ( If[ZeroQ[w], 616 lst={}, 617 If[SumQ[w], 618 lst=Map[Function[SplitFreeFactors[#,x]],Apply[List,w]]; 619 lst=Map[Function[Prepend[SplitFreeFactors[Regularize[#[[2]],x],x],#[[1]]]],lst]; 620 lst=Map[Function[{#[[1]]*#[[2]],#[[3]]}],lst], 621 lst=SplitFreeFactors[w,x]; 622 lst=Prepend[SplitFreeFactors[Regularize[lst[[2]],x],x],lst[[1]]]; 623 lst={{lst[[1]]*lst[[2]],lst[[3]]}}]] ); 624 If[ZeroQ[v], 625 lst, 626 Prepend[lst,{1,v}]]] 627 628 629LinearQ[u_,x_Symbol,flag_:False] := 630 If[ListQ[u], 631 Catch[Scan[Function[If[LinearQ[#,x,flag],Null,Throw[False]]],u]; True], 632 If[flag, 633 MatchQ[u, a_.+b_.*x /; FreeQ[{a,b},x]], 634 PolynomialQ[u,x] && Exponent[u,x]==1]] 635 636 637QuadraticQ[u_,x_Symbol,flag_:False] := 638 If[ListQ[u], 639 Catch[Scan[Function[If[QuadraticQ[#,x,flag],Null,Throw[False]]],u]; True], 640 If[flag, 641 MatchQ[u, a_.+b_.*x+c_.*x^2 /; FreeQ[{a,b,c},x]] || MatchQ[u, a_.+c_.*x^2 /; FreeQ[{a,c},x]], 642 PolynomialQ[u,x] && Exponent[u,x]==2]] 643 644 645BinomialQ[u_,x_Symbol,flag_:False] := 646 If[ListQ[u], 647 Catch[Scan[Function[If[BinomialQ[#,x,flag],Null,Throw[False]]],u]; True], 648 If[flag===False, 649 NotFalseQ[BinomialTest[u,x]], 650 If[flag===True, 651 MatchQ[u, a_.+b_.*x^n_. /; FreeQ[{a,b,n},x]], 652 Function[NotFalseQ[#] && #[[3]]===flag][BinomialTest[u,x]]]]] 653 654 655GeneralizedBinomialQ[u_,x_Symbol,flag_:False] := 656 If[ListQ[u], 657 Catch[Scan[Function[If[GeneralizedBinomialQ[#,x,flag],Null,Throw[False]]],u]; True], 658 If[flag, 659 MatchQ[u, a_.*x^q_.+b_.*x^n_. /; FreeQ[{a,b,n,q},x]], 660 NotFalseQ[GeneralizedBinomialTest[u,x]]]] 661 662 663TrinomialQ[u_,x_Symbol,flag_:False] := 664 If[ListQ[u], 665 Catch[Scan[Function[If[TrinomialQ[#,x,flag],Null,Throw[False]]],u]; True], 666 If[flag, 667 MatchQ[u, a_.+b_.*x^n_.+c_.*x^j_. /; FreeQ[{a,b,c,n},x] && ZeroQ[j-2*n]], 668 NotFalseQ[TrinomialTest[u,x]] && Not[QuadraticQ[u,x]] && Not[MatchQ[u,w_^2 /; BinomialQ[w,x]]]]] 669 670 671GeneralizedTrinomialQ[u_,x_Symbol,flag_:False] := 672 If[ListQ[u], 673 Catch[Scan[Function[If[GeneralizedTrinomialQ[#,x,flag],Null,Throw[False]]],u]; True], 674 If[flag, 675 MatchQ[u, a_.*x^q_.+b_.*x^n_.+c_.*x^r_. /; FreeQ[{a,b,c,n,q},x] && ZeroQ[r-(2*n-q)]], 676 NotFalseQ[GeneralizedTrinomialTest[u,x]]]] 677 678 679(* If u is of the form a*x^n where n!=0 and a!=0, MonomialQ[u,x] returns True; else False. *) 680MonomialQ[u_,x_Symbol] := 681 If[ListQ[u], 682 Catch[Scan[Function[If[MonomialQ[#,x],Null,Throw[False]]],u]; True], 683 MatchQ[u, a_.*x^n_. /; FreeQ[{a,n},x]]] 684 685 686(* If u[x] is a sum and each term is free of x or an expression of the form a*x^n, 687 MonomialSumQ[u,x] returns True; else it returns False. *) 688MonomialSumQ[u_,x_Symbol] := 689 SumQ[u] && Catch[ 690 Scan[Function[If[FreeQ[#,x] || MonomialQ[#,x], Null, Throw[False]]],u]; 691 True] 692 693 694(* u is sum whose terms are monomials. MinimumExponent[u,x] returns the exponent of the term having the smallest exponent. *) 695MinimumMonomialExponent[u_,x_Symbol] := 696 Module[{n=MonomialExponent[First[u],x]}, 697 Scan[Function[If[PosQ[n-MonomialExponent[#,x]],n=MonomialExponent[#,x]]],u]; 698 n] 699 700 701(* u is a monomial. MonomialExponent[u,x] returns the exponent of x in u. *) 702MonomialExponent[a_.*x_^n_.,x_Symbol] := 703 n /; 704FreeQ[{a,n},x] 705 706 707(* If u (x) is an expression of the form a*x^n where n is zero or a positive integer, 708 PolynomialTermQ[u,x] returns True; else it returns False. *) 709PolynomialTermQ[u_,x_Symbol] := 710 FreeQ[u,x] || MatchQ[u,a_.*x^n_. /; FreeQ[a,x] && IntegerQ[n] && n>0] 711 712 713(* u (x) is a sum. PolynomialTerms[u,x] returns the sum of the polynomial terms of u (x). *) 714PolynomialTerms[u_,x_Symbol] := 715 Map[Function[If[PolynomialTermQ[#,x],#,0]],u] 716 717 718(* u (x) is a sum. NonpolynomialTerms[u,x] returns the sum of the nonpolynomial terms of u (x). *) 719NonpolynomialTerms[u_,x_Symbol] := 720 Map[Function[If[PolynomialTermQ[#,x],0,#]],u] 721 722 723(* u is a binomial. BinomialDegree[u,x] returns the degree of x in u. *) 724BinomialDegree[u_,x_Symbol] := 725 BinomialTest[u,x][[3]] 726 727 728(* If u[x] is equivalent to an expression of the form a+b*x^n where n!=0 and b!=0, 729 BinomialTest[u,x] returns the list {a,b,n}; else it returns False. *) 730BinomialTest[u_,x_Symbol] := 731 If[PowerQ[u], 732 If[ZeroQ[u[[1]]-x] && FreeQ[u[[2]],x], 733 {0,1,u[[2]]}, 734 False], 735 If[PolynomialQ[u,x], 736 Module[{lst=CoefficientList[u,x]}, 737 If[Length[lst]<2, 738 False, 739 Catch[ 740 Scan[Function[If[ZeroQ[#],Null,Throw[False]]],Drop[Drop[lst,1],-1]]; 741 {First[lst],Last[lst],Length[lst]-1}]]], 742 Module[{lst1,lst2}, 743 If[ProductQ[u], 744 If[FreeQ[First[u],x], 745 lst2=BinomialTest[Rest[u],x]; 746 If[FalseQ[lst2], 747 False, 748 {First[u]*lst2[[1]],First[u]*lst2[[2]],lst2[[3]]}], 749 If[FreeQ[Rest[u],x], 750 lst1=BinomialTest[First[u],x]; 751 If[FalseQ[lst1], 752 False, 753 {Rest[u]*lst1[[1]],Rest[u]*lst1[[2]],lst1[[3]]}], 754 lst1=BinomialTest[First[u],x]; 755 lst2=BinomialTest[Rest[u],x]; 756 If[FalseQ[lst1] || FalseQ[lst2], 757 False, 758 Module[{a,b,c,d,m,n}, 759 {a,b,m}=lst1; 760 {c,d,n}=lst2; 761 If[ZeroQ[a], 762 If[ZeroQ[c], 763 {0,b*d,m+n}, 764 If[ZeroQ[m+n], 765 {b*d,b*c,m}, 766 False]], 767 If[ZeroQ[c], 768 If[ZeroQ[m+n], 769 {b*d,a*d,n}, 770 False], 771 If[ZeroQ[m-n] && ZeroQ[a*d+b*c], 772 {a*c,b*d,2*m}, 773 False]]]]]]], 774 If[SumQ[u], 775 If[FreeQ[First[u],x], 776 lst2=BinomialTest[Rest[u],x]; 777 If[FalseQ[lst2], 778 False, 779 {First[u]+lst2[[1]],lst2[[2]],lst2[[3]]}], 780 If[FreeQ[Rest[u],x], 781 lst1=BinomialTest[First[u],x]; 782 If[FalseQ[lst1], 783 False, 784 {Rest[u]+lst1[[1]],lst1[[2]],lst1[[3]]}], 785 lst1=BinomialTest[First[u],x]; 786 lst2=BinomialTest[Rest[u],x]; 787 If[FalseQ[lst1] || FalseQ[lst2], 788 False, 789 If[ZeroQ[lst1[[3]]-lst2[[3]]], 790 {lst1[[1]]+lst2[[1]],lst1[[2]]+lst2[[2]],lst1[[3]]}, 791 False]]]], 792 False]]]]] 793 794 795(* If u is equivalent to a generalized binomial of the form a*x^q + b*x^n where a, b, n, and q not equal 0, 796 GeneralizedBinomialDegree[u,x] returns n-q. *) 797GeneralizedBinomialDegree[u_,x_Symbol] := 798 Function[#[[3]]-#[[4]]][GeneralizedBinomialTest[u,x]] 799 800 801(* If u is equivalent to a generalized binomial of the form a*x^q + b*x^n where a, b, n, and q not equal 0, 802 GeneralizedBinomialTest[u,x] returns the list {a,b,n,q}; else it returns False. *) 803GeneralizedBinomialTest[a_.*x_^q_.+b_.*x_^n_.,x_Symbol] := 804 {a,b,n,q} /; 805FreeQ[{a,b,n,q},x] && PosQ[n-q] 806 807GeneralizedBinomialTest[a_*u_,x_Symbol] := 808 Module[{lst=GeneralizedBinomialTest[u,x]}, 809 {a*lst[[1]], a*lst[[2]], lst[[3]], lst[[4]]} /; 810 NotFalseQ[lst]] /; 811FreeQ[a,x] 812 813GeneralizedBinomialTest[x_^m_.*u_,x_Symbol] := 814 Module[{lst=GeneralizedBinomialTest[u,x]}, 815 {lst[[1]], lst[[2]], m+lst[[3]], m+lst[[4]]} /; 816 NotFalseQ[lst] && NonzeroQ[m+lst[[3]]] && NonzeroQ[m+lst[[4]]]] /; 817FreeQ[m,x] 818 819GeneralizedBinomialTest[x_^m_.*u_,x_Symbol] := 820 Module[{lst=BinomialTest[u,x]}, 821 {lst[[1]], lst[[2]], m+lst[[3]], m} /; 822 NotFalseQ[lst] && NonzeroQ[m+lst[[3]]]] /; 823FreeQ[m,x] 824 825GeneralizedBinomialTest[u_,x_Symbol] := 826 False 827 828 829(* If u is equivalent to a trinomial of the form a + b*x^n + c*x^(2*n) where n!=0, b!=0 and c!=0, 830 TrinomialDegree[u,x] returns n. *) 831TrinomialDegree[u_,x_Symbol] := 832 TrinomialTest[u,x][[4]] 833 834 835(* If u is equivalent to a trinomial of the form a + b*x^n + c*x^(2*n) where n!=0, b!=0 and c!=0, 836 TrinomialTest[u,x] returns the list {a,b,c,n}; else it returns False. *) 837TrinomialTest[u_,x_Symbol] := 838 If[PolynomialQ[u,x], 839 Module[{lst=CoefficientList[u,x]}, 840 If[Length[lst]<3 || EvenQ[Length[lst]] || ZeroQ[lst[[(Length[lst]+1)/2]]], 841 False, 842 Catch[ 843 Scan[Function[If[ZeroQ[#],Null,Throw[False]]],Drop[Drop[Drop[lst,{(Length[lst]+1)/2}],1],-1]]; 844 {First[lst],lst[[(Length[lst]+1)/2]],Last[lst],(Length[lst]-1)/2}]]], 845 If[PowerQ[u], 846 If[ZeroQ[u[[2]]-2], 847 Module[{lst=BinomialTest[u[[1]],x]}, 848 If[FalseQ[lst], 849 False, 850 {lst[[1]]^2,2*lst[[1]]*lst[[2]],lst[[2]]^2,lst[[3]]}]], 851 False], 852 Module[{lst1,lst2}, 853 If[ProductQ[u], 854 If[FreeQ[First[u],x], 855 lst2=TrinomialTest[Rest[u],x]; 856 If[FalseQ[lst2], 857 False, 858 {First[u]*lst2[[1]],First[u]*lst2[[2]],First[u]*lst2[[3]],lst2[[4]]}], 859 If[FreeQ[Rest[u],x], 860 lst1=TrinomialTest[First[u],x]; 861 If[FalseQ[lst1], 862 False, 863 {Rest[u]*lst1[[1]],Rest[u]*lst1[[2]],Rest[u]*lst1[[3]],lst1[[4]]}], 864 lst1=BinomialTest[First[u],x]; 865 lst2=BinomialTest[Rest[u],x]; 866 If[FalseQ[lst1] || FalseQ[lst2], 867 False, 868 Module[{a,b,c,d,m,n}, 869 {a,b,m}=lst1; 870 {c,d,n}=lst2; 871 If[ZeroQ[m-n] && NonzeroQ[a*d+b*c], 872 {a*c,a*d+b*c,b*d,m}, 873 False]]]]], 874 If[SumQ[u], 875 If[FreeQ[First[u],x], 876 lst2=TrinomialTest[Rest[u],x]; 877 If[FalseQ[lst2], 878 False, 879 {First[u]+lst2[[1]],lst2[[2]],lst2[[3]],lst2[[4]]}], 880 If[FreeQ[Rest[u],x], 881 lst1=TrinomialTest[First[u],x]; 882 If[FalseQ[lst1], 883 False, 884 {Rest[u]+lst1[[1]],lst1[[2]],lst1[[3]],lst1[[4]]}], 885 lst1=TrinomialTest[First[u],x]; 886 If[FalseQ[lst1], 887 lst1=BinomialTest[First[u],x]; 888 If[FalseQ[lst1], 889 False, 890 lst2=TrinomialTest[Rest[u],x]; 891 If[FalseQ[lst2], 892 lst2=BinomialTest[Rest[u],x]; 893 If[FalseQ[lst2], 894 False, 895 If[ZeroQ[lst1[[3]]-2*lst2[[3]]], 896 {lst1[[1]]+lst2[[1]],lst2[[2]],lst1[[2]],lst2[[3]]}, 897 If[ZeroQ[lst2[[3]]-2*lst1[[3]]], 898 {lst1[[1]]+lst2[[1]],lst1[[2]],lst2[[2]],lst1[[3]]}, 899 False]]], 900 If[ZeroQ[lst1[[3]]-lst2[[4]]] && NonzeroQ[lst1[[2]]+lst2[[2]]], 901 {lst1[[1]]+lst2[[1]],lst1[[2]]+lst2[[2]],lst2[[3]],lst2[[4]]}, 902 If[ZeroQ[lst1[[3]]-2*lst2[[4]]] && NonzeroQ[lst1[[2]]+lst2[[3]]], 903 {lst1[[1]]+lst2[[1]],lst2[[2]],lst1[[2]]+lst2[[3]],lst2[[4]]}, 904 False]]]], 905 lst2=TrinomialTest[Rest[u],x]; 906 If[FalseQ[lst2], 907 lst2=BinomialTest[Rest[u],x]; 908 If[FalseQ[lst2], 909 False, 910 If[ZeroQ[lst2[[3]]-lst1[[4]]] && NonzeroQ[lst1[[2]]+lst2[[2]]], 911 {lst1[[1]]+lst2[[1]],lst1[[2]]+lst2[[2]],lst1[[3]],lst1[[4]]}, 912 If[ZeroQ[lst2[[3]]-2*lst1[[4]]] && NonzeroQ[lst1[[3]]+lst2[[2]]], 913 {lst1[[1]]+lst2[[1]],lst1[[2]],lst1[[3]]+lst2[[2]],lst1[[4]]}, 914 False]]], 915 If[ZeroQ[lst1[[4]]-lst2[[4]]] && NonzeroQ[lst1[[2]]+lst2[[2]]] && NonzeroQ[lst1[[3]]+lst2[[3]]], 916 {lst1[[1]]+lst2[[1]],lst1[[2]]+lst2[[2]],lst1[[3]]+lst2[[3]],lst1[[4]]}, 917 False]]]]], 918 False]]]]] 919 920 921(* If u is equivalent to a generalized trinomial of the form a*x^q + b*x^n + c*x^(2*n-q) where n!=0, q!=0, b!=0 and c!=0, 922 GeneralizedTrinomialDegree[u,x] returns n-q. *) 923GeneralizedTrinomialDegree[u_,x_Symbol] := 924 Function[#[[4]]-#[[5]]][GeneralizedTrinomialTest[u,x]] 925 926 927(* If u is equivalent to a generalized trinomial of the form a*x^q + b*x^n + c*x^(2*n-q) where n!=0, q!=0, b!=0 and c!=0, 928 GeneralizedTrinomialTest[u,x] returns the list {a,b,c,n,q}; else it returns False. *) 929GeneralizedTrinomialTest[a_.*x_^q_.+b_.*x_^n_.+c_.*x_^r_.,x_Symbol] := 930 {a,b,c,n,q} /; 931FreeQ[{a,b,c,n,q},x] && ZeroQ[r-(2*n-q)] 932 933GeneralizedTrinomialTest[a_*u_,x_Symbol] := 934 Module[{lst=GeneralizedTrinomialTest[u,x]}, 935 {a*lst[[1]], a*lst[[2]], a*lst[[3]], lst[[4]], lst[[5]]} /; 936 NotFalseQ[lst]] /; 937FreeQ[a,x] 938 939GeneralizedTrinomialTest[x_^m_.*u_,x_Symbol] := 940 Module[{lst=GeneralizedTrinomialTest[u,x]}, 941 {lst[[1]], lst[[2]], lst[[3]], m+lst[[4]], m+lst[[5]]} /; 942 NotFalseQ[lst] && NonzeroQ[m+lst[[4]]] && NonzeroQ[m+lst[[5]]]] /; 943FreeQ[m,x] 944 945GeneralizedTrinomialTest[x_^m_.*u_,x_Symbol] := 946 Module[{lst=TrinomialTest[u,x]}, 947 {lst[[1]], lst[[2]], lst[[3]], m+lst[[4]], m} /; 948 NotFalseQ[lst] && NonzeroQ[m+lst[[4]]]] /; 949FreeQ[m,x] 950 951GeneralizedTrinomialTest[u_,x_Symbol] := 952 False 953 954 955(* If u (x) is equivalent to a polynomial raised to an integer power greater than 1, 956 PerfectPowerTest[u,x] returns u (x) as an expanded polynomial raised to the power; 957 else it returns False. *) 958PerfectPowerTest[u_,x_Symbol] := 959 If[PolynomialQ[u,x], 960 Module[{lst=FactorSquareFreeList[u],gcd=0,v=1}, 961 If[lst[[1]]==={1,1}, 962 lst=Rest[lst]]; 963 Scan[Function[gcd=GCD[gcd,#[[2]]]],lst]; 964 If[gcd>1, 965 Scan[Function[v=v*#[[1]]^(#[[2]]/gcd)],lst]; 966 Expand[v]^gcd, 967 False]], 968 False] 969 970 971(* If u (x) can be square free factored, SquareFreeFactorTest[u,x] returns u (x) in 972 factored form; else it returns False. *) 973(* SquareFreeFactorTest[u_,x_Symbol] := 974 If[PolynomialQ[u,x], 975 Module[{v=FactorSquareFree[u]}, 976 If[PowerQ[v] || ProductQ[v], 977 v, 978 False]], 979 False] *) 980 981 982(* If u is a polynomial or rational function of x, RationalFunctionQ[u,x] returns True; 983 else it returns False. *) 984RationalFunctionQ[u_,x_Symbol] := 985 If[AtomQ[u], 986 True, 987 If[IntegerPowerQ[u], 988 RationalFunctionQ[u[[1]],x], 989 If[ProductQ[u] || SumQ[u], 990 Catch[Scan[Function[If[RationalFunctionQ[#,x],Null,Throw[False]]],u];True], 991 If[FreeQ[u,x], 992 True, 993 False]]]] 994 995 996(* If u is a rational function of x, RationalFunctionExponents[u,x] returns a list of the 997 exponent of the numerator of u and the exponent of the denominator of u. *) 998RationalFunctionExponents[u_,x_Symbol] := 999 If[PolynomialQ[u,x], 1000 {Exponent[u,x],0}, 1001 If[IntegerPowerQ[u], 1002 If[u[[2]]>0, 1003 u[[2]]*RationalFunctionExponents[u[[1]],x], 1004 (-u[[2]])*Reverse[RationalFunctionExponents[u[[1]],x]]], 1005 If[ProductQ[u], 1006 RationalFunctionExponents[First[u],x]+RationalFunctionExponents[Rest[u],x], 1007 If[SumQ[u], 1008 Module[{v=Together[u]}, 1009 If[SumQ[v], 1010 Module[{lst1,lst2}, 1011 lst1=RationalFunctionExponents[First[u],x]; 1012 lst2=RationalFunctionExponents[Rest[u],x]; 1013 {Max[lst1[[1]]+lst2[[2]],lst2[[1]]+lst1[[2]]],lst1[[2]]+lst2[[2]]}], 1014 RationalFunctionExponents[v,x]]], 1015 {0,0}]]]] 1016 1017 1018(* If u (x) is an algebraic function of x, AlgebraicFunctionQ[u,x] returns True; else False. *) 1019AlgebraicFunctionQ[u_,x_Symbol] := 1020 If[AtomQ[u] || FreeQ[u,x], 1021 True, 1022 If[RationalPowerQ[u], 1023 AlgebraicFunctionQ[u[[1]],x], 1024 If[ProductQ[u] || SumQ[u], 1025 Catch[Scan[Function[If[AlgebraicFunctionQ[#,x],Null,Throw[False]]],u];True], 1026 False]]] 1027 1028 1029QuotientOfLinearsQ[u_,x_Symbol,flag_:False] := 1030 If[ListQ[u], 1031 Catch[Scan[Function[If[QuotientOfLinearsQ[#,x,flag],Null,Throw[False]]],u]; True], 1032 If[flag, 1033 MatchQ[u, (a_.+b_.*x)/(c_.+d_.*x) /; FreeQ[{a,b,c,d},x]], 1034 QuotientOfLinearsP[u,x] && Function[NonzeroQ[#[[2]]] && NonzeroQ[#[[4]]]][QuotientOfLinearsParts[u,x]]]] 1035 1036 1037QuotientOfLinearsP[a_*u_,x_] := 1038 QuotientOfLinearsP[u,x] /; 1039FreeQ[a,x] 1040 1041QuotientOfLinearsP[a_+u_,x_] := 1042 QuotientOfLinearsP[u,x] /; 1043FreeQ[a,x] 1044 1045QuotientOfLinearsP[1/u_,x_] := 1046 QuotientOfLinearsP[u,x] 1047 1048QuotientOfLinearsP[u_,x_] := 1049 True /; 1050LinearQ[u,x] 1051 1052QuotientOfLinearsP[u_/v_,x_] := 1053 True /; 1054LinearQ[u,x] && LinearQ[v,x] 1055 1056QuotientOfLinearsP[u_,x_] := 1057 u===x || FreeQ[u,x] 1058 1059 1060(* If u is equivalent to an expression of the form (a+b*x)/(c+d*x), QuotientOfLinearsParts[u,x] 1061 returns the list {a, b, c, d}. *) 1062QuotientOfLinearsParts[a_*u_,x_] := 1063 Apply[Function[{a*#1, a*#2, #3, #4}], QuotientOfLinearsParts[u,x]] /; 1064FreeQ[a,x] 1065 1066QuotientOfLinearsParts[a_+u_,x_] := 1067 Apply[Function[{#1+a*#3, #2+a*#4, #3, #4}], QuotientOfLinearsParts[u,x]] /; 1068FreeQ[a,x] 1069 1070QuotientOfLinearsParts[1/u_,x_] := 1071 Apply[Function[{#3, #4, #1, #2}], QuotientOfLinearsParts[u,x]] 1072 1073QuotientOfLinearsParts[u_,x_] := 1074 {Coefficient[u,x,0], Coefficient[u,x,1], 1, 0} /; 1075LinearQ[u,x] 1076 1077QuotientOfLinearsParts[u_/v_,x_] := 1078 {Coefficient[u,x,0], Coefficient[u,x,1], Coefficient[v,x,0], Coefficient[v,x,1]} /; 1079LinearQ[u,x] && LinearQ[v,x] 1080 1081QuotientOfLinearsParts[u_,x_] := 1082 If[u===x, 1083 {0, 1, 1, 0}, 1084 If[FreeQ[u,x], 1085 {u, 0, 1, 0}, 1086 Print["QuotientOfLinearParts error!"]; 1087 {u, 0, 1, 0}]] 1088 1089 1090(* u (x) is an improper fraction if it is an expression of the form w (v (x))/t(v (x)) where w (x) 1091 and t (x) are polynomials in x and the degree of w (x) is greater than or equal the degree 1092 of t (x). *) 1093 1094 1095(* If u/v is an improper fraction, ImproperFractionQ[u,v,x] returns True; else it returns False. *) 1096(* ImproperFractionQ[u_,v_,x_Symbol] := 1097 Module[{lst1=PolynomialFunctionOf[u,x],lst2=PolynomialFunctionOf[v,x]}, 1098 lst1[[1]]===lst2[[1]] && Exponent[lst1[[2]],x]>=Exponent[lst2[[2]],x]] *) 1099 1100 1101(* If u/v is an improper rational function where v is of the form fraction a+b*x+c*x^2 or a+b*x^n, 1102 ImproperRationalFunctionQ[u,v,x] returns True; else it returns False. *) 1103ImproperRationalFunctionQ[u_,v_,x_Symbol] := 1104 PolynomialQ[u,x] && 1105 PolynomialQ[v,x] && 1106 Not[MatchQ[u,(a_.+b_.*x)^n_. /; FreeQ[{a,b},x] && IntegerQ[n]] && 1107 MatchQ[v,(a_.+b_.*x)^n_. /; FreeQ[{a,b},x] && IntegerQ[n]]] && 1108 (QuadraticQ[v,x] && Exponent[u,x]>=2 || 1109 MatchQ[v,a_+b_.*x^n_. /; FreeQ[{a,b},x] && IntegerQ[n] && 0<n<=Exponent[u,x]]) 1110 1111 1112(* If u is an improper fraction, ExpandImproperFraction[u,x] returns the list {q,a,r} 1113 where q is the integral part of u and a*r is the proper fractional part of u; 1114 else it returns False. *) 1115ExpandImproperFraction[u_,x_Symbol] := 1116 Module[{tmp}, 1117 If[NotFalseQ[tmp=ExpandImproperFraction[Numerator[u],Denominator[u],x]], 1118 tmp, 1119 If[NotFalseQ[tmp=ExpandImproperFraction[SmartNumerator[u],SmartDenominator[u],x]], 1120 tmp, 1121 If[FunctionOfQ[Sin[x],u,x], 1122 tmp=Regularize[SubstFor[Sin[x],u,x],x]; 1123 If[NotFalseQ[tmp=ExpandImproperFraction[Numerator[tmp],Denominator[tmp],x]], 1124 Subst[tmp,x,Sin[x]], 1125 False], 1126 If[FunctionOfQ[Cos[x],u,x], 1127 tmp=Regularize[SubstFor[Cos[x],u,x],x]; 1128 If[NotFalseQ[tmp=ExpandImproperFraction[Numerator[tmp],Denominator[tmp],x]], 1129 Subst[tmp,x,Cos[x]], 1130 False], 1131 If[FunctionOfQ[Sinh[x],u,x], 1132 tmp=Regularize[SubstFor[Sinh[x],u,x],x]; 1133 If[NotFalseQ[tmp=ExpandImproperFraction[Numerator[tmp],Denominator[tmp],x]], 1134 Subst[tmp,x,Sinh[x]], 1135 False], 1136 If[FunctionOfQ[Cosh[x],u,x], 1137 tmp=Regularize[SubstFor[Cosh[x],u,x],x]; 1138 If[NotFalseQ[tmp=ExpandImproperFraction[Numerator[tmp],Denominator[tmp],x]], 1139 Subst[tmp,x,Cosh[x]], 1140 False], 1141 False]]]]]]] 1142 1143ExpandImproperFraction[u_,v_,x_Symbol] := 1144 Module[{lst1,lst2}, 1145 lst1=PolynomialFunctionOf[u,x]; 1146 lst2=PolynomialFunctionOf[v,x]; 1147 If[lst1[[1]]===lst2[[1]] && Exponent[lst1[[2]],x]>=Exponent[lst2[[2]],x], 1148 ReplaceAll[PolynomialDivide[lst1[[2]],lst2[[2]],x],x->lst1[[1]]], 1149 False]] 1150 1151 1152(* PolynomialDivide[u,v,x] returns the list {q,a,r} where q is the integral part of u/v and 1153 a*r is the proper fractional part of u/v; else it returns False. *) 1154PolynomialDivide[u_,v_,x_Symbol] := 1155 Prepend[SplitFreeFactors[Regularize[PolynomialRemainder[u,v,x]/v,x],x], 1156 PolynomialQuotient[u,v,x]] 1157 1158 1159SmartNumerator[u_] := 1160 If[MemberQ[{Cot,Sec,Csc,Coth,Sech,Csch},Head[u]], 1161 1, 1162 If[PowerQ[u] && IntegerQ[u[[2]]] && MemberQ[{Cot,Sec,Csc,Coth,Sech,Csch},Head[u[[1]]]], 1163 1, 1164 If[PowerQ[u] && RationalQ[u[[2]]] && u[[2]]<0, 1165 1, 1166 If[ProductQ[u], 1167 Map[SmartNumerator,u], 1168 u]]]] 1169 1170 1171SmartDenominator[u_] := 1172 If[MemberQ[{Cot,Sec,Csc,Coth,Sech,Csch},Head[u]], 1173 1/u, 1174 If[PowerQ[u] && IntegerQ[u[[2]]] && MemberQ[{Cot,Sec,Csc,Coth,Sech,Csch},Head[u[[1]]]], 1175 1/u, 1176 If[PowerQ[u] && RationalQ[u[[2]]] && u[[2]]<0, 1177 1/u, 1178 If[ProductQ[u], 1179 Map[SmartDenominator,u], 1180 1]]]] 1181 1182 1183(* PolynomialFunctionOf[u,x] returns the list {v (x),w (x)} where w (v (x)) equals u (x), w (x) is 1184 a polynomial in x, and v (x) is minimal *) 1185PolynomialFunctionOf[u_,x_Symbol] := 1186 If[AtomQ[u], 1187 If[u===x, 1188 {x,x}, 1189 {1,u}], 1190 If[PositiveIntegerPowerQ[u], 1191 Module[{lst=PolynomialFunctionOf[u[[1]],x]}, 1192 {lst[[1]],lst[[2]]^u[[2]]}], 1193 If[ProductQ[u], 1194 Module[{lst1=PolynomialFunctionOf[First[u],x],lst2=PolynomialFunctionOf[Rest[u],x]}, 1195 If[lst1[[1]]===1, 1196 {lst2[[1]],lst1[[2]]*lst2[[2]]}, 1197 If[lst2[[1]]===1, 1198 {lst1[[1]],lst1[[2]]*lst2[[2]]}, 1199 If[lst1[[1]]===lst2[[1]], 1200 {lst1[[1]],lst1[[2]]*lst2[[2]]}, 1201 {u,x}]]]], 1202 If[SumQ[u], 1203 Module[{lst1=PolynomialFunctionOf[First[u],x],lst2=PolynomialFunctionOf[Rest[u],x]}, 1204 If[lst1[[1]]===1, 1205 {lst2[[1]],lst1[[2]]+lst2[[2]]}, 1206 If[lst2[[1]]===1, 1207 {lst1[[1]],lst1[[2]]+lst2[[2]]}, 1208 If[lst1[[1]]===lst2[[1]], 1209 {lst1[[1]],lst1[[2]]+lst2[[2]]}, 1210 {u,x}]]]], 1211 If[FreeQ[u,x], 1212 {1,u}, 1213 {u,x}]]]]] 1214 1215 1216Gcd[m_,n_] := 1217 Module[{denr=LCM[Denominator[m],Denominator[n]]}, 1218 Sign[n]*GCD[m*denr,n*denr]/denr] /; 1219RationalQ[m,n] 1220 1221 1222(* If lst is a list of n terms, CommonNumericFactors[lst] returns a n+1-element list whose first 1223 element is the product of the numeric factors common to all terms of lst, and whose remaining 1224 elements are quotients of each term divided by the numeric common factor. *) 1225CommonNumericFactors [lst_] := 1226 Module[{num=Apply[GCD,Map[NumericFactor,lst]]}, 1227 Prepend[Map[Function[#/num],lst],num]] 1228 1229 1230(* NumericFactor[u] returns the product of the factors of u that are rational numbers. *) 1231NumericFactor[u_] := 1232 If[NumberQ[u], 1233 If[ZeroQ[Im[u]], 1234 u, 1235 If[ZeroQ[Re[u]], 1236 Im[u], 1237 1]], 1238 If[PowerQ[u], 1239 If[RationalQ[u[[1]]] && FractionQ[u[[2]]], 1240 If[u[[2]]>0, 1241 1/Denominator[u[[1]]], 1242 1/Denominator[1/u[[1]]]], 1243 1], 1244 If[ProductQ[u], 1245 Map[NumericFactor,u], 1246 If[SumQ[u], 1247 Function[If[SumQ[#], 1, NumericFactor[#]]][ContentFactor[u]], 1248 1]]]] 1249 1250 1251(* NonnumericFactors[u] returns the product of the factors of u that are not rational numbers. *) 1252NonnumericFactors[u_] := 1253 If[NumberQ[u], 1254 If[ZeroQ[Im[u]], 1255 1, 1256 If[ZeroQ[Re[u]], 1257 I, 1258 u]], 1259 If[PowerQ[u], 1260 If[RationalQ[u[[1]]] && FractionQ[u[[2]]], 1261 u/NumericFactor[u], 1262 u], 1263 If[ProductQ[u], 1264 Map[NonnumericFactors,u], 1265 If[SumQ[u], 1266 Function[If[SumQ[#], u, NonnumericFactors[#]]][ContentFactor[u]], 1267 u]]]] 1268 1269 1270(* AbsurdNumberQ[u] returns True if u is an absurd number, else it returns False. *) 1271AbsurdNumberQ[u_] := 1272 RationalQ[u] 1273 1274AbsurdNumberQ[u_^v_] := 1275 RationalQ[u] && u>0 && FractionQ[v] 1276 1277AbsurdNumberQ[u_*v_] := 1278 AbsurdNumberQ[u] && AbsurdNumberQ[v] 1279 1280 1281(* AbsurdNumberFactors[u] returns the product of the factors of u that are absurd numbers. *) 1282AbsurdNumberFactors[u_] := 1283 If[AbsurdNumberQ[u], 1284 u, 1285 If[ProductQ[u], 1286 Map[AbsurdNumberFactors,u], 1287 NumericFactor[u]]] 1288 1289 1290(* NonabsurdNumberFactors[u] returns the product of the factors of u that are not absurd numbers. *) 1291NonabsurdNumberFactors[u_] := 1292 If[AbsurdNumberQ[u], 1293 1, 1294 If[ProductQ[u], 1295 Map[NonabsurdNumberFactors,u], 1296 NonnumericFactors[u]]] 1297 1298 1299(* m must be an absurd number. FactorAbsurdNumber[m] returns the prime factorization of m *) 1300(* as list of base-degree pairs where the bases are prime numbers and the degrees are rational. *) 1301FactorAbsurdNumber[m_] := 1302 If[RationalQ[m], 1303 FactorInteger[m], 1304 If[PowerQ[m], 1305 Map[Function[{#[[1]], #[[2]]*m[[2]]}],FactorInteger[m[[1]]]], 1306 CombineExponents[Sort[Flatten[Map[FactorAbsurdNumber,Apply[List,m]],1], Function[#1[[1]]<#2[[1]]]]]]] 1307 1308 1309CombineExponents[lst_] := 1310 If[Length[lst]<2, 1311 lst, 1312 If[lst[[1,1]]==lst[[2,1]], 1313 CombineExponents[Prepend[Drop[lst,2],{lst[[1,1]],lst[[1,2]]+lst[[2,2]]}]], 1314 Prepend[CombineExponents[Rest[lst]],First[lst]]]] 1315 1316 1317(* m, n, ... must be absurd numbers. AbsurdNumberGCD[m,n,...] returns the gcd of m, n, ... *) 1318AbsurdNumberGCD[seq__] := 1319 Module[{lst={seq}}, 1320 If[Length[lst]==1, 1321 First[lst], 1322 AbsurdNumberGCDList[FactorAbsurdNumber[First[lst]],FactorAbsurdNumber[Apply[AbsurdNumberGCD,Rest[lst]]]]]] 1323 1324 1325(* lst1 and lst2 must be absurd number prime factorization lists. *) 1326(* AbsurdNumberGCDList[lst1,lst2] returns the gcd of the absurd numbers represented by lst1 and lst2. *) 1327AbsurdNumberGCDList[lst1_,lst2_] := 1328 If[lst1==={}, 1329 Apply[Times,Map[Function[#[[1]]^Min[#[[2]],0]],lst2]], 1330 If[lst2==={}, 1331 Apply[Times,Map[Function[#[[1]]^Min[#[[2]],0]],lst1]], 1332 If[lst1[[1,1]]==lst2[[1,1]], 1333 If[lst1[[1,2]]<=lst2[[1,2]], 1334 lst1[[1,1]]^lst1[[1,2]]*AbsurdNumberGCDList[Rest[lst1],Rest[lst2]], 1335 lst1[[1,1]]^lst2[[1,2]]*AbsurdNumberGCDList[Rest[lst1],Rest[lst2]]], 1336 If[lst1[[1,1]]<lst2[[1,1]], 1337 If[lst1[[1,2]]<0, 1338 lst1[[1,1]]^lst1[[1,2]]*AbsurdNumberGCDList[Rest[lst1],lst2], 1339 AbsurdNumberGCDList[Rest[lst1],lst2]], 1340 If[lst2[[1,2]]<0, 1341 lst2[[1,1]]^lst2[[1,2]]*AbsurdNumberGCDList[lst1,Rest[lst2]], 1342 AbsurdNumberGCDList[lst1,Rest[lst2]]]]]]] 1343 1344 1345DisguisedKnownIntegrandQ[Integrand_,x_Symbol] := 1346 KnownIntegrandQ[Integrand,x] && Not[KnownIntegrandQ[Integrand,x,True]] 1347 1348 1349KnownIntegrandQ[x_^m_.*u_,x_Symbol,flag_:False] := 1350 KnownIntegrandQ[u,x,flag] /; 1351FreeQ[m,x] 1352 1353 1354KnownIntegrandQ[u_+v_,x_Symbol,flag_:False] := 1355 KnownIntegrandQ[u,x,flag] && KnownIntegrandQ[v,x,flag] 1356 1357 1358KnownIntegrandQ[z_,x_Symbol,flag_:False] := 1359 MatchQ[z, u_^p_. /; FreeQ[p,x] && KnownMultinomialQ[u,x,flag]] || 1360 MatchQ[z, f_[u_]^p_. /; FreeQ[{f,p},x] && KnownMultinomialQ[u,x,flag]] || 1361 MatchQ[z, (f_^u_)^p_. /; FreeQ[{f,p},x] && KnownMultinomialQ[u,x,flag]] || 1362 1363 MatchQ[z, u_^p_.*v_^q_. /; FreeQ[{p,q},x] && QuadraticQ[v,x,flag] && (LinearQ[u,x,flag] || QuadraticQ[u,x,flag])] || 1364 MatchQ[z, u_^p_.*f_[v_]^q_. /; FreeQ[{f,p,q},x] && QuadraticQ[v,x,flag] && (LinearQ[u,x,flag] || QuadraticQ[u,x,flag])] || 1365 MatchQ[z, u_^p_.*(f_^v_)^q_. /; FreeQ[{f,p,q},x] && QuadraticQ[v,x,flag] && (LinearQ[u,x,flag] || QuadraticQ[u,x,flag])] || 1366 1367 MatchQ[z, u_^p_.*v_^q_. /; FreeQ[{p,q},x] && BinomialQ[{u,v},x,flag] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[v,x]]] || 1368 MatchQ[z, u_^p_.*f_[v_]^q_. /; FreeQ[{f,p,q},x] && BinomialQ[{u,v},x,flag] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[v,x]]] || 1369 MatchQ[z, u_^p_.*(f_^v_)^q_. /; FreeQ[{f,p,q},x] && BinomialQ[{u,v},x,flag] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[v,x]]] || 1370 1371 MatchQ[z, u_*v_^p_. /; FreeQ[p,x] && BinomialQ[u,x,flag] && TrinomialQ[v,x,flag] && ZeroQ[BinomialDegree[u,x]-TrinomialDegree[v,x]]] || 1372 MatchQ[z, u_*v_^p_. /; FreeQ[p,x] && BinomialQ[u,x,flag] && GeneralizedTrinomialQ[v,x,flag] && ZeroQ[BinomialDegree[u,x]-GeneralizedTrinomialDegree[v,x]]] || 1373 1374 MatchQ[z, u_^p_.*v_^q_.*w_^r_. /; FreeQ[{p,q,r},x] && BinomialQ[{u,v,w},x,flag] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[v,x]] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[w,x]]] || 1375 MatchQ[z, u_^p_.*v_^q_.*w_^r_. /; FreeQ[{p,q,r},x] && QuadraticQ[u,x,flag] && LinearQ[{v,w},x,flag] && (q===1 || r===1)] || 1376 MatchQ[z, u_^p_.*v_^q_.*w_^r_. /; FreeQ[{p,q,r},x] && p===1 && LinearQ[u,x,flag] && QuadraticQ[{v,w},x,flag]] || 1377 1378 MatchQ[z, u_^p_.*v_^q_.*w_^r_.*y_^s_. /; FreeQ[{p,q,r,s},x] && LinearQ[{u,v,w,y},x,flag]] || 1379 1380 MatchQ[z, Log[u_]/v_ /; QuotientOfLinearsQ[u,x,flag] && (LinearQ[v,x,flag] || QuadraticQ[v,x,flag])] || 1381 MatchQ[z, Log[c_.*u_^n_.]/v_ /; FreeQ[{c,n},x] && LinearQ[u,x,flag] && (LinearQ[v,x,flag] || QuadraticQ[v,x,flag])] || 1382 1383 FreeQ[z,x] 1384 1385 1386KnownMultinomialQ[u_,x_Symbol,flag_:False] := 1387 BinomialQ[u,x,flag] || QuadraticQ[u,x,flag] || TrinomialQ[u,x,flag] || 1388 GeneralizedBinomialQ[u,x,flag] || GeneralizedTrinomialQ[u,x,flag] 1389 1390 1391StandardizeIntegrand[x_^m_.*u_,x_Symbol] := 1392 x^m*StandardizeIntegrand[u,x] /; 1393FreeQ[m,x] 1394 1395 1396StandardizeIntegrand[u_+v_,x_Symbol] := 1397 StandardizeIntegrand[u,x] + StandardizeIntegrand[v,x] 1398 1399 1400StandardizeIntegrand[u_^p_.,x_Symbol] := 1401 Function[(#[[1]]+#[[2]]*x^#[[3]])^p][BinomialTest[u,x]] /; 1402FreeQ[p,x] && BinomialQ[u,x] 1403 1404StandardizeIntegrand[f_[u_^m_.]^p_.,x_Symbol] := 1405 Function[f[(#[[1]]+#[[2]]*x^#[[3]])^m]^p][BinomialTest[u,x]] /; 1406FreeQ[{f,m,p},x] && BinomialQ[u,x] 1407 1408StandardizeIntegrand[(f_^(u_^m_.))^p_.,x_Symbol] := 1409 Function[(f^((#[[1]]+#[[2]]*x^#[[3]])^m))^p][BinomialTest[u,x]] /; 1410FreeQ[{f,m,p},x] && BinomialQ[u,x] 1411 1412 1413StandardizeIntegrand[u_^p_.,x_Symbol] := 1414 (Coefficient[u,x,0]+Coefficient[u,x,1]*x+Coefficient[u,x,2]*x^2)^p /; 1415FreeQ[p,x] && QuadraticQ[u,x] 1416 1417StandardizeIntegrand[f_[u_]^p_.,x_Symbol] := 1418 f[Coefficient[u,x,0]+Coefficient[u,x,1]*x+Coefficient[u,x,2]*x^2]^p /; 1419FreeQ[{f,p},x] && QuadraticQ[u,x] 1420 1421StandardizeIntegrand[(f_^u_)^p_.,x_Symbol] := 1422 (f^(Coefficient[u,x,0]+Coefficient[u,x,1]*x+Coefficient[u,x,2]*x^2))^p /; 1423FreeQ[{f,p},x] && QuadraticQ[u,x] 1424 1425 1426StandardizeIntegrand[u_^p_.,x_Symbol] := 1427 Function[(#[[1]] + #[[2]]*x^#[[4]] + #[[3]]*x^(2*#[[4]]))^p][TrinomialTest[u,x]] /; 1428FreeQ[p,x] && TrinomialQ[u,x] 1429 1430StandardizeIntegrand[f_[u_]^p_.,x_Symbol] := 1431 Function[f[#[[1]] + #[[2]]*x^#[[4]] + #[[3]]*x^(2*#[[4]])]^p][TrinomialTest[u,x]] /; 1432FreeQ[{f,p},x] && TrinomialQ[u,x] 1433 1434StandardizeIntegrand[(f_^u_)^p_.,x_Symbol] := 1435 Function[(f^(#[[1]] + #[[2]]*x^#[[4]] + #[[3]]*x^(2*#[[4]])))^p][TrinomialTest[u,x]] /; 1436FreeQ[{f,p},x] && TrinomialQ[u,x] 1437 1438 1439StandardizeIntegrand[u_^p_.,x_Symbol] := 1440 Function[(#[[1]]*x^#[[4]]+#[[2]]*x^#[[3]])^p][GeneralizedBinomialTest[u,x]] /; 1441FreeQ[p,x] && GeneralizedBinomialQ[u,x] 1442 1443StandardizeIntegrand[f_[u_]^p_.,x_Symbol] := 1444 Function[f[#[[1]]*x^#[[4]]+#[[2]]*x^#[[3]]]^p][GeneralizedBinomialTest[u,x]] /; 1445FreeQ[{f,p},x] && GeneralizedBinomialQ[u,x] 1446 1447StandardizeIntegrand[(f_^u_)^p_.,x_Symbol] := 1448 Function[(f^(#[[1]]*x^#[[4]]+#[[2]]*x^#[[3]]))^p][GeneralizedBinomialTest[u,x]] /; 1449FreeQ[{f,p},x] && GeneralizedBinomialQ[u,x] 1450 1451 1452StandardizeIntegrand[u_^p_.,x_Symbol] := 1453 Function[(#[[1]]*x^#[[5]] + #[[2]]*x^#[[4]] + #[[3]]*x^(2*#[[4]]-#[[5]]))^p][GeneralizedTrinomialTest[u,x]] /; 1454FreeQ[p,x] && GeneralizedTrinomialQ[u,x] 1455 1456StandardizeIntegrand[f_[u_]^p_.,x_Symbol] := 1457 Function[f[#[[1]]*x^#[[5]] + #[[2]]*x^#[[4]] + #[[3]]*x^(2*#[[4]]-#[[5]])]^p][GeneralizedTrinomialTest[u,x]] /; 1458FreeQ[{f,p},x] && GeneralizedTrinomialQ[u,x] 1459 1460StandardizeIntegrand[(f_^u_)^p_.,x_Symbol] := 1461 Function[(f^(#[[1]]*x^#[[5]] + #[[2]]*x^#[[4]] + #[[3]]*x^(2*#[[4]]-#[[5]])))^p][GeneralizedTrinomialTest[u,x]] /; 1462FreeQ[{f,p},x] && GeneralizedTrinomialQ[u,x] 1463 1464 1465StandardizeIntegrand[u_^p_.*v_^q_.,x_Symbol] := 1466 Function[(#1[[1]]+#1[[2]]*x^#1[[3]])^p*(#2[[1]]+#2[[2]]*x^#1[[3]])^q][BinomialTest[u,x],BinomialTest[v,x]] /; 1467FreeQ[{p,q},x] && BinomialQ[{u,v},x] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[v,x]] 1468 1469StandardizeIntegrand[u_^p_.*f_[v_^m_.]^q_.,x_Symbol] := 1470 Function[(#1[[1]]+#1[[2]]*x^#1[[3]])^p*f[(#2[[1]]+#2[[2]]*x^#1[[3]])^m]^q][BinomialTest[u,x],BinomialTest[v,x]] /; 1471FreeQ[{f,m,p,q},x] && BinomialQ[{u,v},x] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[v,x]] 1472 1473StandardizeIntegrand[u_^p_.*(f_^(v_^m_.))^q_.,x_Symbol] := 1474 Function[(#1[[1]]+#1[[2]]*x^#1[[3]])^p*(f^((#2[[1]]+#2[[2]]*x^#1[[3]])^m))^q][BinomialTest[u,x],BinomialTest[v,x]] /; 1475FreeQ[{f,m,p,q},x] && BinomialQ[{u,v},x] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[v,x]] 1476 1477 1478StandardizeIntegrand[v_^m_.*w_^p_.,x_Symbol] := 1479 (Coefficient[v,x,0]+Coefficient[v,x,1]*x+Coefficient[v,x,2]*x^2)^m* 1480 (Coefficient[w,x,0]+Coefficient[w,x,1]*x+Coefficient[w,x,2]*x^2)^p /; 1481FreeQ[{m,p},x] && QuadraticQ[{v,w},x] 1482 1483StandardizeIntegrand[v_^m_.*f_[w_]^p_.,x_Symbol] := 1484 (Coefficient[v,x,0]+Coefficient[v,x,1]*x+Coefficient[v,x,2]*x^2)^m* 1485 f[Coefficient[w,x,0]+Coefficient[w,x,1]*x+Coefficient[w,x,2]*x^2]^p /; 1486FreeQ[{f,m,p},x] && QuadraticQ[{v,w},x] 1487 1488StandardizeIntegrand[v_^m_.*(f_^w_)^p_.,x_Symbol] := 1489 (Coefficient[v,x,0]+Coefficient[v,x,1]*x+Coefficient[v,x,2]*x^2)^m* 1490 (f^(Coefficient[w,x,0]+Coefficient[w,x,1]*x+Coefficient[w,x,2]*x^2))^p /; 1491FreeQ[{f,m,p},x] && QuadraticQ[{v,w},x] 1492 1493 1494StandardizeIntegrand[v_^m_.*u_^p_.,x_Symbol] := 1495 (Coefficient[v,x,0]+Coefficient[v,x,1]*x)^m* 1496 (Coefficient[u,x,0]+Coefficient[u,x,1]*x+Coefficient[u,x,2]*x^2)^p /; 1497FreeQ[{m,p},x] && LinearQ[v,x] && QuadraticQ[u,x] 1498 1499StandardizeIntegrand[v_^m_.*f_[u_]^p_.,x_Symbol] := 1500 (Coefficient[v,x,0]+Coefficient[v,x,1]*x)^m* 1501 f[Coefficient[u,x,0]+Coefficient[u,x,1]*x+Coefficient[u,x,2]*x^2]^p /; 1502FreeQ[{f,m,p},x] && LinearQ[v,x] && QuadraticQ[u,x] 1503 1504StandardizeIntegrand[v_^m_.*(f_^u_)^p_.,x_Symbol] := 1505 (Coefficient[v,x,0]+Coefficient[v,x,1]*x)^m* 1506 (f^(Coefficient[u,x,0]+Coefficient[u,x,1]*x+Coefficient[u,x,2]*x^2))^p /; 1507FreeQ[{f,m,p},x] && LinearQ[v,x] && QuadraticQ[u,x] 1508 1509 1510StandardizeIntegrand[u_*v_^p_.,x_Symbol] := 1511 Function[(#1[[1]]+#1[[2]]*x^#1[[3]])*(#2[[1]] + #2[[2]]*x^#2[[4]] + #2[[3]]*x^(2*#2[[4]]))^p][BinomialTest[u,x],TrinomialTest[v,x]] /; 1512FreeQ[p,x] && BinomialQ[u,x] && TrinomialQ[v,x] && ZeroQ[BinomialDegree[u,x]-TrinomialDegree[v,x]] 1513 1514 1515StandardizeIntegrand[u_*v_^p_.,x_Symbol] := 1516 Function[(#1[[1]]+#1[[2]]*x^#1[[3]])*(#2[[1]]^#2[[5]] + #2[[2]]*x^#2[[4]] + #2[[3]]*x^(2*#2[[4]]-#2[[5]]))^p][BinomialTest[u,x],GeneralizedTrinomialTest[v,x]] /; 1517FreeQ[p,x] && BinomialQ[u,x] && GeneralizedTrinomialQ[v,x] && ZeroQ[BinomialDegree[u,x]-GeneralizedTrinomialDegree[v,x]] 1518 1519 1520StandardizeIntegrand[u_^m_.*v_^p_.*w_^q_.,x_Symbol] := 1521 Function[(#1[[1]]+#1[[2]]*x^#1[[3]])^m*(#2[[1]]+#2[[2]]*x^#1[[3]])^p*(#3[[1]]+#3[[2]]*x^#1[[3]])^q][BinomialTest[u,x],BinomialTest[v,x],BinomialTest[w,x]] /; 1522FreeQ[{m,p,q},x] && BinomialQ[{u,v,w},x] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[v,x]] && ZeroQ[BinomialDegree[u,x]-BinomialDegree[w,x]] 1523 1524 1525StandardizeIntegrand[v_^m_.*w_*u_^p_.,x_Symbol] := 1526 (Coefficient[v,x,0]+Coefficient[v,x,1]*x)^m* 1527 (Coefficient[w,x,0]+Coefficient[w,x,1]*x)* 1528 (Coefficient[u,x,0]+Coefficient[u,x,1]*x+Coefficient[u,x,2]*x^2)^p /; 1529FreeQ[{m,p},x] && LinearQ[{v,w},x] && QuadraticQ[u,x] (* && Not[MatchQ[u,r_^2] && ZeroQ[p-1]] *) 1530 1531StandardizeIntegrand[u_*v_^m_.*w_^p_.,x_Symbol] := 1532 (Coefficient[u,x,0]+Coefficient[u,x,1]*x)* 1533 (Coefficient[v,x,0]+Coefficient[v,x,1]*x+Coefficient[v,x,2]*x^2)^m* 1534 (Coefficient[w,x,0]+Coefficient[w,x,1]*x+Coefficient[w,x,2]*x^2)^p /; 1535FreeQ[{m,p},x] && LinearQ[u,x] && QuadraticQ[{v,w},x] 1536 1537 1538StandardizeIntegrand[u_^m_.*v_^p_.*w_^q_.*z_^r_.,x_Symbol] := 1539 (Coefficient[u,x,0]+Coefficient[u,x,1]*x)^m* 1540 (Coefficient[v,x,0]+Coefficient[v,x,1]*x)^p* 1541 (Coefficient[w,x,0]+Coefficient[w,x,1]*x)^q* 1542 (Coefficient[z,x,0]+Coefficient[z,x,1]*x)^r /; 1543FreeQ[{m,p,q,r},x] && LinearQ[{u,v,w,z},x] 1544 1545 1546StandardizeIntegrand[Log[c_.*u_^n_.]/v_,x_Symbol] := 1547 Log[c*(Coefficient[u,x,0]+Coefficient[u,x,1]*x)^n]/(Coefficient[v,x,0]+Coefficient[v,x,1]*x) /; 1548FreeQ[{c,n},x] && LinearQ[u,x] && LinearQ[v,x] 1549 1550StandardizeIntegrand[Log[c_.*u_^n_.]/v_,x_Symbol] := 1551 Log[c*(Coefficient[u,x,0]+Coefficient[u,x,1]*x)^n]/(Coefficient[v,x,0]+Coefficient[v,x,1]*x+Coefficient[v,x,2]*x^2) /; 1552FreeQ[{c,n},x] && LinearQ[u,x] && QuadraticQ[v,x] 1553 1554 1555StandardizeIntegrand[Log[u_]/v_,x_Symbol] := 1556 Log[Function[(#[[1]]+#[[2]]*x)/(#[[3]]+#[[4]]*x)][QuotientOfLinearsParts[u,x]]]/ 1557 (Coefficient[v,x,0]+Coefficient[v,x,1]*x) /; 1558QuotientOfLinearsQ[u,x] && LinearQ[v,x] 1559 1560StandardizeIntegrand[Log[u_]/v_,x_Symbol] := 1561 Log[Function[(#[[1]]+#[[2]]*x)/(#[[3]]+#[[4]]*x)][QuotientOfLinearsParts[u,x]]]/ 1562 (Coefficient[v,x,0]+Coefficient[v,x,1]*x+Coefficient[v,x,2]*x^2) /; 1563QuotientOfLinearsQ[u,x] && QuadraticQ[v,x] 1564 1565 1566StandardizeIntegrand[u_,x_Symbol] := 1567 u /; 1568FreeQ[u,x] 1569 1570 1571(* SimplifyIntegrand[u,x] simplifies u and returns the result in a standard form recognizable by integration rules. *) 1572SimplifyIntegrand[u_,x_Symbol] := 1573 If[KnownIntegrandQ[u,x], 1574 StandardizeIntegrand[u,x], 1575 Module[{v}, 1576 v=NormalizeLeadTermSigns[NormalizeIntegrandAux[Simplify[u],x]]; 1577 If[v===NormalizeLeadTermSigns[u], 1578 u, 1579 v]]] 1580 1581(* SimplifyIntegrand[u_,x_Symbol] := 1582 Module[{v=Together[u],lst}, 1583 lst=SplitFreeFactors[v,x]; 1584 If[KnownIntegrandQ[lst[[2]],x], 1585 Simplify[lst[[1]]]*StandardizeIntegrand[lst[[2]],x], 1586 If[KnownIntegrandQ[u,x], 1587 StandardizeIntegrand[u,x], 1588 v=NormalizeLeadTermSigns[NormalizeIntegrandAux[Simplify[v],x]]; 1589 If[v===NormalizeLeadTermSigns[u], 1590 u, 1591 v]]]] *) 1592 1593 1594(* NormalForm[u_,x_Symbol] := 1595 u *) 1596 1597 1598(* NormalizeIntegrand[u,x] returns u in a standard form recognizable by integration rules. *) 1599NormalizeIntegrand[u_,x_Symbol] := 1600 Module[{v=NormalizeLeadTermSigns[NormalizeIntegrandAux[u,x]]}, 1601 If[v===NormalizeLeadTermSigns[u], 1602 u, 1603 v]] 1604 1605 1606NormalizeIntegrandAux[u_,x_Symbol] := 1607 If[SumQ[u], 1608 Map[Function[NormalizeIntegrandAux[#,x]],u], 1609 If[ProductQ[u], 1610 Map[Function[NormalizeIntegrandFactor[#,x]],u], 1611 NormalizeIntegrandFactor[u,x]]] 1612 1613 1614NormalizeIntegrandFactor[u_,x_Symbol] := 1615 Module[{bas,deg,min}, 1616 If[PowerQ[u] && FreeQ[u[[2]],x], 1617 bas=NormalizeIntegrandFactorBase[u[[1]],x]; 1618 deg=u[[2]]; 1619 If[IntegerQ[deg] && SumQ[bas], 1620 If[MapAnd[Function[MonomialQ[#,x]],bas], 1621 min=MinimumMonomialExponent[bas,x]; 1622 x^(min*deg)*Map[Function[Simplify[#/x^min]],bas]^deg, 1623 bas^deg], 1624 bas^deg], 1625 bas=NormalizeIntegrandFactorBase[u,x]; 1626 If[SumQ[bas], 1627 If[MapAnd[Function[MonomialQ[#,x]],bas], 1628 min=MinimumMonomialExponent[bas,x]; 1629 x^min*Map[Function[#/x^min],bas], 1630 bas], 1631 bas]]] 1632 1633 1634NormalizeIntegrandFactorBase[x_^m_.*u_,x_Symbol] := 1635 NormalizeIntegrandFactorBase[Map[Function[x^m*#],u],x] /; 1636FreeQ[m,x] && SumQ[u] 1637 1638 1639NormalizeIntegrandFactorBase[u_,x_Symbol] := 1640 If[BinomialQ[u,x], 1641 If[BinomialQ[u,x,True], 1642 u, 1643 Function[#[[1]]+#[[2]]*x^#[[3]]][BinomialTest[u,x]]], 1644 If[TrinomialQ[u,x], 1645 If[TrinomialQ[u,x,True], 1646 u, 1647 Function[#[[1]]+#[[2]]*x^#[[4]]+#[[3]]*x^(2*#[[4]])][TrinomialTest[u,x]]], 1648 If[ProductQ[u], 1649 Map[Function[NormalizeIntegrandFactor[#,x]],u], 1650 If[PolynomialQ[u,x] && Exponent[u,x]<=4, 1651 Module[{lst=CoefficientList[u,x]}, 1652 Sum[lst[[i]]*x^(i-1),{i,1,Length[lst]}]], 1653 If[SumQ[u], 1654 Module[{v=Together[Simplify[Together[u]]]}, 1655 If[SumQ[v] || MatchQ[v, x^m_.*w_ /; FreeQ[m,x] && SumQ[w]] || LeafCount[v]>LeafCount[u]+2, 1656 u, 1657 NormalizeIntegrandFactorBase[v,x]]], 1658 Map[Function[NormalizeIntegrandFactor[#,x]],u]]]]]] 1659 1660 1661(* NormalizeLeadTermSigns[u] returns an expression equal u but with not more than one sum 1662 factor raised to a integer degree having a lead term with a negative coefficient. *) 1663NormalizeLeadTermSigns[u_] := 1664 Module[{lst=If[ProductQ[u], Map[SignOfFactor,u], SignOfFactor[u]]}, 1665 If[lst[[1]]==1, 1666 lst[[2]], 1667 AbsorbMinusSign[lst[[2]]]]] 1668 1669 1670(* AbsorbMinusSign[u] returns an expression equal to -u. If there is a factor of u of the 1671 form v^m where v is a sum and m is an odd power, the minus sign is distributed over v; 1672 otherwise -u is returned. *) 1673AbsorbMinusSign[u_.*v_Plus] := 1674 u*(-v) 1675 1676AbsorbMinusSign[u_.*v_Plus^m_] := 1677 u*(-v)^m /; 1678OddQ[m] 1679 1680AbsorbMinusSign[u_] := 1681 -u 1682 1683 1684(* NormalizeSumFactors[u] returns an expression equal u but with the numeric coefficient of 1685 the lead term of sum factors made positive where possible. *) 1686NormalizeSumFactors[u_] := 1687 If[AtomQ[u] || Head[u]===If || Head[u]===Int || HeldFormQ[u], 1688 u, 1689 If[ProductQ[u], 1690 Function[#[[1]]*#[[2]]][SignOfFactor[Map[NormalizeSumFactors,u]]], 1691 Map[NormalizeSumFactors,u]]] 1692 1693 1694(* SignOfFactor[u] returns the list {n,v} where n*v equals u, n^2 equals 1, and the lead 1695 term of the sum factors of v raised to integer degrees all have positive coefficients. *) 1696SignOfFactor[u_] := 1697 If[RationalQ[u] && u<0 || SumQ[u] && NumericFactor[First[u]]<0, 1698 {-1, -u}, 1699 If[IntegerPowerQ[u] && SumQ[u[[1]]] && NumericFactor[First[u[[1]]]]<0, 1700 {(-1)^u[[2]], (-u[[1]])^u[[2]]}, 1701 If[ProductQ[u], 1702 Map[SignOfFactor,u], 1703 {1, u}]]] 1704 1705 1706Simp[u_,x_] := 1707 TimeConstrained[NormalizeSumFactors[SimpHelp[u,x]],TimeLimit,u] 1708 1709SimpHelp[E^(u_.*(v_.*Log[a_]+w_)),x_] := 1710 a^(u*v)*SimpHelp[E^(u*w),x] 1711 1712SimpHelp[u_,x_] := 1713 If[AtomQ[u], 1714 u, 1715 If[Head[u]===If || Head[u]===Int || HeldFormQ[u], 1716 u, 1717 If[FreeQ[u,x], 1718 Module[{v=SmartSimplify[u]}, 1719 If[LeafCount[v]<=LeafCount[u], 1720 v, 1721 u]], 1722 If[ProductQ[u], 1723 Module[{v=1,w=1}, 1724 Scan[Function[If[FreeQ[#,x],v=#*v,w=#*w]],u]; 1725 v=NumericFactor[v]*SmartSimplify[NonnumericFactors[v]*x^2]/x^2; 1726 w=If[ProductQ[w], Map[Function[SimpHelp[#,x]],w], SimpHelp[w,x]]; 1727 w=FactorNumericGcd[w]; 1728 v=MergeFactors[v,w]; 1729 If[ProductQ[v], 1730 Map[Function[SimpFixFactor[#,x]],v], 1731 v]], 1732 If[SumQ[u], 1733 If[PolynomialQ[u,x] && Exponent[u,x]<=0, 1734 SimpHelp[Coefficient[u,x,0],x], 1735 If[PolynomialQ[u,x] && Exponent[u,x]==1 && Coefficient[u,x,0]===0, 1736 SimpHelp[Coefficient[u,x,1],x]*x, 1737 Module[{v=0,w=0}, 1738 Scan[Function[If[FreeQ[#,x],v=#+v,w=#+w]],u]; 1739 v=SmartSimplify[v]; 1740 w=If[SumQ[w], Map[Function[SimpHelp[#,x]],w], SimpHelp[w,x]]; 1741 v+w]]], 1742 Map[Function[SimpHelp[#,x]],u]]]]]] 1743 1744 1745factorTime=0; 1746 1747SmartSimplify[u_] := 1748 TimeConstrained[ 1749 Module[{v,w}, 1750 v=Simplify[u]; 1751 w=Factor[v]; 1752 v=If[LeafCount[w]<LeafCount[v],w,v]; 1753 v=If[NotFalseQ[w=FractionalPowerOfSquareQ[v]] && FractionalPowerSubexpressionQ[u,w,Expand[w]],SubstForExpn[v,w,Expand[w]],v]; 1754 FixSimplify[FactorNumericGcd[v]]], 1755 TimeLimit,u] 1756 1757 1758(* If a subexpression of u is of the form ((v+w)^2)^n where n is a fraction, *) 1759(* FractionalPowerOfSquareQ[u] returns (v+w)^2; else it returns False. *) 1760FractionalPowerOfSquareQ[u_] := 1761 If[AtomQ[u], 1762 False, 1763 If[FractionalPowerQ[u] && MatchQ[u[[1]], a_.*(b_+c_)^2 /; NonsumQ[a]], 1764 u[[1]], 1765 Module[{tmp}, 1766 Catch[ 1767 Scan[Function[If[NotFalseQ[tmp=FractionalPowerOfSquareQ[#]],Throw[tmp]]],u]; 1768 False]]]] 1769 1770 1771(* If a subexpression of u is of the form w^n where n is a fraction but not equal to v, *) 1772(* FractionalPowerSubexpressionQ[u,v,w] returns True; else it returns False. *) 1773FractionalPowerSubexpressionQ[u_,v_,w_] := 1774 If[AtomQ[u], 1775 False, 1776 If[FractionalPowerQ[u] && PositiveQ[u[[1]]/w], 1777 Not[u[[1]]===v] && LeafCount[w]<3*LeafCount[v], 1778 Catch[Scan[Function[If[FractionalPowerSubexpressionQ[#,v,w],Throw[True]]],u]; False]]] 1779 1780 1781FixSimplify[w_.*(a_^m_*u_.+b_^n_.*v_.)] := 1782 FixSimplify[a^m*w*(u+(-1)^n*a^(n-m)*v)] /; 1783a+b===0 && FractionQ[m] && IntegerQ[n] && 0<m<n 1784 1785 1786FixSimplify[w_.*(a_^m_.*u_.+a_^n_.*v_.)^t_.] := 1787 FixSimplify[a^(m*t)*w*(u+a^(n-m)*v)^t] /; 1788Not[RationalQ[a]] && IntegerQ[t] && RationalQ[m,n] && 0<m<=n 1789 1790FixSimplify[w_.*(a_^m_.*u_.+a_^n_.*v_.+a_^p_.*z_.)^t_.] := 1791 FixSimplify[a^(m*t)*w*(u+a^(n-m)*v+a^(p-m)*z)^t] /; 1792Not[RationalQ[a]] && IntegerQ[t] && RationalQ[m,n,p] && 0<m<=n<=p 1793 1794FixSimplify[w_.*(a_^m_.*u_.+a_^n_.*v_.+a_^p_.*z_.+a_^q_.*y_.)^t_.] := 1795 FixSimplify[a^(m*t)*w*(u+a^(n-m)*v+a^(p-m)*z+a^(q-m)*y)^t] /; 1796Not[RationalQ[a]] && IntegerQ[t] && RationalQ[m,n,p] && 0<m<=n<=p<=q 1797 1798 1799FixSimplify[w_.*(u_.+a_.*Sqrt[v_Plus]+b_.*Sqrt[v_]+c_.*Sqrt[v_]+d_.*Sqrt[v_])] := 1800 FixSimplify[w*(u+FixSimplify[a+b+c+d]*Sqrt[v])] 1801 1802FixSimplify[w_.*(u_.+a_.*Sqrt[v_Plus]+b_.*Sqrt[v_]+c_.*Sqrt[v_])] := 1803 FixSimplify[w*(u+FixSimplify[a+b+c]*Sqrt[v])] 1804 1805FixSimplify[w_.*(u_.+a_.*Sqrt[v_Plus]+b_.*Sqrt[v_])] := 1806 FixSimplify[w*(u+FixSimplify[a+b]*Sqrt[v])] 1807 1808 1809FixSimplify[u_.*a_^m_*Sqrt[b_.*(c_+d_.*Sqrt[a_])]] := 1810 Sqrt[Together[b*(c*a^(2*m)+d*a^(2*m+1/2))]]*FixSimplify[u] /; 1811RationalQ[a,b,c,d,m] && a>0 && Denominator[m]==4 1812 1813FixSimplify[u_.*a_^m_/Sqrt[b_.*(c_+d_.*Sqrt[a_])]] := 1814 FixSimplify[u]/Sqrt[Together[b*(c/a^(2*m)+d/a^(2*m-1/2))]] /; 1815RationalQ[a,b,c,d,m] && a>0 && Denominator[m]==4 1816 1817 1818FixSimplify[u_.*v_^m_*w_^n_] := 1819 -FixSimplify[u*v^(m-1)] /; 1820RationalQ[m] && Not[RationalQ[w]] && FractionQ[n] && n<0 && ZeroQ[v+w^(-n)] 1821 1822 1823FixSimplify[u_.*v_^m_*w_^n_.] := 1824 (-1)^(n)*FixSimplify[u*v^(m+n)] /; 1825RationalQ[m] && Not[RationalQ[w]] && IntegerQ[n] && ZeroQ[v+w] 1826 1827 1828FixSimplify[u_.*(-v_^p_.)^m_*w_^n_.] := 1829 (-1)^(n/p)*FixSimplify[u*(-v^p)^(m+n/p)] /; 1830RationalQ[m] && Not[RationalQ[w]] && IntegerQ[n/p] && ZeroQ[v-w] 1831 1832 1833FixSimplify[u_.*(-v_^p_.)^m_*w_^n_.] := 1834 (-1)^(n+n/p)*FixSimplify[u*(-v^p)^(m+n/p)] /; 1835RationalQ[m] && Not[RationalQ[w]] && IntegersQ[n,n/p] && ZeroQ[v+w] 1836 1837 1838FixSimplify[u_.*(a-b)^m_.*(a+b)^m_.] := 1839 u*(a^2-b^2)^m /; 1840IntegerQ[m] 1841 1842FixSimplify[u_.*(c*d^2-e*(b*d-a*e))^m_.] := 1843 u*(c*d^2-b*d*e+a*e^2)^m /; 1844RationalQ[m] 1845 1846FixSimplify[u_.*(c*d^2+e*(-b*d+a*e))^m_.] := 1847 u*(c*d^2-b*d*e+a*e^2)^m /; 1848RationalQ[m] 1849 1850FixSimplify[u_] := u 1851 1852 1853SimpFixFactor[(a_.*c_^r_ + b_.*x_^n_.)^p_.,x_] := 1854 c^(r*p)*SimpFixFactor[(a+b/c^r*x^n)^p,x] /; 1855FreeQ[{a,b,c},x] && IntegersQ[n,p] && AtomQ[c] && RationalQ[r] && r<0 1856 1857SimpFixFactor[(a_. + b_.*c_^r_*x_^n_.)^p_.,x_] := 1858 c^(r*p)*SimpFixFactor[(a/c^r+b*x^n)^p,x] /; 1859FreeQ[{a,b,c},x] && IntegersQ[n,p] && AtomQ[c] && RationalQ[r] && r<0 1860 1861SimpFixFactor[(a_.*c_^s_. + b_.*c_^r_.*x_^n_.)^p_.,x_] := 1862 c^(s*p)*SimpFixFactor[(a+b*c^(r-s)*x^n)^p,x] /; 1863FreeQ[{a,b,c},x] && IntegersQ[n,p] && RationalQ[s,r] && 0<s<=r && c^(s*p)=!=-1 1864 1865SimpFixFactor[(a_.*c_^s_. + b_.*c_^r_.*x_^n_.)^p_.,x_] := 1866 c^(r*p)*SimpFixFactor[(a*c^(s-r)+b*x^n)^p,x] /; 1867FreeQ[{a,b,c},x] && IntegersQ[n,p] && RationalQ[s,r] && 0<r<s && c^(r*p)=!=-1 1868 1869SimpFixFactor[u_,x_] := u 1870 1871 1872(* FactorNumericGcd[u] returns u with the gcd of the numeric coefficients of terms of sums factored out. *) 1873FactorNumericGcd[u_] := 1874 If[PowerQ[u] && RationalQ[u[[2]]], 1875 FactorNumericGcd[u[[1]]]^u[[2]], 1876 If[ProductQ[u], 1877 Map[FactorNumericGcd,u], 1878 If[SumQ[u], 1879 Module[{g=Apply[GCD,Map[NumericFactor,Apply[List,u]]]}, 1880 g*Map[Function[#/g],u]], 1881 u]]] 1882 1883 1884(* MergeFactors[u,v] returns the product of u and v, but with the mergeable factors of u merged into v. *) 1885MergeFactors[u_,v_] := 1886 If[ProductQ[u], 1887 MergeFactors[Rest[u],MergeFactors[First[u],v]], 1888 If[PowerQ[u], 1889 If[MergeableFactorQ[u[[1]],u[[2]],v], 1890 MergeFactor[u[[1]],u[[2]],v], 1891 If[RationalQ[u[[2]]] && u[[2]]<-1 && MergeableFactorQ[u[[1]],-1,v], 1892 MergeFactors[u[[1]]^(u[[2]]+1),MergeFactor[u[[1]],-1,v]], 1893 u*v]], 1894 If[MergeableFactorQ[u,1,v], 1895 MergeFactor[u,1,v], 1896 u*v]]] 1897 1898 1899(* If MergeableFactorQ[bas,deg,v], MergeFactor[bas,deg,v] return the product of bas^deg and v, 1900 but with bas^deg merged into the factor of v whose base equals bas. *) 1901MergeFactor[bas_,deg_,v_] := 1902 If[bas===v, 1903 bas^(deg+1), 1904 If[PowerQ[v], 1905 If[bas===v[[1]], 1906 bas^(deg+v[[2]]), 1907 MergeFactor[bas,deg/v[[2]],v[[1]]]^v[[2]]], 1908 If[ProductQ[v], 1909 If[MergeableFactorQ[bas,deg,First[v]], 1910 MergeFactor[bas,deg,First[v]]*Rest[v], 1911 First[v]*MergeFactor[bas,deg,Rest[v]]], 1912 MergeFactor[bas,deg,First[v]] + MergeFactor[bas,deg,Rest[v]]]]] 1913 1914 1915(* MergeableFactorQ[bas,deg,v] returns True iff bas equals the base of a factor of v or bas is a factor of every term of v. *) 1916MergeableFactorQ[bas_,deg_,v_] := 1917 If[bas===v, 1918 RationalQ[deg+1] && (deg+1>=0 || RationalQ[deg] && deg>0), 1919 If[PowerQ[v], 1920 If[bas===v[[1]], 1921 RationalQ[deg+v[[2]]] && (deg+v[[2]]>=0 || RationalQ[deg] && deg>0), 1922 SumQ[v[[1]]] && IntegerQ[v[[2]]] && (Not[IntegerQ[deg]] || IntegerQ[deg/v[[2]]]) && MergeableFactorQ[bas,deg/v[[2]],v[[1]]]], 1923 If[ProductQ[v], 1924 MergeableFactorQ[bas,deg,First[v]] || MergeableFactorQ[bas,deg,Rest[v]], 1925 SumQ[v] && MergeableFactorQ[bas,deg,First[v]] && MergeableFactorQ[bas,deg,Rest[v]]]]] 1926 1927 1928(* RemoveContent[expn,x] returns expn with the factored content free of x removed. *) 1929RemoveContent[expn_,x_Symbol] := 1930 Module[{u=SplitFreeFactors[ContentFactor[expn],x][[2]]}, 1931 If[SumQ[u] && NegQ[u[[1]]], 1932 -u, 1933 u]] 1934 1935 1936(* ContentFactor[expn] returns expn with the content of sum factors factored out. *) 1937(* Basis: a*b+a*c == a*(b+c) *) 1938ContentFactor[expn_] := 1939 TimeConstrained[ContentFactorAux[expn],TimeLimit,expn]; 1940 1941ContentFactorAux[expn_] := 1942 If[AtomQ[expn], 1943 expn, 1944 If[IntegerPowerQ[expn], 1945 If[SumQ[expn[[1]]] && NumericFactor[expn[[1,1]]]<0, 1946 (-1)^expn[[2]] * ContentFactorAux[-expn[[1]]]^expn[[2]], 1947 ContentFactorAux[expn[[1]]]^expn[[2]]], 1948 If[ProductQ[expn], 1949 Module[{num=1,tmp}, 1950 tmp=Map[Function[If[SumQ[#] && NumericFactor[#[[1]]]<0, num=-num; ContentFactorAux[-#], ContentFactorAux[#]]], expn]; 1951 num*UnifyNegativeBaseFactors[tmp]], 1952 If[SumQ[expn], 1953 Module[{lst=CommonFactors[Apply[List,expn]]}, 1954 If[lst[[1]]===1 || lst[[1]]===-1, 1955 expn, 1956 lst[[1]]*Apply[Plus,Rest[lst]]]], 1957 expn]]]] 1958 1959 1960(* UnifyNegativeBaseFactors[u] returns u with factors of the form (-v)^m and v^n where n is an integer replaced with (-1)^n*(-v)^(m+n). *) 1961(* This should be done automatically by the host CAS! *) 1962UnifyNegativeBaseFactors[u_.*(-v_)^m_*v_^n_.] := 1963 UnifyNegativeBaseFactors[(-1)^n*u*(-v)^(m+n)] /; 1964IntegerQ[n] 1965 1966UnifyNegativeBaseFactors[u_] := 1967 u 1968 1969 1970(* If lst is a list of n terms, CommonFactors[lst] returns a n+1-element list whose first 1971 element is the product of the factors common to all terms of lst, and whose remaining 1972 elements are quotients of each term divided by the common factor. *) 1973CommonFactors [lst_] := 1974 Module[{lst1,lst2,lst3,lst4,common,base,num}, 1975 lst1=Map[NonabsurdNumberFactors,lst]; 1976 lst2=Map[AbsurdNumberFactors,lst]; 1977 num=Apply[AbsurdNumberGCD,lst2]; 1978 common=num; 1979 lst2=Map[Function[#/num],lst2]; 1980 While[True, 1981 lst3=Map[LeadFactor,lst1]; 1982 ( If[Apply[SameQ,lst3], 1983 common=common*lst3[[1]]; 1984 lst1=Map[RemainingFactors,lst1], 1985 If[MapAnd[Function[LogQ[#] && IntegerQ[First[#]] && First[#]>0],lst3] && 1986 MapAnd[RationalQ,lst4=Map[Function[FullSimplify[#/First[lst3]]],lst3]], 1987 num=Apply[GCD,lst4]; 1988 common=common*Log[(First[lst3][[1]])^num]; 1989 lst2=Map2[Function[#1*#2/num],lst2,lst4]; 1990 lst1=Map[RemainingFactors,lst1], 1991 lst4=Map[LeadDegree,lst1]; 1992 If[Apply[SameQ,Map[LeadBase,lst1]] && MapAnd[RationalQ,lst4], 1993 num=Smallest[lst4]; 1994 base=LeadBase[lst1[[1]]]; 1995 ( If[num!=0, 1996 common=common*base^num] ); 1997 lst2=Map2[Function[#1*base^(#2-num)],lst2,lst4]; 1998 lst1=Map[RemainingFactors,lst1], 1999 If[Length[lst1]==2 && ZeroQ[LeadBase[lst1[[1]]]+LeadBase[lst1[[2]]]] && 2000 NonzeroQ[lst1[[1]]-1] && IntegerQ[lst4[[1]]] && FractionQ[lst4[[2]]], 2001 num=Min[lst4]; 2002 base=LeadBase[lst1[[2]]]; 2003 ( If[num!=0, 2004 common=common*base^num] ); 2005 lst2={lst2[[1]]*(-1)^lst4[[1]],lst2[[2]]}; 2006 lst2=Map2[Function[#1*base^(#2-num)],lst2,lst4]; 2007 lst1=Map[RemainingFactors,lst1], 2008 If[Length[lst1]==2 && ZeroQ[LeadBase[lst1[[1]]]+LeadBase[lst1[[2]]]] && 2009 NonzeroQ[lst1[[2]]-1] && IntegerQ[lst4[[2]]] && FractionQ[lst4[[1]]], 2010 num=Min[lst4]; 2011 base=LeadBase[lst1[[1]]]; 2012 ( If[num!=0, 2013 common=common*base^num] ); 2014 lst2={lst2[[1]],lst2[[2]]*(-1)^lst4[[2]]}; 2015 lst2=Map2[Function[#1*base^(#2-num)],lst2,lst4]; 2016 lst1=Map[RemainingFactors,lst1], 2017 num=MostMainFactorPosition[lst3]; 2018 lst2=ReplacePart[lst2,lst3[[num]]*lst2[[num]],num]; 2019 lst1=ReplacePart[lst1,RemainingFactors[lst1[[num]]],num]]]]]] ); 2020 If[MapAnd[Function[#===1],lst1], 2021 Return[Prepend[lst2,common]]]]] 2022 2023 2024MostMainFactorPosition[lst_List] := 2025 Module[{factor=1,num=1}, 2026 Do[If[FactorOrder[lst[[i]],factor]>0,factor=lst[[i]];num=i],{i,Length[lst]}]; 2027 num] 2028 2029 2030FactorOrder[u_,v_] := 2031 If[u===1, 2032 If[v===1, 2033 0, 2034 -1], 2035 If[v===1, 2036 1, 2037 Order[u,v]]] 2038 2039 2040Smallest[num1_,num2_] := 2041 If[num1>0, 2042 If[num2>0, 2043 Min[num1,num2], 2044 0], 2045 If[num2>0, 2046 0, 2047 Max[num1,num2]]] 2048 2049Smallest[lst_List] := 2050 Module[{num=lst[[1]]}, 2051 Scan[Function[num=Smallest[num,#]],Rest[lst]]; 2052 num] 2053 2054 2055(* MonomialFactor[u,x] returns the list {n,v} where x^n*v==u and n is free of x. *) 2056MonomialFactor[u_,x_Symbol] := 2057 If[AtomQ[u], 2058 If[u===x, 2059 {1,1}, 2060 {0,u}], 2061 If[PowerQ[u], 2062 If[IntegerQ[u[[2]]], 2063 Module[{lst=MonomialFactor[u[[1]],x]}, 2064 {lst[[1]]*u[[2]],lst[[2]]^u[[2]]}], 2065 If[u[[1]]===x && FreeQ[u[[2]],x], 2066 {u[[2]],1}, 2067 {0,u}]], 2068 If[ProductQ[u], 2069 Module[{lst1=MonomialFactor[First[u],x],lst2=MonomialFactor[Rest[u],x]}, 2070 {lst1[[1]]+lst2[[1]],lst1[[2]]*lst2[[2]]}], 2071 If[SumQ[u], 2072 Module[{lst,deg}, 2073 lst=Map[Function[MonomialFactor[#,x]],Apply[List,u]]; 2074 deg=lst[[1,1]]; 2075 Scan[Function[deg=MinimumDegree[deg,#[[1]]]],Rest[lst]]; 2076 If[ZeroQ[deg] || RationalQ[deg] && deg<0, 2077 {0,u}, 2078 {deg,Apply[Plus,Map[Function[x^(#[[1]]-deg)*#[[2]]],lst]]}]], 2079 {0,u}]]]] 2080 2081 2082MinimumDegree[deg1_,deg2_] := 2083 If[RationalQ[deg1], 2084 If[RationalQ[deg2], 2085 Min[deg1,deg2], 2086 deg1], 2087 If[RationalQ[deg2], 2088 deg2, 2089 Module[{deg=Simplify[deg1-deg2]}, 2090 If[RationalQ[deg], 2091 If[deg>0, 2092 deg2, 2093 deg1], 2094 If[OrderedQ[{deg1,deg2}], 2095 deg1, 2096 deg2]]]]] 2097 2098 2099(* ConstantFactor[u,x] returns a 2-element list of the factors of u[x] free of x and the 2100 factors not free of u[x]. Common constant factors of the terms of sums are also collected. *) 2101(* Compare with the more passive function SplitFreeFactors. *) 2102ConstantFactor[u_,x_Symbol] := 2103 If[FreeQ[u,x], 2104 {u,1}, 2105 If[AtomQ[u], 2106 {1,u}, 2107 If[PowerQ[u] && FreeQ[u[[2]],x], 2108 Module[{lst=ConstantFactor[u[[1]],x],tmp}, 2109 If[IntegerQ[u[[2]]], 2110 {lst[[1]]^u[[2]],lst[[2]]^u[[2]]}, 2111 tmp=PositiveFactors[lst[[1]]]; 2112 If[tmp===1, 2113 {1,u}, 2114 {tmp^u[[2]],(NonpositiveFactors[lst[[1]]]*lst[[2]])^u[[2]]}]]], 2115 If[ProductQ[u], 2116 Module[{lst=Map[Function[ConstantFactor[#,x]],Apply[List,u]]}, 2117 {Apply[Times,Map[First,lst]],Apply[Times,Map[Function[#[[2]]],lst]]}], 2118 If[SumQ[u], 2119 Module[{lst1=Map[Function[ConstantFactor[#,x]],Apply[List,u]]}, 2120 If[Apply[SameQ,Map[Function[#[[2]]],lst1]], 2121 {Apply[Plus,Map[First,lst1]],lst1[[1,2]]}, 2122 Module[{lst2=CommonFactors[Map[First,lst1]]}, 2123 {First[lst2],Apply[Plus,Map2[Times,Rest[lst2],Map[Function[#[[2]]],lst1]]]}]]], 2124 {1,u}]]]]] 2125 2126 2127(* PositiveFactors[u] returns the positive factors of u *) 2128PositiveFactors[u_] := 2129 If[ZeroQ[u], 2130 1, 2131 If[RationalQ[u], 2132 Abs[u], 2133 If[PositiveQ[u], 2134 u, 2135 If[ProductQ[u], 2136 Map[PositiveFactors,u], 2137 1]]]] 2138 2139 2140(* NonpositiveFactors[u] returns the nonpositive factors of u *) 2141NonpositiveFactors[u_] := 2142 If[ZeroQ[u], 2143 u, 2144 If[RationalQ[u], 2145 Sign[u], 2146 If[PositiveQ[u], 2147 1, 2148 If[ProductQ[u], 2149 Map[NonpositiveFactors,u], 2150 u]]]] 2151 2152 2153Clear[ExpandIntegrand]; 2154 2155 2156ExpandIntegrand[(a_.+b_.*x_)^m_.*f_^(e_.*(c_.+d_.*x_)^n_.)/(g_.+h_.*x_),x_Symbol] := 2157 Module[{tmp=a*h-b*g}, 2158 SimplifyTerm[tmp^m/h^m,x]*f^(e*(c+d*x)^n)/(g+h*x) + 2159 Sum[SimplifyTerm[b*tmp^(k-1)/h^k,x]*f^(e*(c+d*x)^n)*(a+b*x)^(m-k),{k,1,m}]] /; 2160FreeQ[{a,b,c,d,e,f,g,h},x] && PositiveIntegerQ[m] && ZeroQ[b*c-a*d] 2161 2162 2163ExpandIntegrand[x_^m_.*(e_+f_.*x_)^p_.*F_^(b_.*(c_.+d_.*x_)^n_.),x_Symbol] := 2164 If[PositiveIntegerQ[m,p] && m<=p && (OneQ[n] || ZeroQ[d*e-c*f]), 2165 Distribute[F^(b*(c+d*x)^n)*ExpandLinearProduct[x^m,e+f*x,p,x],Plus,Times], 2166 If[PositiveIntegerQ[p], 2167 Distribute[x^m*F^(b*(c+d*x)^n)*Expand[(e+f*x)^p,x],Plus,Times], 2168 Distribute[F^(b*(c+d*x)^n)*ExpandIntegrand[x^m*(e+f*x)^p,x],Plus,Times]]] /; 2169FreeQ[{F,b,c,d,e,f,m,n,p},x] 2170 2171 2172ExpandIntegrand[x_^m_.*(e_+f_.*x_)^p_.*F_^(a_.+b_.*(c_.+d_.*x_)^n_.),x_Symbol] := 2173 If[PositiveIntegerQ[m,p] && m<=p && (OneQ[n] || ZeroQ[d*e-c*f]), 2174 Distribute[F^(a+b*(c+d*x)^n)*ExpandLinearProduct[x^m,e+f*x,p,x],Plus,Times], 2175 If[PositiveIntegerQ[p], 2176 Distribute[x^m*F^(a+b*(c+d*x)^n)*Expand[(e+f*x)^p,x],Plus,Times], 2177 Distribute[F^(a+b*(c+d*x)^n)*ExpandIntegrand[x^m*(e+f*x)^p,x],Plus,Times]]] /; 2178FreeQ[{F,a,b,c,d,e,f,m,n,p},x] 2179 2180 2181ExpandIntegrand[u_*(a_.+b_.*x_)^m_.*f_^(e_.*(c_.+d_.*x_)^n_.),x_Symbol] := 2182 Module[{v=ExpandIntegrand[u*(a+b*x)^m,x]}, 2183 Distribute[f^(e*(c+d*x)^n)*v,Plus,Times] /; 2184 SumQ[v]] /; 2185FreeQ[{a,b,c,d,e,f,m,n},x] && PolynomialQ[u,x] 2186 2187 2188ExpandIntegrand[u_*(a_.+b_.*x_)^m_.*Log[c_.*(d_.+e_.*x_^n_.)^p_.],x_Symbol] := 2189 Distribute[Log[c*(d+e*x^n)^p]*ExpandIntegrand[u*(a+b*x)^m,x],Plus,Times] /; 2190FreeQ[{a,b,c,d,e,m,n,p},x] && PolynomialQ[u,x] 2191 2192 2193ExpandIntegrand[u_*f_^(e_.*(c_.+d_.*x_)^n_.),x_Symbol] := 2194 Distribute[f^(e*(c+d*x)^n)*ExpandLinearProduct[u,c+d*x,0,x],Plus,Times] /; 2195FreeQ[{c,d,e,f,n},x] && PolynomialQ[u,x] 2196 2197 2198ExpandIntegrand[u_.*v_^m_,x_Symbol] := 2199 Distribute[NormalizeIntegrand[v^m,x]*ExpandIntegrand[u,x],Plus,Times] /; 2200Not[IntegerQ[m]] && Not[LinearQ[v,x]] 2201 2202 2203ExpandIntegrand[u_./(a_.*x_^n_+b_.*Sqrt[c_+d_.*x_^j_]),x_Symbol] := 2204 ExpandIntegrand[u*(a*x^n-b*Sqrt[c+d*x^(2*n)])/(-b^2*c+(a^2-b^2*d)*x^(2*n)),x] /; 2205FreeQ[{a,b,c,d,n},x] && ZeroQ[j-2*n] 2206 2207 2208ExpandIntegrand[(a_+b_.*x_)^m_/(c_+d_.*x_),x_Symbol] := 2209 If[RationalQ[a,b,c,d], 2210 ExpandIntegrandAux[(a+b*x)^m/(c+d*x),x], 2211 Module[{tmp=a*d-b*c}, 2212 SimplifyTerm[tmp^m/d^m,x]/(c+d*x) + Sum[SimplifyTerm[b*tmp^(k-1)/d^k,x]*(a+b*x)^(m-k),{k,1,m}]]] /; 2213FreeQ[{a,b,c,d},x] && PositiveIntegerQ[m] 2214 2215 2216ExpandIntegrand[(a_+b_.*x_)^m_.*(A_+B_.*x_)/(c_+d_.*x_),x_Symbol] := 2217 If[RationalQ[a,b,c,d,A,B], 2218 ExpandIntegrandAux[(a+b*x)^m*(A+B*x)/(c+d*x),x], 2219 Module[{tmp1,tmp2}, 2220 tmp1=(A*d-B*c)/d; 2221 tmp2=ExpandIntegrand[(a+b*x)^m/(c+d*x),x]; 2222 tmp2=If[SumQ[tmp2], Map[Function[SimplifyTerm[tmp1*#,x]],tmp2], SimplifyTerm[tmp1*tmp2,x]]; 2223 SimplifyTerm[B/d,x]*(a+b*x)^m + tmp2]] /; 2224FreeQ[{a,b,c,d,A,B},x] && PositiveIntegerQ[m] 2225 2226 2227(* If u is a polynomial in x, ExpandIntegrand[u*(a+b*x)^m,x] expand u*(a+b*x)^m into a sum of terms of the form A*(a+b*x)^n. *) 2228ExpandIntegrand[u_*(a_.+b_.*x_)^m_,x_Symbol] := 2229 Module[{tmp1,tmp2}, 2230 tmp1=ExpandLinearProduct[u,a+b*x,m,x]; 2231 If[Not[IntegerQ[m]], 2232 tmp1, 2233 tmp2=ExpandIntegrandAux[u*(a+b*x)^m,x]; 2234 If[SumQ[tmp2] && LeafCount[tmp2]<=LeafCount[tmp1]+2, 2235 tmp2, 2236 tmp1]]] /; 2237FreeQ[{a,b,m},x] && PolynomialQ[u,x] && 2238 Not[PositiveIntegerQ[m] && MatchQ[u,v_.*(c_+d_.*x)^n_ /; FreeQ[{c,d},x] && IntegerQ[n] && n>m]] 2239 2240 2241(* If u is a polynomial in x, MergeLinearProduct[u,a+b*x,m,x] expand u*(a+b*x)^m into a sum of terms of the form A*(a+b*x)^n. *) 2242ExpandLinearProduct[u_,a_.+b_.*x_,m_,x_Symbol] := 2243 Module[{lst}, 2244 lst=CoefficientList[ReplaceAll[u,x->(x-a)/b],x]; 2245 lst=Map[Function[SimplifyTerm[#,x]],lst]; 2246 Sum[lst[[k]]*(a+b*x)^(m+k-1),{k,1,Length[lst]}]] /; 2247FreeQ[{a,b,m},x] && PolynomialQ[u,x] 2248 2249 2250ExpandIntegrand[u_/v_,x_Symbol] := 2251 Module[{lst=CoefficientList[u,x]}, 2252 lst[[-1]]*x^Exponent[u,x]/v + Sum[lst[[i]]*x^(i-1),{i,1,Exponent[u,x]}]/v] /; 2253PolynomialQ[u,x] && PolynomialQ[v,x] && BinomialQ[v,x] && Exponent[u,x]==Exponent[v,x]-1>=2 2254 2255 2256ExpandIntegrand[u_/v_,x_Symbol] := 2257 Simp[PolynomialQuotient[u,v,x],x] + SimplifyIntegrand[Together[PolynomialRemainder[u,v,x]]/v,x] /; 2258PolynomialQ[u,x] && PolynomialQ[v,x] && Exponent[u,x]>=Exponent[v,x] 2259 2260 2261ExpandIntegrand[u_,x_Symbol] := 2262 ExpandIntegrandAux[u,x] 2263 2264 2265(* Note: These rule is necessary because if a or b contains fractional powers, Apart rationalizes 2266 denominator resulting in hard to integrate terms in partial fraction expansion. *) 2267ExpandIntegrandAux[u_.*(a_.+d_.*c_^m_+b_.*v_)^p_,x_Symbol] := 2268 Module[{tmp}, 2269 ReplaceAll[ExpandIntegrandAux[u*(a+d*tmp+b*v)^p,x],{tmp->c^m}]] /; 2270FreeQ[{a,b,c,d},x] && IntegerQ[p] && p<0 && FractionQ[m] && Not[FreeQ[v,x]] 2271 2272ExpandIntegrandAux[u_.*(a_.+b_.*c_^m_*v_)^p_,x_Symbol] := 2273 Module[{tmp}, 2274 ReplaceAll[ExpandIntegrandAux[u*(a+b*tmp*v)^p,x],{tmp->c^m}]] /; 2275FreeQ[{a,b,c},x] && IntegerQ[p] && p<0 && FractionQ[m] && Not[FreeQ[v,x]] 2276 2277 2278ExpandIntegrandAux[u_,x_Symbol] := 2279 Module[{v}, 2280 v=If[AlgebraicFunctionQ[u,x] && Not[RationalFunctionQ[u,x]], ExpandAlgebraic[u,x], 0]; 2281 ( If[Not[SumQ[v]], 2282 v=Apart[u,x]; 2283 If[Not[SumQ[v]], 2284 v=Apart[u]; 2285 If[Not[SumQ[v]], 2286 v=Expand[u,x]; 2287 If[Not[SumQ[v]], 2288 v=Expand[u]]]]] ); 2289 If[SumQ[v], 2290 v=Map[Function[SimplifyTerm[#,x]],v]; 2291 Apply[Plus,Map[Function[#[[1]]*#[[2]]],UnifyTerms[Map[Function[SplitFreeFactors[#,x]],Apply[List,v]]]]], 2292 SimplifyTerm[u,x]]] 2293 2294 2295SimplifyTerm[u_,x_Symbol] := 2296 NormalizeIntegrand[Together[Simplify[u]],x] 2297 2298 2299ExpandAlgebraic[u_Plus*v_,x_Symbol] := 2300 Map[Function[#*v],u] /; 2301Not[FreeQ[u,x]] 2302 2303ExpandAlgebraic[u_Plus^n_*v_.,x_Symbol] := 2304 Module[{w=Expand[u^n,x]}, 2305 Map[Function[#*v],w] /; 2306 SumQ[w]] /; 2307PositiveIntegerQ[n] && Not[FreeQ[u,x]] 2308 2309 2310(* lst is a list of pairs of the form {u,v}. UnifyTerms[lst,x] returns lst with pairs having indentical v's collected into a single element. *) 2311UnifyTerms[lst_] := 2312 If[lst==={}, 2313 lst, 2314 UnifyTerm[First[lst][[1]],First[lst][[2]],UnifyTerms[Rest[lst]]]] 2315 2316 2317UnifyTerm[u_,v_,lst_] := 2318 If[lst==={}, 2319 {{u,v}}, 2320 If[v===First[lst][[2]], 2321 Prepend[Rest[lst],{u+First[lst][[1]],v}], 2322 Prepend[UnifyTerm[u,v,Rest[lst]],First[lst]]]] 2323 2324 2325Distrib[u_] := 2326 Distribute[u,Plus,Times] 2327 2328 2329(* Dist[u,v] returns the sum of u times each term of v, provided v is free of Int. *) 2330DownValues[Dist]={}; 2331UpValues[Dist]={}; 2332 2333Dist[0,v_,x_] := 2334 (Print["*** Warning ***: Dist[0,",v," ",x,"]"]; 0); 2335 2336Dist[1,v_,x_] := v 2337 2338Dist[u_,v_,x_] := 2339 -Dist[-u,v,x] /; 2340NumericFactor[u]<0 2341 2342Dist /: Dist[u_,v_,x_]+Dist[w_,v_,x_] := 2343 If[ZeroQ[u+w], 2344 0, 2345 Dist[u+w,v,x]] 2346 2347Dist /: Dist[u_,v_,x_]-Dist[w_,v_,x_] := 2348 If[ZeroQ[u-w], 2349 0, 2350 Dist[u-w,v,x]] 2351 2352Dist /: w_*Dist[u_,v_,x_] := 2353 Dist[w*u,v,x] /; 2354w=!=-1 2355 2356Dist[u_,Dist[v_,w_,x_],x_] := 2357 Dist[u*v,w,x] 2358 2359Dist[u_,v_,x_] := 2360 Map[Function[Dist[u,#,x]],v] /; 2361SumQ[v] 2362 2363Dist[u_,v_,x_] := 2364 Simp[u*v,x] /; 2365FreeQ[v,Int] || ShowSteps=!=True 2366 2367Dist[u_,v_,x_] := 2368 Module[{w=Simp[u,x]}, 2369 Dist[w,v,x] /; 2370w=!=u] 2371 2372Dist[u_,v_*w_,x_] := 2373 Dist[u*v,w,x] /; 2374FreeQ[v,Int] && Not[FreeQ[w,Int]] 2375 2376 2377(* DistSimp[u_.*v_^m_*w_^n_] := 2378 DistSimp[u*v^(m+n)] /; 2379ZeroQ[v-w] 2380 2381(* Basis: If n is an integer, (a+b*z)^m*(b+a/z)^n == (a+b*z)^(m+n)/z^n *) 2382DistSimp[u_*(a_+b_.*f_[v_])^m_*(b_+a_.*g_[v_])^n_.] := 2383 u*(a+b*f[v])^(m+n)/f[v]^n /; 2384TrigQ[f] && TrigQ[g] && f[v]===1/g[v] && RationalQ[m] && IntegerQ[n] 2385 2386DistSimp[u_] := u *) 2387 2388 2389(* If u (x) is equivalent to an expression of the form f (a+b*x) and not the case that a==0 and 2390 b==1, FunctionOfLinear[u,x] returns the list {f (x),a,b}; else it returns False. *) 2391FunctionOfLinear[u_,x_Symbol] := 2392 Module[{lst=FunctionOfLinear[u,False,False,x,False]}, 2393 If[FalseQ[lst] || FalseQ[lst[[1]]] || lst[[1]]===0 && lst[[2]]===1, 2394 False, 2395 {FunctionOfLinearSubst[u,lst[[1]],lst[[2]],x],lst[[1]],lst[[2]]}]] 2396 2397 2398FunctionOfLinear[u_,a_,b_,x_,flag_] := 2399 If[FreeQ[u,x], 2400 {a,b}, 2401 If[CalculusQ[u], 2402 False, 2403 If[LinearQ[u,x], 2404 If[FalseQ[a], 2405 {Coefficient[u,x,0],Coefficient[u,x,1]}, 2406 Module[{lst=CommonFactors[{b,Coefficient[u,x,1]}]}, 2407 If[ZeroQ[Coefficient[u,x,0]] && Not[flag], 2408 {0,lst[[1]]}, 2409 If[ZeroQ[b*Coefficient[u,x,0]-a*Coefficient[u,x,1]], 2410 {a/lst[[2]],lst[[1]]}, 2411 {0,1}]]]], 2412 If[PowerQ[u] && FreeQ[u[[1]],x], 2413 FunctionOfLinear[Log[u[[1]]]*u[[2]],a,b,x,False], 2414 Module[{lst}, 2415 If[ProductQ[u] && NonzeroQ[(lst=MonomialFactor[u,x])[[1]]], 2416 If[False && IntegerQ[lst[[1]]] && lst[[1]]!=-1 && FreeQ[lst[[2]],x], 2417 If[RationalQ[LeadFactor[lst[[2]]]] && LeadFactor[lst[[2]]]<0, 2418 FunctionOfLinear[DivideDegreesOfFactors[-lst[[2]],lst[[1]]]*x,a,b,x,False], 2419 FunctionOfLinear[DivideDegreesOfFactors[lst[[2]],lst[[1]]]*x,a,b,x,False]], 2420 False], 2421 lst={a,b}; 2422 Catch[ 2423 Scan[Function[lst=FunctionOfLinear[#,lst[[1]],lst[[2]],x,SumQ[u]]; 2424 If[FalseQ[lst],Throw[False]]],u]; 2425 lst]]]]]]] 2426 2427 2428FunctionOfLinearSubst[u_,a_,b_,x_] := 2429 If[FreeQ[u,x], 2430 u, 2431 If[LinearQ[u,x], 2432 Module[{tmp=Coefficient[u,x,1]}, 2433 tmp=If[tmp===b, 1, tmp/b]; 2434 Coefficient[u,x,0]-a*tmp+tmp*x], 2435 If[PowerQ[u] && FreeQ[u[[1]],x], 2436 E^FullSimplify[FunctionOfLinearSubst[Log[u[[1]]]*u[[2]],a,b,x]], 2437 Module[{lst}, 2438 If[ProductQ[u] && NonzeroQ[(lst=MonomialFactor[u,x])[[1]]], 2439 If[RationalQ[LeadFactor[lst[[2]]]] && LeadFactor[lst[[2]]]<0, 2440 -FunctionOfLinearSubst[DivideDegreesOfFactors[-lst[[2]],lst[[1]]]*x,a,b,x]^lst[[1]], 2441 FunctionOfLinearSubst[DivideDegreesOfFactors[lst[[2]],lst[[1]]]*x,a,b,x]^lst[[1]]], 2442 Map[Function[FunctionOfLinearSubst[#,a,b,x]],u]]]]]] 2443 2444 2445(* DivideDegreesOfFactors[u,n] returns the product of the base of the factors of u raised to 2446 the degree of the factors divided by n. *) 2447DivideDegreesOfFactors[u_,n_] := 2448 If[ProductQ[u], 2449 Map[Function[LeadBase[#]^(LeadDegree[#]/n)],u], 2450 LeadBase[u]^(LeadDegree[u]/n)] 2451 2452 2453(* If u is a function of an inverse linear binomial of the form 1/(a+b*x), 2454 FunctionOfInverseLinear[u,x] returns the list {a,b}; else it returns False. *) 2455FunctionOfInverseLinear[u_,x_Symbol] := 2456 FunctionOfInverseLinear[u,Null,x] 2457 2458FunctionOfInverseLinear[u_,lst_,x_] := 2459 If[FreeQ[u,x], 2460 lst, 2461 If[u===x, 2462 False, 2463 If[QuotientOfLinearsQ[u,x], 2464 Module[{tmp=Drop[QuotientOfLinearsParts[u,x],2]}, 2465 If[tmp[[2]]===0, 2466 False, 2467 If[lst===Null, 2468 tmp, 2469 If[ZeroQ[lst[[1]]*tmp[[2]]-lst[[2]]*tmp[[1]]], 2470 lst, 2471 False]]]], 2472 If[CalculusQ[u], 2473 False, 2474 Module[{tmp=lst},Catch[ 2475 Scan[Function[If[FalseQ[tmp=FunctionOfInverseLinear[#,tmp,x]],Throw[False]]],u]; 2476 tmp]]]]]] 2477 2478 2479(* If u is a function of f^(a+b*x), FunctionOfExponentialOfLinear[u,x] returns the list {v,a,b,f} 2480 where v of f^(a+b*x) equals u; else it returns False. *) 2481FunctionOfExponentialOfLinear[u_,x_Symbol] := 2482 Module[{lst=FunctionOfExponentialOfLinear[u,x,False,False,False],a,b,f}, 2483 If[FalseQ[lst] || FalseQ[lst[[1]]], 2484 False, 2485 a=lst[[1]]; 2486 b=lst[[2]]; 2487 f=lst[[3]]; 2488 ( If[MatchQ[u,v_*g_^(c_.+d_*x) /; FreeQ[{c,d,g},x] && NumericFactor[d]<0] && NumericFactor[b]>0, 2489 a=-a; 2490 b=-b] ); 2491 {FunctionOfExponentialOfLinearSubst[u,a,b,f,x],a,b,f}]] 2492 2493 2494(* If u is a function of f^(a+b*x), FunctionOfExponentialOfLinear[u,x,False,False,False] 2495 returns the list {a, b, f}; else it returns False. *) 2496FunctionOfExponentialOfLinear[u_,x_,a_,b_,f_] := 2497 If[FreeQ[u,x], 2498 {a,b,f}, 2499 If[u===x || CalculusQ[u], 2500 False, 2501 If[PowerQ[u] && FreeQ[u[[1]],x] && LinearQ[u[[2]],x], 2502 FunctionOfExponentialOfLinearAux[a,b,f,Coefficient[u[[2]],x,0],Coefficient[u[[2]],x,1],u[[1]]], 2503 If[HyperbolicQ[u] && LinearQ[u[[1]],x], 2504 FunctionOfExponentialOfLinearAux[a,b,f,Coefficient[u[[1]],x,0],Coefficient[u[[1]],x,1],E], 2505 Module[{lst}, 2506 If[PowerQ[u] && FreeQ[u[[1]],x] && SumQ[u[[2]]], 2507 lst=FunctionOfExponentialOfLinear[u[[1]]^First[u[[2]]],x,a,b,f]; 2508 If[FalseQ[lst], 2509 False, 2510 FunctionOfExponentialOfLinear[u[[1]]^Rest[u[[2]]],x,lst[[1]],lst[[2]],lst[[3]]]], 2511 lst={a,b,f}; 2512 Catch[Scan[Function[ 2513 lst=FunctionOfExponentialOfLinear[#,x,lst[[1]],lst[[2]],lst[[3]]]; 2514 If[FalseQ[lst],Throw[False]]],u]; 2515 lst]]]]]]] 2516 2517 2518FunctionOfExponentialOfLinearAux[a_,b_,f_,c_,d_,g_] := 2519 If[FalseQ[a], 2520 {c,d,g}, 2521 If[ZeroQ[Log[f]*NonnumericFactors[b]-Log[g]*NonnumericFactors[d]], 2522 Module[{gcd=GCD[NumericFactor[b],NumericFactor[d]]}, 2523 ( If[NumericFactor[b]<0 && NumericFactor[d]<0, 2524 gcd=-gcd] ); 2525 If[gcd==NumericFactor[b], 2526 {a,b,f}, 2527 If[gcd==NumericFactor[d], 2528 {c,d,g}, 2529 {0,gcd*NonnumericFactors[b],f}]]], 2530 False]] 2531 2532 2533(* u is a function of f^(a+b*x). FunctionOfExponentialOfLinearSubst[u,a,b,f,x] returns u 2534 with f^(a+b*x) replaced by x. *) 2535FunctionOfExponentialOfLinearSubst[u_,a_,b_,f_,x_] := 2536 If[FreeQ[u,x], 2537 u, 2538 If[PowerQ[u] && FreeQ[u[[1]],x] && LinearQ[u[[2]],x], 2539 Module[{c,d,g}, 2540 c=Coefficient[u[[2]],x,0]; 2541 d=Coefficient[u[[2]],x,1]; 2542 g=u[[1]]; 2543 g^(c-a*d/b)*x^(d*Log[g]/(b*Log[f]))], 2544 If[HyperbolicQ[u] && LinearQ[u[[1]],x], 2545 Module[{c,d,tmp}, 2546 c=Coefficient[u[[1]],x,0]; 2547 d=Coefficient[u[[1]],x,1]; 2548 tmp=E^(c-a*d/b)*x^(d/(b*Log[f])); 2549 If[SinhQ[u], 2550 tmp/2-1/(2*tmp), 2551 If[CoshQ[u], 2552 tmp/2+1/(2*tmp), 2553 If[TanhQ[u], 2554 (tmp-1/tmp)/(tmp+1/tmp), 2555 If[CothQ[u], 2556 (tmp+1/tmp)/(tmp-1/tmp), 2557 If[SechQ[u], 2558 2/(tmp+1/tmp), 2559 2/(tmp-1/tmp)]]]]]], 2560 If[PowerQ[u] && FreeQ[u[[1]],x] && SumQ[u[[2]]], 2561 FunctionOfExponentialOfLinearSubst[u[[1]]^First[u[[2]]],a,b,f,x]* 2562 FunctionOfExponentialOfLinearSubst[u[[1]]^Rest[u[[2]]],a,b,f,x], 2563 Map[Function[FunctionOfExponentialOfLinearSubst[#,a,b,f,x]],u]]]]] 2564 2565 2566(* If u is a function of trig functions of a linear function of x, 2567 FunctionOfTrigOfLinearQ[u,x] returns True; else it returns False. *) 2568FunctionOfTrigOfLinearQ[u_,x_Symbol] := 2569 (* Not[MatchQ[u, (c_.*f_[a_.+b_.*x])^p_. /; FreeQ[{a,b,c,p},x] && MemberQ[{Sin,Cos,Sec,Csc},f]]] && *) 2570 Not[MemberQ[{Null, False}, FunctionOfTrig[u,Null,x]]] && 2571 RecognizedFunctionOfTrigQ[SubstInertTrigFunction[u,x],x] 2572 2573(* If u is a function of trig functions of v where v is a linear function of x, 2574 FunctionOfTrig[u,x] returns v; else it returns False. *) 2575FunctionOfTrig[u_,x_Symbol] := 2576 Module[{v=FunctionOfTrig[u,Null,x]}, 2577 If[v===Null, False, v]] 2578 2579FunctionOfTrig[u_,v_,x_] := 2580 If[AtomQ[u], 2581 If[u===x, 2582 False, 2583 v], 2584 If[TrigQ[u] && LinearQ[u[[1]],x], 2585 If[v===Null, 2586 u[[1]], 2587 Module[{a=Coefficient[v,x,0],b=Coefficient[v,x,1], 2588 c=Coefficient[u[[1]],x,0],d=Coefficient[u[[1]],x,1]}, 2589 If[ZeroQ[a*d-b*c] && RationalQ[b/d], 2590 a/Numerator[b/d]+b*x/Numerator[b/d], 2591 False]]], 2592 If[CalculusQ[u], 2593 False, 2594 Module[{w=v},Catch[ 2595 Scan[Function[If[FalseQ[w=FunctionOfTrig[#,w,x]],Throw[False]]],u]; 2596 w]]]]] 2597 2598 2599(* u is a function of the inert trig functions (sin, csc and tan) of x. 2600If u can be put in the form f[c+d*x]^m*(A+B*g[c+d*x]+C*g[c+d*x]^2)*(a+b*g[c+d*x])^n 2601RecognizedFunctionOfTrigQ[u,x] returns True; else it returns False. *) 2602RecognizedFunctionOfTrigQ[u_,x_Symbol] := 2603 MatchQ[u, (a_.+b_.*f_[c_.+d_.*x])^n_. /; 2604 FreeQ[{a,b,c,d,n},x] && InertTrigQ[f]] || 2605 MatchQ[u, (A_.+B_.*f_[c_.+d_.*x])*(a_.+b_.*g_[c_.+d_.*x])^n_. /; 2606 FreeQ[{a,b,c,d,A,B,n},x] && InertTrigQ[f,g]] || 2607 MatchQ[u, (A_.+C_.*f_[c_.+d_.*x]^2)*(a_.+b_.*g_[c_.+d_.*x])^n_. /; 2608 FreeQ[{a,b,c,d,A,C,n},x] && InertTrigQ[f,g]] || 2609 MatchQ[u, (A_.+B_.*f_[c_.+d_.*x]+C_.*f_[c_.+d_.*x]^2)*(a_.+b_.*g_[c_.+d_.*x])^n_. /; 2610 FreeQ[{a,b,c,d,A,B,C,n},x] && InertTrigQ[f,g]] || 2611 MatchQ[u, (A_.+B_.*sin[c_.+d_.*x]+C_.*csc[c_.+d_.*x])*(a_.+b_.*g_[c_.+d_.*x])^n_. /; 2612 FreeQ[{a,b,c,d,A,B,C,n},x] && InertTrigQ[g]] || 2613 2614 MatchQ[u, f_[c_.+d_.*x]^m_.*(A_.+B_.*g_[c_.+d_.*x]) /; 2615 FreeQ[{c,d,A,B,m},x] && InertTrigQ[f,g]] || 2616 MatchQ[u, f_[c_.+d_.*x]^m_.*(A_.+C_.*g_[c_.+d_.*x]^2) /; 2617 FreeQ[{c,d,A,C,m},x] && InertTrigQ[f,g]] || 2618 MatchQ[u, f_[c_.+d_.*x]^m_.*(A_.+B_.*g_[c_.+d_.*x]+C_.*g_[c_.+d_.*x]^2) /; 2619 FreeQ[{c,d,A,B,C,m},x] && InertTrigQ[f,g]] || 2620 MatchQ[u, f_[c_.+d_.*x]^m_.*(A_.+B_.*sin[c_.+d_.*x]+C_.*csc[c_.+d_.*x]) /; 2621 FreeQ[{c,d,A,B,C,m},x] && InertTrigQ[f]] || 2622 2623 MatchQ[u, f_[c_.+d_.*x]^m_.*(a_.+b_.*g_[c_.+d_.*x])^n_. /; 2624 FreeQ[{a,b,c,d,m,n},x] && InertTrigQ[f,g]] || 2625 MatchQ[u, f_[c_.+d_.*x]^m_.*(A_.+B_.*g_[c_.+d_.*x])*(a_.+b_.*h_[c_.+d_.*x])^n_. /; 2626 FreeQ[{a,b,c,d,A,B,m,n},x] && InertTrigQ[f,g,h]] || 2627 MatchQ[u, f_[c_.+d_.*x]^m_.*(A_.+C_.*g_[c_.+d_.*x]^2)*(a_.+b_.*h_[c_.+d_.*x])^n_. /; 2628 FreeQ[{a,b,c,d,A,C,m,n},x] && InertTrigQ[f,g,h]] || 2629 MatchQ[u, f_[c_.+d_.*x]^m_.*(A_.+B_.*g_[c_.+d_.*x]+C_.*g_[c_.+d_.*x]^2)*(a_.+b_.*h_[c_.+d_.*x])^n_. /; 2630 FreeQ[{a,b,c,d,A,B,C,m,n},x] && InertTrigQ[f,g,h]] || 2631 MatchQ[u, f_[c_.+d_.*x]^m_.*(A_.+B_.*sin[c_.+d_.*x]+C_.*csc[c_.+d_.*x])*(a_.+b_.*g_[c_.+d_.*x])^n_. /; 2632 FreeQ[{a,b,c,d,A,B,C,m,n},x] && InertTrigQ[f,g]] || 2633 2634 MatchQ[u, Sqrt[a_+b_.*csc[c_.+d_.*x]]/(A_+B_.*sin[c_.+d_.*x]) /; 2635 FreeQ[{a,b,c,d,A,B},x] && ZeroQ[B-A] && NonzeroQ[a^2-b^2]] || 2636 MatchQ[u, Sqrt[a_+b_.*sin[c_.+d_.*x]]/(Sqrt[sin[c_.+d_.*x]]*(A_+B_.*sin[c_.+d_.*x])) /; 2637 FreeQ[{a,b,c,d,A,B},x] && ZeroQ[B-A] && NonzeroQ[a^2-b^2]] 2638 2639 2640InertTrigQ[f_] := f===sin || f===csc || f===tan 2641 2642InertTrigQ[f_,g_] := 2643 If[f===g, 2644 InertTrigQ[f], 2645 f===sin && g===csc || f===csc && g===sin] 2646 2647InertTrigQ[f_,g_,h_] := InertTrigQ[f,g] && InertTrigQ[g,h] 2648 2649 2650(* If u is a function of hyperbolic trig functions of v where v is linear in x, 2651 FunctionOfHyperbolic[u,x] returns v; else it returns False. *) 2652FunctionOfHyperbolic[u_,x_Symbol] := 2653 Module[{v=FunctionOfHyperbolic[u,Null,x]}, 2654 If[v===Null, False, v]] 2655 2656FunctionOfHyperbolic[u_,v_,x_] := 2657 If[AtomQ[u], 2658 If[u===x, 2659 False, 2660 v], 2661 If[HyperbolicQ[u] && LinearQ[u[[1]],x], 2662 If[v===Null, 2663 u[[1]], 2664 Module[{a=Coefficient[v,x,0],b=Coefficient[v,x,1], 2665 c=Coefficient[u[[1]],x,0],d=Coefficient[u[[1]],x,1]}, 2666 If[ZeroQ[a*d-b*c] && RationalQ[b/d], 2667 a/Numerator[b/d]+b*x/Numerator[b/d], 2668 False]]], 2669 If[CalculusQ[u], 2670 False, 2671 Module[{w=v},Catch[ 2672 Scan[Function[If[FalseQ[w=FunctionOfHyperbolic[#,w,x]],Throw[False]]],u]; 2673 w]]]]] 2674 2675 2676(* v is a function of x. 2677 If u is a function of v, FunctionOfQ[v,u,x] returns True; else it returns False. *) 2678FunctionOfQ[v_,u_,x_Symbol,PureFlag_:False] := 2679 If[FreeQ[u,x], 2680 False, 2681 If[AtomQ[v], 2682 True, 2683 If[PowerQ[v] && FreeQ[v[[2]],x] (* && NonzeroQ[v[[2]]+1] *), 2684 FunctionOfPowerQ[u,v[[1]],v[[2]],x], 2685 If[PureFlag, 2686 If[SinQ[v] || CscQ[v], 2687 PureFunctionOfSinQ[u,v[[1]],x], 2688 If[CosQ[v] || SecQ[v], 2689 PureFunctionOfCosQ[u,v[[1]],x], 2690 If[TanQ[v], 2691 PureFunctionOfTanQ[u,v[[1]],x], 2692 If[CotQ[v], 2693 PureFunctionOfCotQ[u,v[[1]],x], 2694 If[SinhQ[v] || CschQ[v], 2695 PureFunctionOfSinhQ[u,v[[1]],x], 2696 If[CoshQ[v] || SechQ[v], 2697 PureFunctionOfCoshQ[u,v[[1]],x], 2698 If[TanhQ[v], 2699 PureFunctionOfTanhQ[u,v[[1]],x], 2700 If[CothQ[v], 2701 PureFunctionOfCothQ[u,v[[1]],x], 2702 FunctionOfExpnQ[u,v,x]]]]]]]]], 2703 If[SinQ[v] || CscQ[v], 2704 FunctionOfSinQ[u,v[[1]],x], 2705 If[CosQ[v] || SecQ[v], 2706 FunctionOfCosQ[u,v[[1]],x], 2707 If[TanQ[v] || CotQ[v], 2708 FunctionOfTanQ[u,v[[1]],x], 2709 If[SinhQ[v] || CschQ[v], 2710 FunctionOfSinhQ[u,v[[1]],x], 2711 If[CoshQ[v] || SechQ[v], 2712 FunctionOfCoshQ[u,v[[1]],x], 2713 If[TanhQ[v] || CothQ[v], 2714 FunctionOfTanhQ[u,v[[1]],x], 2715 FunctionOfExpnQ[u,v,x]]]]]]]]]]] 2716 2717 2718FunctionOfExpnQ[u_,v_,x_] := 2719 If[u===v, 2720 True, 2721 If[AtomQ[u], 2722 u=!=x, 2723 If[CalculusQ[u], 2724 False, 2725 Catch[Scan[Function[If[FunctionOfExpnQ[#,v,x],Null,Throw[False]]],u];True]]]] 2726 2727 2728FunctionOfPowerQ[u_,bas_,deg_,x_] := 2729 If[AtomQ[u], 2730 u=!=x, 2731 If[CalculusQ[u], 2732 False, 2733 If[PowerQ[u] && ZeroQ[u[[1]]-bas] && FreeQ[u[[2]],x], 2734 If[RationalQ[deg], 2735 If[RationalQ[u[[2]]], 2736 IntegerQ[u[[2]]/deg] && (deg>0 || u[[2]]<0), 2737 False], 2738 IntegerQ[Simplify[u[[2]]/deg]]], 2739 Catch[Scan[Function[If[FunctionOfPowerQ[#,bas,deg,x],Null,Throw[False]]],u];True]]]] 2740 2741 2742(* If func[w]^m is a factor of u where m is odd and w is an integer multiple of v, 2743 FindTrigFactor[func1,func2,u,v,True] returns the list {w,u/func[w]^n}; else it returns False. *) 2744(* If func[w]^m is a factor of u where m is odd and w is an integer multiple of v not equal to v, 2745 FindTrigFactor[func1,func2,u,v,False] returns the list {w,u/func[w]^n}; else it returns False. *) 2746FindTrigFactor[func1_,func2_,u_,v_,flag_] := 2747 If[u===1, 2748 False, 2749 If[(Head[LeadBase[u]]===func1 || Head[LeadBase[u]]===func2) && 2750 OddQ[LeadDegree[u]] && 2751 IntegerQuotientQ[LeadBase[u][[1]],v] && 2752 (flag || NonzeroQ[LeadBase[u][[1]]-v]), 2753 {LeadBase[u][[1]], RemainingFactors[u]}, 2754 Module[{lst=FindTrigFactor[func1,func2,RemainingFactors[u],v,flag]}, 2755 If[FalseQ[lst], 2756 False, 2757 {lst[[1]], LeadFactor[u]*lst[[2]]}]]]] 2758 2759 2760(* If u is a pure function of Sin[v] and/or Csc[v], PureFunctionOfSinQ[u,v,x] returns True; 2761 else it returns False. *) 2762PureFunctionOfSinQ[u_,v_,x_] := 2763 If[AtomQ[u], 2764 u=!=x, 2765 If[CalculusQ[u], 2766 False, 2767 If[TrigQ[u] && ZeroQ[u[[1]]-v], 2768 SinQ[u] || CscQ[u], 2769 Catch[Scan[Function[If[Not[PureFunctionOfSinQ[#,v,x]],Throw[False]]],u];True]]]] 2770 2771 2772(* If u is a pure function of Cos[v] and/or Sec[v], PureFunctionOfCosQ[u,v,x] returns True; 2773 else it returns False. *) 2774PureFunctionOfCosQ[u_,v_,x_] := 2775 If[AtomQ[u], 2776 u=!=x, 2777 If[CalculusQ[u], 2778 False, 2779 If[TrigQ[u] && ZeroQ[u[[1]]-v], 2780 CosQ[u] || SecQ[u], 2781 Catch[Scan[Function[If[Not[PureFunctionOfCosQ[#,v,x]],Throw[False]]],u];True]]]] 2782 2783 2784(* If u is a pure function of Tan[v] and/or Cot[v], PureFunctionOfTanQ[u,v,x] returns True; 2785 else it returns False. *) 2786PureFunctionOfTanQ[u_,v_,x_] := 2787 If[AtomQ[u], 2788 u=!=x, 2789 If[CalculusQ[u], 2790 False, 2791 If[TrigQ[u] && ZeroQ[u[[1]]-v], 2792 TanQ[u] || CotQ[u], 2793 Catch[Scan[Function[If[Not[PureFunctionOfTanQ[#,v,x]],Throw[False]]],u];True]]]] 2794 2795 2796(* If u is a pure function of Cot[v], PureFunctionOfCotQ[u,v,x] returns True; 2797 else it returns False. *) 2798PureFunctionOfCotQ[u_,v_,x_] := 2799 If[AtomQ[u], 2800 u=!=x, 2801 If[CalculusQ[u], 2802 False, 2803 If[TrigQ[u] && ZeroQ[u[[1]]-v], 2804 CotQ[u], 2805 Catch[Scan[Function[If[Not[PureFunctionOfCotQ[#,v,x]],Throw[False]]],u];True]]]] 2806 2807 2808(* If u is a function of Sin[v], FunctionOfSinQ[u,v,x] returns True; else it returns False. *) 2809FunctionOfSinQ[u_,v_,x_] := 2810 If[AtomQ[u], 2811 u=!=x, 2812 If[CalculusQ[u], 2813 False, 2814 If[TrigQ[u] && IntegerQuotientQ[u[[1]],v], 2815 If[OddQuotientQ[u[[1]],v], 2816(* Basis: If m odd, Sin[m*v]^n is a function of Sin[v]. *) 2817 SinQ[u] || CscQ[u], 2818(* Basis: If m even, Cos[m*v]^n is a function of Sin[v]. *) 2819 CosQ[u] || SecQ[u]], 2820 If[IntegerPowerQ[u] && TrigQ[u[[1]]] && IntegerQuotientQ[u[[1,1]],v], 2821 If[EvenQ[u[[2]]], 2822(* Basis: If m integer and n even, Trig[m*v]^n is a function of Sin[v]. *) 2823 True, 2824 FunctionOfSinQ[u[[1]],v,x]], 2825 If[ProductQ[u], 2826 If[CosQ[u[[1]]] && SinQ[u[[2]]] && ZeroQ[u[[1,1]]-v/2] && ZeroQ[u[[2,1]]-v/2], 2827 FunctionOfSinQ[Drop[u,2],v,x], 2828 Module[{lst}, 2829 lst=FindTrigFactor[Sin,Csc,u,v,False]; 2830 If[NotFalseQ[lst] && EvenQuotientQ[lst[[1]],v], 2831(* Basis: If m even and n odd, Sin[m*v]^n == Cos[v]*u where u is a function of Sin[v]. *) 2832 FunctionOfSinQ[Cos[v]*lst[[2]],v,x], 2833 lst=FindTrigFactor[Cos,Sec,u,v,False]; 2834 If[NotFalseQ[lst] && OddQuotientQ[lst[[1]],v], 2835(* Basis: If m odd and n odd, Cos[m*v]^n == Cos[v]*u where u is a function of Sin[v]. *) 2836 FunctionOfSinQ[Cos[v]*lst[[2]],v,x], 2837 lst=FindTrigFactor[Tan,Cot,u,v,True]; 2838 If[NotFalseQ[lst], 2839(* Basis: If m integer and n odd, Tan[m*v]^n == Cos[v]*u where u is a function of Sin[v]. *) 2840 FunctionOfSinQ[Cos[v]*lst[[2]],v,x], 2841 Catch[Scan[Function[If[Not[FunctionOfSinQ[#,v,x]],Throw[False]]],u];True]]]]]], 2842 Catch[Scan[Function[If[Not[FunctionOfSinQ[#,v,x]],Throw[False]]],u];True]]]]]] 2843 2844 2845(* If u is a function of Cos[v], FunctionOfCosQ[u,v,x] returns True; else it returns False. *) 2846FunctionOfCosQ[u_,v_,x_] := 2847 If[AtomQ[u], 2848 u=!=x, 2849 If[CalculusQ[u], 2850 False, 2851 If[TrigQ[u] && IntegerQuotientQ[u[[1]],v], 2852(* Basis: If m integer, Cos[m*v]^n is a function of Cos[v]. *) 2853 CosQ[u] || SecQ[u], 2854 If[IntegerPowerQ[u] && TrigQ[u[[1]]] && IntegerQuotientQ[u[[1,1]],v], 2855 If[EvenQ[u[[2]]], 2856(* Basis: If m integer and n even, Trig[m*v]^n is a function of Cos[v]. *) 2857 True, 2858 FunctionOfCosQ[u[[1]],v,x]], 2859 If[ProductQ[u], 2860 Module[{lst}, 2861 lst=FindTrigFactor[Sin,Csc,u,v,False]; 2862 If[NotFalseQ[lst], 2863(* Basis: If m integer and n odd, Sin[m*v]^n == Sin[v]*u where u is a function of Cos[v]. *) 2864 FunctionOfCosQ[Sin[v]*lst[[2]],v,x], 2865 lst=FindTrigFactor[Tan,Cot,u,v,True]; 2866 If[NotFalseQ[lst], 2867(* Basis: If m integer and n odd, Tan[m*v]^n == Sin[v]*u where u is a function of Cos[v]. *) 2868 FunctionOfCosQ[Sin[v]*lst[[2]],v,x], 2869 Catch[Scan[Function[If[Not[FunctionOfCosQ[#,v,x]],Throw[False]]],u];True]]]], 2870 Catch[Scan[Function[If[Not[FunctionOfCosQ[#,v,x]],Throw[False]]],u];True]]]]]] 2871 2872 2873(* If u is a function of the form f[Tan[v],Cot[v]] where f is independent of x, 2874 FunctionOfTanQ[u,v,x] returns True; else it returns False. *) 2875FunctionOfTanQ[u_,v_,x_] := 2876 If[AtomQ[u], 2877 u=!=x, 2878 If[CalculusQ[u], 2879 False, 2880 If[TrigQ[u] && IntegerQuotientQ[u[[1]],v], 2881 TanQ[u] || CotQ[u] || EvenQuotientQ[u[[1]],v], 2882 If[PowerQ[u] && EvenQ[u[[2]]] && TrigQ[u[[1]]] && IntegerQuotientQ[u[[1,1]],v], 2883 True, 2884 If[ProductQ[u], 2885 Module[{lst=ReapList[Scan[Function[If[Not[FunctionOfTanQ[#,v,x]],Sow[#]]],u]]}, 2886 If[lst==={}, 2887 True, 2888 Length[lst]==2 && OddTrigPowerQ[lst[[1]],v,x] && OddTrigPowerQ[lst[[2]],v,x]]], 2889 Catch[Scan[Function[If[Not[FunctionOfTanQ[#,v,x]],Throw[False]]],u];True]]]]]] 2890 2891OddTrigPowerQ[u_,v_,x_] := 2892 If[SinQ[u] || CosQ[u] || SecQ[u] || CscQ[u], 2893 OddQuotientQ[u[[1]],v], 2894 If[PowerQ[u], 2895 OddQ[u[[2]]] && OddTrigPowerQ[u[[1]],v,x], 2896 If[ProductQ[u], 2897 Module[{lst=ReapList[Scan[Function[If[Not[FunctionOfTanQ[#,v,x]],Sow[#]]],u]]}, 2898 If[lst==={}, 2899 True, 2900 Length[lst]==1 && OddTrigPowerQ[lst[[1]],v,x]]], 2901(*If[SumQ[u], 2902 Catch[Scan[Function[If[Not[OddTrigPowerQ[#,v,x]],Throw[False]]],u];True], *) 2903 False]]] 2904 2905 2906(* u is a function of the form f[Tan[v],Cot[v]] where f is independent of x. 2907FunctionOfTanWeight[u,v,x] returns a nonnegative number if u is best considered a function 2908of Tan[v]; else it returns a negative number. *) 2909FunctionOfTanWeight[u_,v_,x_] := 2910 If[AtomQ[u], 2911 0, 2912 If[CalculusQ[u], 2913 0, 2914 If[TrigQ[u] && IntegerQuotientQ[u[[1]],v], 2915 If[TanQ[u] && ZeroQ[u[[1]]-v], 2916 1, 2917 If[CotQ[u] && ZeroQ[u[[1]]-v], 2918 -1, 2919 0]], 2920 If[PowerQ[u] && EvenQ[u[[2]]] && TrigQ[u[[1]]] && IntegerQuotientQ[u[[1,1]],v], 2921 If[TanQ[u[[1]]] || CosQ[u[[1]]] || SecQ[u[[1]]], 2922 1, 2923 -1], 2924 If[ProductQ[u], 2925 If[Catch[Scan[Function[If[Not[FunctionOfTanQ[#,v,x]],Throw[False]]],u];True], 2926 Apply[Plus,Map[Function[FunctionOfTanWeight[#,v,x]],Apply[List,u]]], 2927 0], 2928 Apply[Plus,Map[Function[FunctionOfTanWeight[#,v,x]],Apply[List,u]]]]]]]] 2929 2930 2931(* If u (x) is equivalent to an expression of the form f (Sin[v],Cos[v],Tan[v],Cot[v],Sec[v],Csc[v]) 2932 where f is independent of x, FunctionOfTrigQ[u,v,x] returns True; else it returns False. *) 2933FunctionOfTrigQ[u_,v_,x_Symbol] := 2934 If[AtomQ[u], 2935 u=!=x, 2936 If[CalculusQ[u], 2937 False, 2938 If[TrigQ[u] && IntegerQuotientQ[u[[1]],v], 2939 True, 2940 Catch[ 2941 Scan[Function[If[Not[FunctionOfTrigQ[#,v,x]],Throw[False]]],u]; 2942 True]]]] 2943 2944 2945(* If u is a pure function of Sinh[v] and/or Csch[v], PureFunctionOfSinhQ[u,v,x] returns True; 2946 else it returns False. *) 2947PureFunctionOfSinhQ[u_,v_,x_] := 2948 If[AtomQ[u], 2949 u=!=x, 2950 If[CalculusQ[u], 2951 False, 2952 If[HyperbolicQ[u] && ZeroQ[u[[1]]-v], 2953 SinhQ[u] || CschQ[u], 2954 Catch[Scan[Function[If[Not[PureFunctionOfSinhQ[#,v,x]],Throw[False]]],u];True]]]] 2955 2956 2957(* If u is a pure function of Cosh[v] and/or Sech[v], PureFunctionOfCoshQ[u,v,x] returns True; 2958 else it returns False. *) 2959PureFunctionOfCoshQ[u_,v_,x_] := 2960 If[AtomQ[u], 2961 u=!=x, 2962 If[CalculusQ[u], 2963 False, 2964 If[HyperbolicQ[u] && ZeroQ[u[[1]]-v], 2965 CoshQ[u] || SechQ[u], 2966 Catch[Scan[Function[If[Not[PureFunctionOfCoshQ[#,v,x]],Throw[False]]],u];True]]]] 2967 2968 2969(* If u is a pure function of Tanh[v] and/or Coth[v], PureFunctionOfTanhQ[u,v,x] returns True; 2970 else it returns False. *) 2971PureFunctionOfTanhQ[u_,v_,x_] := 2972 If[AtomQ[u], 2973 u=!=x, 2974 If[CalculusQ[u], 2975 False, 2976 If[HyperbolicQ[u] && ZeroQ[u[[1]]-v], 2977 TanhQ[u] || CothQ[u], 2978 Catch[Scan[Function[If[Not[PureFunctionOfTanhQ[#,v,x]],Throw[False]]],u];True]]]] 2979 2980 2981(* If u is a pure function of Coth[v], PureFunctionOfCothQ[u,v,x] returns True; 2982 else it returns False. *) 2983PureFunctionOfCothQ[u_,v_,x_] := 2984 If[AtomQ[u], 2985 u=!=x, 2986 If[CalculusQ[u], 2987 False, 2988 If[HyperbolicQ[u] && ZeroQ[u[[1]]-v], 2989 CothQ[u], 2990 Catch[Scan[Function[If[Not[PureFunctionOfCothQ[#,v,x]],Throw[False]]],u];True]]]] 2991 2992 2993(* If u is a function of Sinh[v], FunctionOfSinhQ[u,v,x] returns True; else it returns False. *) 2994FunctionOfSinhQ[u_,v_,x_] := 2995 If[AtomQ[u], 2996 u=!=x, 2997 If[CalculusQ[u], 2998 False, 2999 If[HyperbolicQ[u] && IntegerQuotientQ[u[[1]],v], 3000 If[OddQuotientQ[u[[1]],v], 3001(* Basis: If m odd, Sinh[m*v]^n is a function of Sinh[v]. *) 3002 SinhQ[u] || CschQ[u], 3003(* Basis: If m even, Cos[m*v]^n is a function of Sinh[v]. *) 3004 CoshQ[u] || SechQ[u]], 3005 If[IntegerPowerQ[u] && HyperbolicQ[u[[1]]] && IntegerQuotientQ[u[[1,1]],v], 3006 If[EvenQ[u[[2]]], 3007(* Basis: If m integer and n even, Hyper[m*v]^n is a function of Sinh[v]. *) 3008 True, 3009 FunctionOfSinhQ[u[[1]],v,x]], 3010 If[ProductQ[u], 3011 If[CoshQ[u[[1]]] && SinhQ[u[[2]]] && ZeroQ[u[[1,1]]-v/2] && ZeroQ[u[[2,1]]-v/2], 3012 FunctionOfSinhQ[Drop[u,2],v,x], 3013 Module[{lst}, 3014 lst=FindTrigFactor[Sinh,Csch,u,v,False]; 3015 If[NotFalseQ[lst] && EvenQuotientQ[lst[[1]],v], 3016(* Basis: If m even and n odd, Sinh[m*v]^n == Cosh[v]*u where u is a function of Sinh[v]. *) 3017 FunctionOfSinhQ[Cosh[v]*lst[[2]],v,x], 3018 lst=FindTrigFactor[Cosh,Sech,u,v,False]; 3019 If[NotFalseQ[lst] && OddQuotientQ[lst[[1]],v], 3020(* Basis: If m odd and n odd, Cosh[m*v]^n == Cosh[v]*u where u is a function of Sinh[v]. *) 3021 FunctionOfSinhQ[Cosh[v]*lst[[2]],v,x], 3022 lst=FindTrigFactor[Tanh,Coth,u,v,True]; 3023 If[NotFalseQ[lst], 3024(* Basis: If m integer and n odd, Tanh[m*v]^n == Cosh[v]*u where u is a function of Sinh[v]. *) 3025 FunctionOfSinhQ[Cosh[v]*lst[[2]],v,x], 3026 Catch[Scan[Function[If[Not[FunctionOfSinhQ[#,v,x]],Throw[False]]],u];True]]]]]], 3027 Catch[Scan[Function[If[Not[FunctionOfSinhQ[#,v,x]],Throw[False]]],u];True]]]]]] 3028 3029 3030(* If u is a function of Cosh[v], FunctionOfCoshQ[u,v,x] returns True; else it returns False. *) 3031FunctionOfCoshQ[u_,v_,x_] := 3032 If[AtomQ[u], 3033 u=!=x, 3034 If[CalculusQ[u], 3035 False, 3036 If[HyperbolicQ[u] && IntegerQuotientQ[u[[1]],v], 3037(* Basis: If m integer, Cosh[m*v]^n is a function of Cosh[v]. *) 3038 CoshQ[u] || SechQ[u], 3039 If[IntegerPowerQ[u] && HyperbolicQ[u[[1]]] && IntegerQuotientQ[u[[1,1]],v], 3040 If[EvenQ[u[[2]]], 3041(* Basis: If m integer and n even, Hyper[m*v]^n is a function of Cosh[v]. *) 3042 True, 3043 FunctionOfCoshQ[u[[1]],v,x]], 3044 If[ProductQ[u], 3045 Module[{lst}, 3046 lst=FindTrigFactor[Sinh,Csch,u,v,False]; 3047 If[NotFalseQ[lst], 3048(* Basis: If m integer and n odd, Sinh[m*v]^n == Sinh[v]*u where u is a function of Cosh[v]. *) 3049 FunctionOfCoshQ[Sinh[v]*lst[[2]],v,x], 3050 lst=FindTrigFactor[Tanh,Coth,u,v,True]; 3051 If[NotFalseQ[lst], 3052(* Basis: If m integer and n odd, Tanh[m*v]^n == Sinh[v]*u where u is a function of Cosh[v]. *) 3053 FunctionOfCoshQ[Sinh[v]*lst[[2]],v,x], 3054 Catch[Scan[Function[If[Not[FunctionOfCoshQ[#,v,x]],Throw[False]]],u];True]]]], 3055 Catch[Scan[Function[If[Not[FunctionOfCoshQ[#,v,x]],Throw[False]]],u];True]]]]]] 3056 3057 3058(* If u is a function of the form f[Tanh[v],Coth[v]] where f is independent of x, 3059 FunctionOfTanhQ[u,v,x] returns True; else it returns False. *) 3060FunctionOfTanhQ[u_,v_,x_] := 3061 If[AtomQ[u], 3062 u=!=x, 3063 If[CalculusQ[u], 3064 False, 3065 If[HyperbolicQ[u] && IntegerQuotientQ[u[[1]],v], 3066 TanhQ[u] || CothQ[u] || EvenQuotientQ[u[[1]],v], 3067 If[PowerQ[u] && EvenQ[u[[2]]] && HyperbolicQ[u[[1]]] && IntegerQuotientQ[u[[1,1]],v], 3068 True, 3069 If[ProductQ[u], 3070 Module[{lst=ReapList[Scan[Function[If[Not[FunctionOfTanhQ[#,v,x]],Sow[#]]],u]]}, 3071 If[lst==={}, 3072 True, 3073 Length[lst]==2 && OddHyperbolicPowerQ[lst[[1]],v,x] && OddHyperbolicPowerQ[lst[[2]],v,x]]], 3074 Catch[Scan[Function[If[Not[FunctionOfTanhQ[#,v,x]],Throw[False]]],u];True]]]]]] 3075 3076OddHyperbolicPowerQ[u_,v_,x_] := 3077 If[SinhQ[u] || CoshQ[u] || SechQ[u] || CschQ[u], 3078 OddQuotientQ[u[[1]],v], 3079 If[PowerQ[u], 3080 OddQ[u[[2]]] && OddHyperbolicPowerQ[u[[1]],v,x], 3081 If[ProductQ[u], 3082 Module[{lst=ReapList[Scan[Function[If[Not[FunctionOfTanhQ[#,v,x]],Sow[#]]],u]]}, 3083 If[lst==={}, 3084 True, 3085 Length[lst]==1 && OddHyperbolicPowerQ[lst[[1]],v,x]]], 3086(*If[SumQ[u], 3087 Catch[Scan[Function[If[Not[OddHyperbolicPowerQ[#,v,x]],Throw[False]]],u];True], *) 3088 False]]] 3089 3090 3091(* u is a function of the form f[Tanh[v],Coth[v]] where f is independent of x. 3092FunctionOfTanhWeight[u,v,x] returns a nonnegative number if u is best considered a function 3093of Tanh[v]; else it returns a negative number. *) 3094FunctionOfTanhWeight[u_,v_,x_] := 3095 If[AtomQ[u], 3096 0, 3097 If[CalculusQ[u], 3098 0, 3099 If[HyperbolicQ[u] && IntegerQuotientQ[u[[1]],v], 3100 If[TanhQ[u] && ZeroQ[u[[1]]-v], 3101 1, 3102 If[CothQ[u] && ZeroQ[u[[1]]-v], 3103 -1, 3104 0]], 3105 If[PowerQ[u] && EvenQ[u[[2]]] && HyperbolicQ[u[[1]]] && IntegerQuotientQ[u[[1,1]],v], 3106 If[TanhQ[u[[1]]] || CoshQ[u[[1]]] || SechQ[u[[1]]], 3107 1, 3108 -1], 3109 If[ProductQ[u], 3110 If[Catch[Scan[Function[If[Not[FunctionOfTanhQ[#,v,x]],Throw[False]]],u];True], 3111 Apply[Plus,Map[Function[FunctionOfTanhWeight[#,v,x]],Apply[List,u]]], 3112 0], 3113 Apply[Plus,Map[Function[FunctionOfTanhWeight[#,v,x]],Apply[List,u]]]]]]]] 3114 3115 3116(* If u (x) is equivalent to a function of the form f (Sinh[v],Cosh[v],Tanh[v],Coth[v],Sech[v],Csch[v]) 3117 where f is independent of x, FunctionOfHyperbolicQ[u,v,x] returns True; else it returns False. *) 3118FunctionOfHyperbolicQ[u_,v_,x_Symbol] := 3119 If[AtomQ[u], 3120 u=!=x, 3121 If[CalculusQ[u], 3122 False, 3123 If[HyperbolicQ[u] && IntegerQuotientQ[u[[1]],v], 3124 True, 3125 Catch[Scan[Function[If[FunctionOfHyperbolicQ[#,v,x],Null,Throw[False]]],u];True]]]] 3126 3127 3128(* If u/v is an integer, IntegerQuotientQ[u,v] returns True; else it returns False. *) 3129IntegerQuotientQ[u_,v_] := 3130 u===v || ZeroQ[u-v] || IntegerQ[u/v] 3131 3132(* If u/v is odd, OddQuotientQ[u,v] returns True; else it returns False. *) 3133OddQuotientQ[u_,v_] := 3134 u===v || ZeroQ[u-v] || OddQ[u/v] 3135 3136(* If u/v is even, EvenQuotientQ[u,v] returns True; else it returns False. *) 3137EvenQuotientQ[u_,v_] := 3138 EvenQ[u/v] 3139 3140 3141(* If all occurrences of x in u (x) are in dense polynomials, FunctionOfDensePolynomialsQ[u,x] 3142 returns True; else it returns False. *) 3143FunctionOfDensePolynomialsQ[u_,x_Symbol] := 3144 If[FreeQ[u,x], 3145 True, 3146 If[PolynomialQ[u,x], 3147 Length[Exponent[u,x,List]]>1, 3148 Catch[ 3149 Scan[Function[If[FunctionOfDensePolynomialsQ[#,x],Null,Throw[False]]],u]; 3150 True]]] 3151 3152 3153(* If u (x) is equivalent to an expression of the form f (Log[a*x^n]), FunctionOfLog[u,x] returns 3154 the list {f (x),a*x^n,n}; else it returns False. *) 3155FunctionOfLog[u_,x_Symbol] := 3156 Module[{lst=FunctionOfLog[u,False,False,x]}, 3157 If[FalseQ[lst] || FalseQ[lst[[2]]], 3158 False, 3159 lst]] 3160 3161 3162FunctionOfLog[u_,v_,n_,x_] := 3163 If[AtomQ[u], 3164 If[u===x, 3165 False, 3166 {u,v,n}], 3167 If[CalculusQ[u], 3168 False, 3169 Module[{lst}, 3170 If[LogQ[u] && NotFalseQ[lst=BinomialTest[u[[1]],x]] && ZeroQ[lst[[1]]], 3171 If[FalseQ[v] || u[[1]]===v, 3172 {x,u[[1]],lst[[3]]}, 3173 False], 3174 lst={0,v,n}; 3175 Catch[ 3176 {Map[Function[lst=FunctionOfLog[#,lst[[2]],lst[[3]],x]; 3177 If[FalseQ[lst],Throw[False],lst[[1]]]], 3178 u],lst[[2]],lst[[3]]}]]]]] 3179 3180 3181(* If m is an integer, u is an expression of the form f[(c*x)^n] and g=GCD[m,n]>1, 3182 PowerVariableExpn[u,m,x] returns the list {x^(m/g)*f[(c*x)^(n/g)],g,c}; else it returns False. *) 3183PowerVariableExpn[u_,m_,x_Symbol] := 3184 If[IntegerQ[m], 3185 Module[{lst=PowerVariableDegree[u,m,1,x]}, 3186 If[FalseQ[lst], 3187 False, 3188 {x^(m/lst[[1]])*PowerVariableSubst[u,lst[[1]],x], lst[[1]], lst[[2]]}]], 3189 False] 3190 3191 3192PowerVariableDegree[u_,m_,c_,x_Symbol] := 3193 If[FreeQ[u,x], 3194 {m, c}, 3195 If[AtomQ[u] || CalculusQ[u], 3196 False, 3197 If[PowerQ[u] && FreeQ[u[[1]]/x,x], 3198 If[ZeroQ[m] || m===u[[2]] && c===u[[1]]/x, 3199 {u[[2]], u[[1]]/x}, 3200 If[IntegerQ[u[[2]]] && IntegerQ[m] && GCD[m,u[[2]]]>1 && c===u[[1]]/x, 3201 {GCD[m,u[[2]]], c}, 3202 False]], 3203 Catch[Module[{lst={m, c}}, 3204 Scan[Function[lst=PowerVariableDegree[#,lst[[1]],lst[[2]],x];If[FalseQ[lst],Throw[False]]],u]; 3205 lst]]]]] 3206 3207 3208PowerVariableSubst[u_,m_,x_Symbol] := 3209 If[FreeQ[u,x] || AtomQ[u] ||CalculusQ[u], 3210 u, 3211 If[PowerQ[u] && FreeQ[u[[1]]/x,x], 3212 x^(u[[2]]/m), 3213 Map[Function[PowerVariableSubst[#,m,x]],u]]] 3214 3215 3216(* 3217Euler substitution #2: 3218 If u is an expression of the form f (Sqrt[a+b*x+c*x^2],x), f (x,x) is a rational function, and 3219 PosQ[c], FunctionOfSquareRootOfQuadratic[u,x] returns the 3-element list { 3220 f ((a*Sqrt[c]+b*x+Sqrt[c]*x^2)/(b+2*Sqrt[c]*x),(-a+x^2)/(b+2*Sqrt[c]*x))* 3221 (a*Sqrt[c]+b*x+Sqrt[c]*x^2)/(b+2*Sqrt[c]*x)^2, 3222 Sqrt[c]*x+Sqrt[a+b*x+c*x^2], 2 }; 3223 3224Euler substitution #1: 3225 If u is an expression of the form f (Sqrt[a+b*x+c*x^2],x), f (x,x) is a rational function, and 3226 PosQ[a], FunctionOfSquareRootOfQuadratic[u,x] returns the two element list { 3227 f ((c*Sqrt[a]-b*x+Sqrt[a]*x^2)/(c-x^2),(-b+2*Sqrt[a]*x)/(c-x^2))* 3228 (c*Sqrt[a]-b*x+Sqrt[a]*x^2)/(c-x^2)^2, 3229 (-Sqrt[a]+Sqrt[a+b*x+c*x^2])/x, 1 }; 3230 3231Euler substitution #3: 3232 If u is an expression of the form f (Sqrt[a+b*x+c*x^2],x), f (x,x) is a rational function, and 3233 NegQ[a] and NegQ[c], FunctionOfSquareRootOfQuadratic[u,x] returns the two element list { 3234 -Sqrt[b^2-4*a*c]* 3235 f (-Sqrt[b^2-4*a*c]*x/(c-x^2),-(b*c+c*Sqrt[b^2-4*a*c]+(-b+Sqrt[b^2-4*a*c])*x^2)/(2*c*(c-x^2)))* 3236 x/(c-x^2)^2, 3237 2*c*Sqrt[a+b*x+c*x^2]/(b-Sqrt[b^2-4*a*c]+2*c*x), 3 }; 3238 3239 else it returns False. *) 3240 3241FunctionOfSquareRootOfQuadratic[u_,x_Symbol] := 3242 If[MatchQ[u,x^m_.*(a_+b_.*x^n_.)^p_ /; FreeQ[{a,b,m,n,p},x]], 3243 False, 3244 Module[{tmp=FunctionOfSquareRootOfQuadratic[u,False,x]}, 3245 If[FalseQ[tmp] || FalseQ[tmp[[1]]], 3246 False, 3247 tmp=tmp[[1]]; 3248 Module[{a=Coefficient[tmp,x,0],b=Coefficient[tmp,x,1],c=Coefficient[tmp,x,2],sqrt,q,r}, 3249 If[ZeroQ[a] && ZeroQ[b] || ZeroQ[b^2-4*a*c], 3250 False, 3251 If[PosQ[c], 3252 sqrt=Rt[c,2]; 3253 q=a*sqrt+b*x+sqrt*x^2; 3254 r=b+2*sqrt*x; 3255 {Simplify[SquareRootOfQuadraticSubst[u,q/r,(-a+x^2)/r,x]*q/r^2], 3256 Simplify[sqrt*x+Sqrt[tmp]], 3257 2}, 3258 If[PosQ[a], 3259 sqrt=Rt[a,2]; 3260 q=c*sqrt-b*x+sqrt*x^2; 3261 r=c-x^2; 3262 {Simplify[SquareRootOfQuadraticSubst[u,q/r,(-b+2*sqrt*x)/r,x]*q/r^2], 3263 Simplify[(-sqrt+Sqrt[tmp])/x], 3264 1}, 3265 sqrt=Rt[b^2-4*a*c,2]; 3266 r=c-x^2; 3267 {Simplify[-sqrt*SquareRootOfQuadraticSubst[u,-sqrt*x/r,-(b*c+c*sqrt+(-b+sqrt)*x^2)/(2*c*r),x]*x/r^2], 3268 FullSimplify[2*c*Sqrt[tmp]/(b-sqrt+2*c*x)], 3269 3}]]]]]]] 3270 3271 3272FunctionOfSquareRootOfQuadratic[u_,v_,x_Symbol] := 3273 If[AtomQ[u] || FreeQ[u,x], 3274 {v}, 3275 If[PowerQ[u] && FreeQ[u[[2]],x], 3276 If[FractionQ[u[[2]]] && Denominator[u[[2]]]==2 && PolynomialQ[u[[1]],x] && Exponent[u[[1]],x]==2, 3277 If[(FalseQ[v] || u[[1]]===v), 3278 {u[[1]]}, 3279 False], 3280 FunctionOfSquareRootOfQuadratic[u[[1]],v,x]], 3281 If[ProductQ[u] || SumQ[u], 3282 Catch[Module[{lst={v}}, 3283 Scan[Function[lst=FunctionOfSquareRootOfQuadratic[#,lst[[1]],x];If[FalseQ[lst],Throw[False]]],u]; 3284 lst]], 3285 False]]] 3286 3287 3288(* SquareRootOfQuadraticSubst[u,vv,xx,x] returns u with fractional powers replaced by vv raised 3289 to the power and x replaced by xx. *) 3290SquareRootOfQuadraticSubst[u_,vv_,xx_,x_Symbol] := 3291 If[AtomQ[u] || FreeQ[u,x], 3292 If[u===x, 3293 xx, 3294 u], 3295 If[PowerQ[u] && FreeQ[u[[2]],x], 3296 If[FractionQ[u[[2]]] && Denominator[u[[2]]]==2 && PolynomialQ[u[[1]],x] && Exponent[u[[1]],x]==2, 3297 vv^Numerator[u[[2]]], 3298 SquareRootOfQuadraticSubst[u[[1]],vv,xx,x]^u[[2]]], 3299 Map[Function[SquareRootOfQuadraticSubst[#,vv,xx,x]],u]]] 3300 3301 3302NormalizeSubst[u_,x_Symbol,w_] := 3303 NormalizeIntegrand[Subst[u,x,w],x] 3304 3305 3306Subst[u_,x_,w_] := 3307 SubstAux[u,x,w] 3308(*Module[{v=SubstAux[u,x,w]}, 3309 If[SumQ[v], 3310 Map[Function[If[FreeQ[#,Int],SimplifyIntegrand[#,x],#]],v], 3311 If[FreeQ[v,Int],SimplifyIntegrand[v,x],v]]] *) 3312 3313 3314(* Subst[u,v,w] returns u with all nondummy occurences of v replaced by w *) 3315SubstAux[u_,v_,w_] := 3316 If[u===v, 3317 w, 3318 If[AtomQ[u], 3319 u, 3320 If[PowerQ[u], 3321 If[PowerQ[v] && u[[1]]===v[[1]] && SumQ[u[[2]]], 3322 SubstAux[u[[1]]^First[u[[2]]],v,w]*SubstAux[u[[1]]^Rest[u[[2]]],v,w], 3323 SubstAux[u[[1]],v,w]^SubstAux[u[[2]],v,w]], 3324 If[Head[u]===Defer[Subst], 3325 If[u[[2]]===v || FreeQ[u[[1]],v], 3326 SubstAux[u[[1]],u[[2]],SubstAux[u[[3]],v,w]], 3327 Defer[Subst][u,v,w]], 3328 If[CalculusQ[u] && Not[FreeQ[v,u[[2]]]] || HeldFormQ[u], 3329 Defer[Subst][u,v,w], 3330 If[Head[u]===Dist, 3331 Dist[SubstAux[u[[1]],v,w],SubstAux[u[[2]],v,w],u[[3]]], 3332 Map[Function[SubstAux[#,v,w]],u]]]]]]] 3333 3334 3335(* u is a function v. SubstFor[v,u,x] returns f (x). *) 3336SubstFor[v_,u_,x_] := 3337 If[AtomQ[v], 3338 Subst[u,v,x], 3339 If[PowerQ[v] && FreeQ[v[[2]],x] (* && NonzeroQ[v[[2]]+1] *), 3340 SubstForPower[u,v[[1]],v[[2]],x], 3341 3342 If[SinQ[v], 3343 SubstForTrig[u,x,Sqrt[1-x^2],v[[1]],x], 3344 If[CosQ[v], 3345 SubstForTrig[u,Sqrt[1-x^2],x,v[[1]],x], 3346 If[TanQ[v], 3347 SubstForTrig[u,x/Sqrt[1+x^2],1/Sqrt[1+x^2],v[[1]],x], 3348 If[CotQ[v], 3349 SubstForTrig[u,1/Sqrt[1+x^2],x/Sqrt[1+x^2],v[[1]],x], 3350 If[SecQ[v], 3351 SubstForTrig[u,1/Sqrt[1-x^2],1/x,v[[1]],x], 3352 If[CscQ[v], 3353 SubstForTrig[u,1/x,1/Sqrt[1-x^2],v[[1]],x], 3354 3355 If[SinhQ[v], 3356 SubstForHyperbolic[u,x,Sqrt[1+x^2],v[[1]],x], 3357 If[CoshQ[v], 3358 SubstForHyperbolic[u,Sqrt[-1+x^2],x,v[[1]],x], 3359 If[TanhQ[v], 3360 SubstForHyperbolic[u,x/Sqrt[1-x^2],1/Sqrt[1-x^2],v[[1]],x], 3361 If[CothQ[v], 3362 SubstForHyperbolic[u,1/Sqrt[-1+x^2],x/Sqrt[-1+x^2],v[[1]],x], 3363 If[SechQ[v], 3364 SubstForHyperbolic[u,1/Sqrt[-1+x^2],1/x,v[[1]],x], 3365 If[CschQ[v], 3366 SubstForHyperbolic[u,1/x,1/Sqrt[1+x^2],v[[1]],x], 3367 3368 SubstForExpn[u,v,x]]]]]]]]]]]]]]] 3369 3370 3371SubstForExpn[u_,v_,w_] := 3372 If[u===v, 3373 w, 3374 If[AtomQ[u], 3375 u, 3376 Map[Function[SubstForExpn[#,v,w]],u]]] 3377 3378 3379SubstForPower[u_,bas_,deg_,x_] := 3380 If[AtomQ[u], 3381 u, 3382 If[PowerQ[u] && ZeroQ[u[[1]]-bas] && FreeQ[u[[2]],x] && IntegerQ[Simplify[u[[2]]/deg]] 3383 (* && (u[[2]]/deg>0 || FractionQ[deg]) *), 3384 x^(u[[2]]/deg), 3385 Map[Function[SubstForPower[#,bas,deg,x]],u]]] 3386 3387 3388(* u (v) is an expression of the form f (Sin[v],Cos[v],Tan[v],Cot[v],Sec[v],Csc[v]). *) 3389(* SubstForTrig[u,sin,cos,v,x] returns the expression f (sin,cos,sin/cos,cos/sin,1/cos,1/sin). *) 3390SubstForTrig[u_,sin_,cos_,v_,x_] := 3391 If[AtomQ[u], 3392 u, 3393 If[TrigQ[u] && IntegerQuotientQ[u[[1]],v], 3394 If[u[[1]]===v || ZeroQ[u[[1]]-v], 3395 If[SinQ[u], 3396 sin, 3397 If[CosQ[u], 3398 cos, 3399 If[TanQ[u], 3400 sin/cos, 3401 If[CotQ[u], 3402 cos/sin, 3403 If[SecQ[u], 3404 1/cos, 3405 1/sin]]]]], 3406 Map[Function[SubstForTrig[#,sin,cos,v,x]], 3407 ReplaceAll[TrigExpand[Head[u][u[[1]]/v*x]],x->v]]], 3408 If[ProductQ[u] && CosQ[u[[1]]] && SinQ[u[[2]]] && ZeroQ[u[[1,1]]-v/2] && ZeroQ[u[[2,1]]-v/2], 3409 sin/2*SubstForTrig[Drop[u,2],sin,cos,v,x], 3410 Map[Function[SubstForTrig[#,sin,cos,v,x]],u]]]] 3411 3412 3413(* u (v) is an expression of the form f (Sinh[v],Cosh[v],Tanh[v],Coth[v],Sech[v],Csch[v]). *) 3414(* SubstForHyperbolic[u,sinh,cosh,v,x] returns the expression 3415 f (sinh,cosh,sinh/cosh,cosh/sinh,1/cosh,1/sinh). *) 3416SubstForHyperbolic[u_,sinh_,cosh_,v_,x_] := 3417 If[AtomQ[u], 3418 u, 3419 If[HyperbolicQ[u] && IntegerQuotientQ[u[[1]],v], 3420 If[u[[1]]===v || ZeroQ[u[[1]]-v], 3421 If[SinhQ[u], 3422 sinh, 3423 If[CoshQ[u], 3424 cosh, 3425 If[TanhQ[u], 3426 sinh/cosh, 3427 If[CothQ[u], 3428 cosh/sinh, 3429 If[SechQ[u], 3430 1/cosh, 3431 1/sinh]]]]], 3432 Map[Function[SubstForHyperbolic[#,sinh,cosh,v,x]], 3433 ReplaceAll[TrigExpand[Head[u][u[[1]]/v*x]],x->v]]], 3434 If[ProductQ[u] && CoshQ[u[[1]]] && SinhQ[u[[2]]] && ZeroQ[u[[1,1]]-v/2] && ZeroQ[u[[2,1]]-v/2], 3435 sinh/2*SubstForHyperbolic[Drop[u,2],sinh,cosh,v,x], 3436 Map[Function[SubstForHyperbolic[#,sinh,cosh,v,x]],u]]]] 3437 3438 3439(* If u has a subexpression of the form (a+b*x)^(m/n) where m and n>1 are integers, 3440 SubstForFractionalPowerOfLinear[u,x] returns the list {v,n,a+b*x,1/b} where v is u 3441 with subexpressions of the form (a+b*x)^(m/n) replaced by x^m and x replaced 3442 by -a/b+x^n/b, and all times x^(n-1); else it returns False. *) 3443SubstForFractionalPowerOfLinear[u_,x_Symbol] := 3444 Module[{lst=FractionalPowerOfLinear[u,1,False,x],n,a,b,tmp}, 3445 If[FalseQ[lst] || FalseQ[lst[[2]]], 3446 False, 3447 n=lst[[1]]; 3448 a=Coefficient[lst[[2]],x,0]; 3449 b=Coefficient[lst[[2]],x,1]; 3450 tmp=x^(n-1)*SubstForFractionalPower[u,lst[[2]],n,-a/b+x^n/b,x]; 3451 tmp=SplitFreeFactors[Simplify[tmp],x]; 3452 {tmp[[2]],n,lst[[2]],tmp[[1]]/b}]] 3453 3454 3455(* If u has a subexpression of the form (a+b*x)^(m/n), 3456 FractionalPowerOfLinear[u,1,False,x] returns {n,a+b*x}; else it returns False. *) 3457FractionalPowerOfLinear[u_,n_,v_,x_] := 3458 If[AtomQ[u] || FreeQ[u,x], 3459 {n,v}, 3460 If[CalculusQ[u], 3461 False, 3462 If[FractionalPowerQ[u] && LinearQ[u[[1]],x] && (FalseQ[v] || ZeroQ[u[[1]]-v]), 3463 {LCM[Denominator[u[[2]]],n],u[[1]]}, 3464 Catch[Module[{lst={n,v}}, 3465 Scan[Function[If[FalseQ[lst=FractionalPowerOfLinear[#,lst[[1]],lst[[2]],x]],Throw[False]]],u]; 3466 lst]]]]] 3467 3468 3469(* If u has a subexpression of the form ((a+b*x)/(c+d*x))^(m/n) where m and n>1 are integers, 3470 SubstForFractionalPowerOfQuotientOfLinears[u,x] returns the list {v,n,(a+b*x)/(c+d*x),b*c-a*d} where v is u 3471 with subexpressions of the form ((a+b*x)/(c+d*x))^(m/n) replaced by x^m and x replaced 3472 by (-a+c*x^n)/(b-d*x^n), and all times x^(n-1)/(b-d*x^n)^2; else it returns False. *) 3473SubstForFractionalPowerOfQuotientOfLinears[u_,x_Symbol] := 3474 Module[{lst=FractionalPowerOfQuotientOfLinears[u,1,False,x],n,a,b,c,d,tmp}, 3475 If[FalseQ[lst] || FalseQ[lst[[2]]], 3476 False, 3477 n=lst[[1]]; 3478 tmp=lst[[2]]; 3479 lst=QuotientOfLinearsParts[tmp,x]; 3480 a=lst[[1]]; 3481 b=lst[[2]]; 3482 c=lst[[3]]; 3483 d=lst[[4]]; 3484 If[ZeroQ[d], 3485 False, 3486 lst=x^(n-1)*SubstForFractionalPower[u,tmp,n,(-a+c*x^n)/(b-d*x^n),x]/(b-d*x^n)^2; 3487 lst=SplitFreeFactors[Simplify[lst],x]; 3488 {lst[[2]],n,tmp,lst[[1]]*(b*c-a*d)}]]] 3489 3490 3491(* If the substitution x=v^(1/n) will not complicate algebraic subexpressions of u, 3492 SubstForFractionalPowerQ[u,v,x] returns True; else it returns False. *) 3493SubstForFractionalPowerQ[u_,v_,x_Symbol] := 3494 If[AtomQ[u] || FreeQ[u,x], 3495 True, 3496 If[FractionalPowerQ[u], 3497 SubstForFractionalPowerAuxQ[u,v,x], 3498 Catch[Scan[Function[If[Not[SubstForFractionalPowerQ[#,v,x]],Throw[False]]],u];True]]] 3499 3500SubstForFractionalPowerAuxQ[u_,v_,x_] := 3501 If[AtomQ[u], 3502 False, 3503 If[FractionalPowerQ[u] && ZeroQ[u[[1]]-v], 3504 True, 3505 Catch[Scan[Function[If[SubstForFractionalPowerAuxQ[#,v,x],Throw[True]]],u];False]]] 3506 3507 3508(* If u has a subexpression of the form ((a+b*x)/(c+d*x))^(m/n), 3509 FractionalPowerOfQuotientOfLinears[u,1,False,x] returns {n,(a+b*x)/(c+d*x)}; else it returns False. *) 3510FractionalPowerOfQuotientOfLinears[u_,n_,v_,x_] := 3511 If[AtomQ[u] || FreeQ[u,x], 3512 {n,v}, 3513 If[CalculusQ[u], 3514 False, 3515 If[FractionalPowerQ[u] && QuotientOfLinearsQ[u[[1]],x] && Not[LinearQ[u[[1]],x]] && (FalseQ[v] || ZeroQ[u[[1]]-v]), 3516 {LCM[Denominator[u[[2]]],n],u[[1]]}, 3517 Catch[Module[{lst={n,v}}, 3518 Scan[Function[If[FalseQ[lst=FractionalPowerOfQuotientOfLinears[#,lst[[1]],lst[[2]],x]],Throw[False]]],u]; 3519 lst]]]]] 3520 3521 3522(* If u has a subexpression of the form g[a+b*x] where g is the inverse of the function h 3523 (i.e. h[g[x]] == x) and f[x,g[a+b*x]] equals u, SubstForInverseFunctionOfLinear[u,x] returns 3524 the list {f[-a/b+h[x]/b,x]*h'[x], g[a+b*x], b} *) 3525SubstForInverseFunctionOfLinear[u_,x_Symbol] := 3526 Module[{tmp=InverseFunctionOfLinear[u,x],h,a,b}, 3527 If[FalseQ[tmp], 3528 False, 3529 h=InverseFunction[Head[tmp]]; 3530 a=Coefficient[tmp[[1]],x,0]; 3531 b=Coefficient[tmp[[1]],x,1]; 3532 {SubstForInverseFunction[u,tmp,-a/b+h[x]/b,x]*D[h[x],x], tmp, b}]] 3533 3534 3535(* If u has a subexpression of the form g[a+b*x] where g is an inverse function, 3536 InverseFunctionOfLinear[u,x] returns g[a+b*x]; else it returns False. *) 3537InverseFunctionOfLinear[u_,x_Symbol] := 3538 If[AtomQ[u] || CalculusQ[u] || FreeQ[u,x], 3539 False, 3540 If[InverseFunctionQ[u] && LinearQ[u[[1]],x], 3541 u, 3542 Module[{tmp}, 3543 Catch[ 3544 Scan[Function[If[NotFalseQ[tmp=InverseFunctionOfLinear[#,x]],Throw[tmp]]],u]; 3545 False]]]] 3546 3547 3548(* If u has a subexpression of the form g[(a+b*x)/(c+d*x)] where g is the inverse of function h 3549 and f[x,g[(a+b*x)/(c+d*x)]] equals u, SubstForInverseFunctionOfQuotientOfLinears[u,x] returns 3550 the list {f[(-a+c*h[x])/(b-d*h[x]),x]*h'[x]/(b-d*h[x])^2, g[(a+b*x)/(c+d*x)], b*c-a*d} *) 3551SubstForInverseFunctionOfQuotientOfLinears[u_,x_Symbol] := 3552 Module[{tmp=InverseFunctionOfQuotientOfLinears[u,x],h,a,b,c,d,lst}, 3553 If[FalseQ[tmp], 3554 False, 3555 h=InverseFunction[Head[tmp]]; 3556 lst=QuotientOfLinearsParts[tmp[[1]],x]; 3557 a=lst[[1]]; 3558 b=lst[[2]]; 3559 c=lst[[3]]; 3560 d=lst[[4]]; 3561 {SubstForInverseFunction[u,tmp,(-a+c*h[x])/(b-d*h[x]),x]*D[h[x],x]/(b-d*h[x])^2, tmp, b*c-a*d}]] 3562 3563 3564(* If u has a subexpression of the form g[(a+b*x)/(c+d*x)] where g is an inverse function, 3565 InverseFunctionOfQuotientOfLinears[u,x] returns g[(a+b*x)/(c+d*x)]; else it returns False. *) 3566InverseFunctionOfQuotientOfLinears[u_,x_Symbol] := 3567 If[AtomQ[u] || CalculusQ[u] || FreeQ[u,x], 3568 False, 3569 If[InverseFunctionQ[u] && QuotientOfLinearsQ[u[[1]],x], 3570 u, 3571 Module[{tmp}, 3572 Catch[ 3573 Scan[Function[If[NotFalseQ[tmp=InverseFunctionOfQuotientOfLinears[#,x]],Throw[tmp]]],u]; 3574 False]]]] 3575 3576 3577(* SubstForFractionalPower[u,v,n,w,x] returns u with subexpressions equal to v^(m/n) replaced 3578 by x^m and x replaced by w. *) 3579SubstForFractionalPower[u_,v_,n_,w_,x_Symbol] := 3580 If[AtomQ[u], 3581 If[u===x, 3582 w, 3583 u], 3584 If[FractionalPowerQ[u] && ZeroQ[u[[1]]-v], 3585 x^(n*u[[2]]), 3586 Map[Function[SubstForFractionalPower[#,v,n,w,x]],u]]] 3587 3588 3589(* SubstForInverseFunction[u,v,w,x] returns u with subexpressions equal to v replaced by x 3590 and x replaced by w. *) 3591SubstForInverseFunction[u_,v_,x_Symbol] := 3592(* Module[{a=Coefficient[v[[1]],0],b=Coefficient[v[[1]],1]}, 3593 SubstForInverseFunction[u,v,-a/b+InverseFunction[Head[v]]/b,x]] *) 3594 SubstForInverseFunction[u,v, 3595 (-Coefficient[v[[1]],x,0]+InverseFunction[Head[v]][x])/Coefficient[v[[1]],x,1],x] 3596 3597SubstForInverseFunction[u_,v_,w_,x_Symbol] := 3598 If[AtomQ[u], 3599 If[u===x, 3600 w, 3601 u], 3602 If[Head[u]===Head[v] && ZeroQ[u[[1]]-v[[1]]], 3603 x, 3604 Map[Function[SubstForInverseFunction[#,v,w,x]],u]]] 3605 3606 3607(* If u is a function of an inverse linear binomial of the form f[1/(a+b*x)], 3608 SubstForInverseLinear[u,x] returns the list {f[x],a+b*x,b}; else it returns False. *) 3609SubstForInverseLinear[u_,x_Symbol] := 3610 Module[{lst=FunctionOfInverseLinear[u,x],a,b}, 3611 If[FalseQ[lst], 3612 False, 3613 a=lst[[1]]; 3614 b=lst[[2]]; 3615 {RegularizeSubst[u,x,-a/b+1/(b*x)],a+b*x,b}]] 3616 3617 3618(* u is a function of trig functions of a linear function of x. 3619SubstInertTrigFunction[u] returns u with the trig functions replaced with 3620the inert trig functions (sin, csc and tan). *) 3621SubstInertTrigFunction[u_,x_] := 3622 FixInertTrigFunction[SubstInertTrigFunctionAux[u,x],x] 3623 3624 3625SubstInertTrigFunctionAux[u_,x_] := 3626 If[AtomQ[u], 3627 u, 3628 If[TrigQ[u] && LinearQ[u[[1]],x], 3629 If[SinQ[u], 3630 sin[u[[1]]], 3631 If[CosQ[u], 3632 sin[u[[1]]+Pi/2], 3633 If[TanQ[u], 3634 tan[u[[1]]], 3635 If[CotQ[u], 3636 1/tan[u[[1]]], 3637 If[SecQ[u], 3638 csc[u[[1]]+Pi/2], 3639 csc[u[[1]]]]]]]], 3640 Map[Function[SubstInertTrigFunctionAux[#,x]],u]]] 3641 3642 3643FixInertTrigFunction[u_.*f_[c_.+d_.*x_]^m_.*(a_.+b_.*g_[c_.+d_.*x_])^n_.,x_] := 3644 u*g[c+d*x]^(-m)*(a+b*g[c+d*x])^n /; 3645FreeQ[{a,b,c,d,n},x] && IntegerQ[m] && (f===sin && g===csc || f===csc && g===sin) 3646 3647FixInertTrigFunction[f_[c_.+d_.*x_]^m_.*(A_.+B_.*g_[c_.+d_.*x_]+C_.*g_[c_.+d_.*x_]^2),x_] := 3648 g[c+d*x]^(-m)*(A+B*g[c+d*x]+C*g[c+d*x]^2) /; 3649FreeQ[{c,d,A,B,C},x] && IntegerQ[m] && (f===sin && g===csc || f===csc && g===sin) 3650 3651FixInertTrigFunction[f_[c_.+d_.*x_]^m_.*(A_.+C_.*g_[c_.+d_.*x_]^2),x_] := 3652 g[c+d*x]^(-m)*(A+C*g[c+d*x]^2) /; 3653FreeQ[{c,d,A,C},x] && IntegerQ[m] && (f===sin && g===csc || f===csc && g===sin) 3654 3655FixInertTrigFunction[u_,x_] := u 3656 3657 3658TryTanSubst[u_,x_Symbol] := 3659 FalseQ[FunctionOfLinear[u,x]] && 3660 Not[MatchQ[u,r_.*(s_+t_)^n_. /; IntegerQ[n] && n>0]] && 3661(*Not[MatchQ[u,Log[f_[x]^2] /; SinCosQ[f]]] && *) 3662 Not[MatchQ[u,Log[v_]]] && 3663 Not[MatchQ[u,1/(a_+b_.*f_[x]^n_) /; SinCosQ[f] && IntegerQ[n] && n>2]] && 3664 Not[MatchQ[u,f_[m_.*x]*g_[n_.*x] /; IntegersQ[m,n] && SinCosQ[f] && SinCosQ[g]]] && 3665 Not[MatchQ[u,r_.*(a_.*s_^m_)^p_ /; FreeQ[{a,m,p},x] && Not[m===2 && (s===Sec[x] || s===Csc[x])]]] && 3666 u===ExpnExpand[u,x] 3667 3668 3669TryPureTanSubst[u_,x_Symbol] := 3670 Not[MatchQ[u,Log[v_]]] && 3671 Not[MatchQ[u,f_[v_]^2 /; LinearQ[v,x]]] && 3672 Not[MatchQ[u,ArcTan[a_.*Tan[v_]] /; FreeQ[a,x]]] && 3673 Not[MatchQ[u,ArcTan[a_.*Cot[v_]] /; FreeQ[a,x]]] && 3674 Not[MatchQ[u,ArcCot[a_.*Tan[v_]] /; FreeQ[a,x]]] && 3675 Not[MatchQ[u,ArcCot[a_.*Cot[v_]] /; FreeQ[a,x]]] && 3676 u===ExpnExpand[u,x] 3677 3678 3679TryTanhSubst[u_,x_Symbol] := 3680 FalseQ[FunctionOfLinear[u,x]] && 3681 Not[MatchQ[u,r_.*(s_+t_)^n_. /; IntegerQ[n] && n>0]] && 3682(*Not[MatchQ[u,Log[f_[x]^2] /; SinhCoshQ[f]]] && *) 3683 Not[MatchQ[u,Log[v_]]] && 3684 Not[MatchQ[u,1/(a_+b_.*f_[x]^n_) /; SinhCoshQ[f] && IntegerQ[n] && n>2]] && 3685 Not[MatchQ[u,f_[m_.*x]*g_[n_.*x] /; IntegersQ[m,n] && SinhCoshQ[f] && SinhCoshQ[g]]] && 3686 Not[MatchQ[u,r_.*(a_.*s_^m_)^p_ /; FreeQ[{a,m,p},x] && Not[m===2 && (s===Sech[x] || s===Csch[x])]]] && 3687 u===ExpnExpand[u,x] 3688 3689 3690TryPureTanhSubst[u_,x_Symbol] := 3691 Not[MatchQ[u,Log[v_]]] && 3692 Not[MatchQ[u,ArcTanh[a_.*Tanh[v_]] /; FreeQ[a,x]]] && 3693 Not[MatchQ[u,ArcTanh[a_.*Coth[v_]] /; FreeQ[a,x]]] && 3694 Not[MatchQ[u,ArcCoth[a_.*Tanh[v_]] /; FreeQ[a,x]]] && 3695 Not[MatchQ[u,ArcCoth[a_.*Coth[v_]] /; FreeQ[a,x]]] && 3696 u===ExpnExpand[u,x] 3697 3698 3699(* If u divided by y is free of x, Divides[y,u,x] returns the quotient; else it returns False. *) 3700Divides[y_,u_,x_Symbol] := 3701 Module[{v=Simplify[u/y]}, 3702 If[FreeQ[v,x], 3703 v, 3704 False]] 3705 3706 3707(* If y not equal to x, y is easy to differentiate wrt x, and u divided by the derivative of y 3708 is free of x, DerivativeDivides[y,u,x] returns the quotient; else it returns False. *) 3709DerivativeDivides[y_,u_,x_Symbol] := 3710 If[MatchQ[y,a_.*x /; FreeQ[a,x]], 3711 False, 3712 If[If[PolynomialQ[y,x], PolynomialQ[u,x] && Exponent[u,x]==Exponent[y,x]-1, EasyDQ[y,x]], 3713 Module[{v=Block[{ShowSteps=False}, D[y,x]]}, 3714 If[ZeroQ[v], 3715 False, 3716 v=Simplify[u/v]; 3717 If[FreeQ[v,x], 3718 v, 3719 False]]], 3720 False]] 3721 3722 3723(* If y is easy to differentiate wrt x, EasyDQ[y,x] returns True; else it returns False. *) 3724EasyDQ[y_,x_Symbol] := 3725 If[AtomQ[y] || FreeQ[y,x] || Length[y]==0, 3726 True, 3727 If[CalculusQ[y], 3728 False, 3729 If[Length[y]==1, 3730 EasyDQ[y[[1]],x], 3731 If[BinomialQ[y,x], 3732 True, 3733 If[RationalFunctionQ[y,x] && RationalFunctionExponents[y,x]==={1,1}, 3734 True, 3735 If[ProductQ[y], 3736 If[FreeQ[First[y],x], 3737 EasyDQ[Rest[y],x], 3738 If[FreeQ[Rest[y],x], 3739 EasyDQ[First[y],x], 3740 False]], 3741 If[SumQ[y], 3742 EasyDQ[First[y],x] && EasyDQ[Rest[y],x], 3743 If[Length[y]==2, 3744 If[FreeQ[y[[1]],x], 3745 EasyDQ[y[[2]],x], 3746 If[FreeQ[y[[2]],x], 3747 EasyDQ[y[[1]],x], 3748 False]], 3749 False]]]]]]]] 3750 3751 3752DownValues[Rt]={}; 3753 3754 3755Rt[u_^m_,n_Integer] := 3756 1/Rt[u^-m,n] /; 3757RationalQ[m] && m<0 3758 3759Rt[v_.*u_^w_,n_Integer] := 3760 Module[{m=Numerator[NumericFactor[w]]}, 3761 Rt[v,n]*Rt[u^(w/m),n/GCD[m,n]]^(m/GCD[m,n]) /; 3762 m>1] /; 3763Not[NegativeOrZeroQ[v]] 3764 3765(* Rt[u_*v_^m_,n_Integer] := 3766 Rt[-u,n]/Rt[-v^-m,n] /; 3767RationalQ[m] && m<0 && NegativeQ[u] *) 3768 3769 3770Rt[u_,n_Integer] := 3771 Map[Function[Rt[#,n]],u] /; 3772ProductQ[u] && OddQ[n] 3773 3774Rt[u_,n_Integer] := 3775 Catch[ 3776 Do[If[PositiveQ[u[[i]]], 3777 Throw[Rt[u[[i]],n]*Rt[Delete[u,i],n]]], 3778 {i,1,Length[u]}]; 3779 Do[If[NegativeQ[u[[i]]] && NonzeroQ[u[[i]]+1], 3780 Throw[Rt[-u[[i]],n]*Rt[-Delete[u,i],n]]], 3781 {i,1,Length[u]}]; 3782 If[u[[1]]===-1, 3783 Do[If[SumQ[u[[i]]] && (NegQ[u[[i,1]]] || NegQ[u[[i,2]]]), 3784 Throw[Rt[-First[u[[i]]] - Rest[u[[i]]],n]*Rt[-Delete[u,i],n]]], 3785 {i,2,Length[u]}]; 3786 Do[If[AtomQ[u[[i]]], 3787 Throw[Rt[-u[[i]],n]*Rt[-Delete[u,i],n]]], 3788 {i,2,Length[u]}]; 3789 Rt[-u[[2]],n]*Rt[Drop[u,2],n], 3790 Do[If[Not[FreeQ[Delete[u,i],Rt[-u[[i]],n]]], 3791 Throw[Rt[-u[[i]],n]*Rt[-Delete[u,i],n]]], 3792 {i,1,Length[u]}]; 3793 Map[Function[Rt[#,n]],u]]] /; 3794ProductQ[u] && EvenQ[n] && Not[u[[1]]===-1 && Length[u]==2] 3795 3796 3797(* Note: These simplification rules required because not always done by Simplify! See Warts.m 3798 for examples of the problem. *) 3799 3800(* Basis: 1-Sin[z]^2 == Cos[z]^2 *) 3801Rt[u_.*(a_+b_.*Sin[v_]^2)^m_.,n_Integer] := 3802 Rt[u*(a*Cos[v]^2)^m,n] /; 3803ZeroQ[a+b] 3804 3805(* Basis: 1-Cos[z]^2 == Sin[z]^2 *) 3806Rt[u_.*(a_+b_.*Cos[v_]^2)^m_.,n_Integer] := 3807 Rt[u*(a*Sin[v]^2)^m,n] /; 3808ZeroQ[a+b] 3809 3810(* Basis: 1+Sinh[z]^2 == Cosh[z]^2 *) 3811Rt[u_.*(a_+b_.*Sinh[v_]^2)^m_.,n_Integer] := 3812 Rt[u*(a*Cosh[v]^2)^m,n] /; 3813ZeroQ[a-b] 3814 3815(* Basis: 1-Cosh[z]^2 == -Sinh[z]^2 *) 3816Rt[u_.*(a_+b_.*Cosh[v_]^2)^m_.,n_Integer] := 3817 Rt[u*(b*Sinh[v]^2)^m,n] /; 3818ZeroQ[a+b] 3819 3820 3821Rt[u_,n_Integer] := 3822 Module[{v=ContentFactor[u]}, 3823 Rt[v,n] /; 3824 NonsumQ[v]] /; 3825SumQ[u] 3826 3827 3828Rt[u_,n_] := 3829 -Rt[-u,n] /; 3830OddQ[n] && NegativeQ[u] 3831 3832Rt[u_,n_Integer] := 3833 Module[{v=Simplify[u]}, 3834 If[LeafCount[Together[v]]<LeafCount[v], v=Together[v]]; 3835 If[v=!=u, 3836 Rt[v,n], 3837 u^(1/n)]] 3838 3839 3840(* Rt[u_,n_Integer] := 3841 If[AtomQ[u], 3842 u^(1/n), 3843 If[PowerQ[u], 3844 If[RationalQ[u[[2]]], 3845 If[u[[2]]<0, 3846 1/Rt[u[[1]]^-u[[2]],n], 3847 If[Numerator[u[[2]]]>1, 3848 Module[{gcd=GCD[Numerator[u[[2]]],n]}, 3849 Rt[u[[1]]^(1/Denominator[u[[2]]]),n/gcd]^(Numerator[u[[2]]]/gcd)], 3850 u^(1/n)]], 3851 u^(1/n)], 3852 If[ProductQ[u], 3853 If[OddQ[n], 3854 Map[Function[Rt[#,n]],u], 3855 If[NegativeQ[First[u]], 3856 If[First[u]===-1, 3857 If[PowerQ[Rest[u]] && OddQ[Rest[u][[2]]], 3858 If[Rest[u][[2]]<0, 3859 1/Rt[(-Rest[u][[1]])^-Rest[u][[2]],n], 3860 Module[{gcd=GCD[Rest[u][[2]],n]}, 3861 Rt[Rest[u][[1]],n/gcd]^(Rest[u][[2]]/gcd)]], 3862 u^(1/n)], 3863 Rt[-First[u],n]*Rt[-Rest[u],n]], 3864 u^(1/n)]], *) 3865 3866 3867(* If u is free of x or of the form c*(a+b*x)^m, IntSum[u,x] returns the antiderivative of u wrt x; 3868 else it returns d*Int[v,x] where d*v=u and d is free of x. *) 3869IntSum[u_,x_Symbol] := 3870 Module[{lst=SplitFreeTerms[u,x]}, 3871 Simp[lst[[1]]*x,x] + IntTerm[lst[[2]],x]] 3872 3873 3874(* If u is of the form c*(a+b*x)^m, IntTerm[u,x] returns the antiderivative of u wrt x; 3875 else it returns d*Int[v,x] where d*v=u and d is free of x. *) 3876IntTerm[c_./v_,x_Symbol] := 3877 Simp[c*Log[RemoveContent[v,x]]/Coefficient[v,x,1],x] /; 3878FreeQ[c,x] && LinearQ[v,x] 3879 3880IntTerm[c_.*v_^m_.,x_Symbol] := 3881 Simp[c*v^(m+1)/(Coefficient[v,x,1]*(m+1)),x] /; 3882FreeQ[{c,m},x] && NonzeroQ[m+1] && LinearQ[v,x] 3883 3884IntTerm[u_,x_Symbol] := 3885 Map[Function[IntTerm[#,x]],u] /; 3886SumQ[u] 3887 3888IntTerm[u_,x_Symbol] := 3889 Module[{lst=SplitFreeFactors[u,x]}, 3890 Dist[lst[[1]], Int[lst[[2]],x], x]] 3891 3892 3893(* SimplerIntegrandQ[u,v,x] returns True iff u is simpler to integrate wrt x than v. *) 3894SimplerIntegrandQ[u_,v_,x_Symbol] := 3895 Module[{lst=CancelCommonFactors[u,v],u1,v1}, 3896 u1=lst[[1]]; 3897 v1=lst[[2]]; 3898(*If[Head[u1]===Head[v1] && Length[u1]==Length[v1]==1, 3899 SimplerIntegrandQ[u1[[1]],v1[[1]],x], *) 3900 If[LeafCount[u1]<3/4*LeafCount[v1], 3901 True, 3902 If[RationalFunctionQ[u1,x], 3903 If[RationalFunctionQ[v1,x], 3904 Apply[Plus,RationalFunctionExponents[u1,x]]<Apply[Plus,RationalFunctionExponents[v1,x]], 3905 True], 3906 False]]] 3907 3908 3909(* CancelCommonFactors[u,v] returns {u',v'} are the noncommon factors of u and v respectively. *) 3910CancelCommonFactors[u_,v_] := 3911 If[ProductQ[u], 3912 If[ProductQ[v], 3913 If[MemberQ[v,First[u]], 3914 CancelCommonFactors[Rest[u],DeleteCases[v,First[u],1,1]], 3915 Function[{First[u]*#[[1]],#[[2]]}][CancelCommonFactors[Rest[u],v]]], 3916 If[MemberQ[u,v], 3917 {DeleteCases[u,v,1,1],1}, 3918 {u,v}]], 3919 If[ProductQ[v], 3920 If[MemberQ[v,u], 3921 {1,DeleteCases[v,u,1,1]}, 3922 {u,v}], 3923 {u,v}]] 3924 3925 3926(* SumSimplerQ[u,v] returns True iff for every term w of v there is a term of u 3927 equal to n*w where n<-1/2. Therefore if True, u+v will be simpler than u. *) 3928SumSimplerQ[u_,v_] := 3929 If[RationalQ[u,v], 3930 If[v==0, 3931 False, 3932 If[v>0, 3933 u<-1, 3934 u>=-v]], 3935 SumSimplerAuxQ[Expand[u],Expand[v]]] 3936 3937 3938SumSimplerAuxQ[u_,v_] := 3939 (RationalQ[First[v]] || SumSimplerAuxQ[u,First[v]]) && 3940 (RationalQ[Rest[v]] || SumSimplerAuxQ[u,Rest[v]]) /; 3941SumQ[v] 3942 3943SumSimplerAuxQ[u_,v_] := 3944 SumSimplerAuxQ[First[u],v] || SumSimplerAuxQ[Rest[u],v] /; 3945SumQ[u] 3946 3947SumSimplerAuxQ[u_,v_] := 3948 v=!=0 && 3949 NonnumericFactors[u]===NonnumericFactors[v] && 3950 (NumericFactor[u]/NumericFactor[v]<-1/2 || NumericFactor[u]/NumericFactor[v]==-1/2 && NumericFactor[u]<0) 3951 3952 3953(* SimplerSqrtQ[u,v] returns True iff Rt[u,2] is simpler than Rt[v,2]. *) 3954SimplerSqrtQ[u_,v_] := 3955 Module[{sqrtu=Rt[u,2],sqrtv=Rt[v,2]}, 3956 If[IntegerQ[sqrtu], 3957 If[IntegerQ[sqrtv], 3958 sqrtu<sqrtv, 3959 True], 3960 If[IntegerQ[sqrtv], 3961 False, 3962 If[RationalQ[Rt[sqrtu]], 3963 If[RationalQ[sqrtv], 3964 sqrtu<sqrtv, 3965 True], 3966 If[RationalQ[sqrtv], 3967 False, 3968 If[PosQ[u], 3969 If[PosQ[v], 3970 LeafCount[sqrtu]<LeafCount[sqrtv], 3971 True], 3972 If[PosQ[v], 3973 False, 3974 LeafCount[sqrtu]<LeafCount[sqrtv]]]]]]]] 3975 3976 3977ClearAll[FixIntRules,FixIntRule,FixRhsIntRule] 3978 3979 3980FixIntRules[] := 3981 (DownValues[Int]=FixIntRules[DownValues[Int]]; Null) 3982 3983 3984FixIntRules[rulelist_] := 3985 Module[{IntDownValues=DownValues[Int],SubstDownValues=DownValues[Subst], 3986 SimpDownValues=DownValues[Simp],DistDownValues=DownValues[Dist],lst}, 3987(* Print["Fixing ",Length[rulelist]," integration rules."]; *) 3988 Clear[Int,Subst,Simp,Dist]; 3989 SetAttributes[{Simp,Dist,Int,Subst},HoldAll]; 3990 lst=Map[Function[FixIntRule[#,#[[1,1,2,1]]]],rulelist]; 3991 DownValues[Int]=IntDownValues; 3992 DownValues[Subst]=SubstDownValues; 3993 DownValues[Simp]=SimpDownValues; 3994 DownValues[Dist]=DistDownValues; 3995 ClearAttributes[{Simp,Dist,Int,Subst},HoldAll]; 3996 lst] 3997 3998 3999FixIntRule[RuleDelayed[lhs_,F_[G_[list_,F_[u_+v_,test2_]],test1_]],x_] := 4000 ReplacePart[RuleDelayed[lhs,Condition[Module[list,Condition[u+v,test2]],test1]],{{2,1,2,1,1}->FixRhsIntRule[u,x],{2,1,2,1,2}->FixRhsIntRule[v,x]}] /; 4001F===Condition && G===Module 4002 4003FixIntRule[RuleDelayed[lhs_,G_[list_,F_[u_+v_,test2_]]],x_] := 4004 ReplacePart[RuleDelayed[lhs,Module[list,Condition[u+v,test2]]],{{2,2,1,1}->FixRhsIntRule[u,x],{2,2,1,2}->FixRhsIntRule[v,x]}] /; 4005F===Condition && G===Module 4006 4007FixIntRule[RuleDelayed[lhs_,F_[G_[list_,u_+v_],test_]],x_] := 4008 ReplacePart[RuleDelayed[lhs,Condition[Module[list,u+v],test]],{{2,1,2,1}->FixRhsIntRule[u,x],{2,1,2,2}->FixRhsIntRule[v,x]}] /; 4009F===Condition && G===Module 4010 4011FixIntRule[RuleDelayed[lhs_,G_[list_,u_+v_]],x_] := 4012 ReplacePart[RuleDelayed[lhs,Module[list,u+v]],{{2,2,1}->FixRhsIntRule[u,x],{2,2,2}->FixRhsIntRule[v,x]}] /; 4013G===Module 4014 4015FixIntRule[RuleDelayed[lhs_,F_[u_+v_,test_]],x_] := 4016 ReplacePart[RuleDelayed[lhs,Condition[u+v,test]],{{2,1,1}->FixRhsIntRule[u,x],{2,1,2}->FixRhsIntRule[v,x]}] /; 4017F===Condition 4018 4019FixIntRule[RuleDelayed[lhs_,u_+v_],x_] := 4020 ReplacePart[RuleDelayed[lhs,u+v],{{2,1}->FixRhsIntRule[u,x],{2,2}->FixRhsIntRule[v,x]}] 4021 4022 4023FixIntRule[RuleDelayed[lhs_,F_[G_[list1_,F_[G_[list2_,u_],test2_]],test1_]],x_] := 4024 ReplacePart[RuleDelayed[lhs,Condition[Module[list1,Condition[Module[list2,u],test2]],test1]],{2,1,2,1,2}->FixRhsIntRule[u,x]] /; 4025F===Condition && G===Module 4026 4027FixIntRule[RuleDelayed[lhs_,F_[G_[list_,F_[H_[str1_,str2_,str3_,J_[u_]],test2_]],test1_]],x_] := 4028 ReplacePart[RuleDelayed[lhs,Condition[Module[list,Condition[ShowStep[str1,str2,str3,Hold[u]],test2]],test1]],{2,1,2,1,4,1}->FixRhsIntRule[u,x]] /; 4029F===Condition && G===Module && H===ShowStep && J===Hold 4030 4031FixIntRule[RuleDelayed[lhs_,F_[G_[list_,F_[u_,test2_]],test1_]],x_] := 4032 ReplacePart[RuleDelayed[lhs,Condition[Module[list,Condition[u,test2]],test1]],{2,1,2,1}->FixRhsIntRule[u,x]] /; 4033F===Condition && G===Module 4034 4035FixIntRule[RuleDelayed[lhs_,G_[list_,F_[u_,test2_]]],x_] := 4036 ReplacePart[RuleDelayed[lhs,Module[list,Condition[u,test2]]],{2,2,1}->FixRhsIntRule[u,x]] /; 4037F===Condition && G===Module 4038 4039FixIntRule[RuleDelayed[lhs_,F_[G_[list_,u_],test_]],x_] := 4040 ReplacePart[RuleDelayed[lhs,Condition[Module[list,u],test]],{2,1,2}->FixRhsIntRule[u,x]] /; 4041F===Condition && G===Module 4042 4043FixIntRule[RuleDelayed[lhs_,G_[list_,u_]],x_] := 4044 ReplacePart[RuleDelayed[lhs,Module[list,u]],{2,2}->FixRhsIntRule[u,x]] /; 4045G===Module 4046 4047FixIntRule[RuleDelayed[lhs_,F_[u_,test_]],x_] := 4048 ReplacePart[RuleDelayed[lhs,Condition[u,test]],{2,1}->FixRhsIntRule[u,x]] /; 4049F===Condition 4050 4051FixIntRule[RuleDelayed[lhs_,u_],x_] := 4052 ReplacePart[RuleDelayed[lhs,u],{2}->FixRhsIntRule[u,x]] 4053 4054 4055SetAttributes[FixRhsIntRule,HoldAll]; 4056 4057FixRhsIntRule[u_+v_,x_] := 4058 FixRhsIntRule[u,x]+FixRhsIntRule[v,x] 4059 4060FixRhsIntRule[u_-v_,x_] := 4061 FixRhsIntRule[u,x]-FixRhsIntRule[v,x] 4062 4063FixRhsIntRule[-u_,x_] := 4064 -FixRhsIntRule[u,x] 4065 4066FixRhsIntRule[a_*u_,x_] := 4067 Dist[a,u,x] /; 4068MemberQ[{Int,Subst},Head[Unevaluated[u]]] 4069 4070FixRhsIntRule[u_,x_] := 4071 If[Head[Unevaluated[u]]===Dist && Length[Unevaluated[u]]==2, 4072 Insert[Unevaluated[u],x,3], 4073 If[MemberQ[{Int,Subst,Defer[Int],Simp,Dist},Head[Unevaluated[u]]], 4074 u, 4075 Simp[u,x]]] 4076