home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e031 / 3.ddi / MATHZIP2 / STARTUP / INTEGRAT / TABLE.M < prev    next >
Encoding:
Text File  |  1991-09-19  |  13.4 KB  |  502 lines
  1. (* ****************************************************************
  2. *
  3. *     TABLE -- Table Lookup
  4. *
  5. **************************************************************** *)
  6.  
  7. (* This is done here really to assist auto-loading on non-dumped Kernels*)
  8. Begin[ "Integrate`"]
  9.  
  10. Unprotect[ TableLookUp]
  11.  
  12. Clear[ TableLookUp]
  13.  
  14. TableLookUp[$f_]:=
  15.   Block[{$list,$c,$g,$factor,$k,$match,$i,$answer},
  16.     TrcEnter[TableLookUp,$f];
  17.     $list=FactorSquareFreeList[$f,Trig->True];
  18.     $c=1;
  19.     $g=1;
  20.     Do[{$factor,$k}=$list[[$i]];
  21.        If[FreeQ[$factor,X],
  22.           $c=$c*$factor^$k,
  23.       $g=$g*$factor^$k],
  24.        {$i,Length[$list]}];
  25.     $match=TableMatch[$g];
  26.     $answer=If[SameQ[Head[$match],TableMatch],
  27.                   NOK,
  28.            Dist[$c,$match]];
  29.     TrcExit[TableLookUp,$answer];
  30.     $answer]
  31.  
  32. Foil[$rat1_,$rat2_]:=
  33.   (* Distributive product. *)
  34.   Block[{$i,$j,$answer},
  35.     TrcEnter[Foil,$rat1,$rat2];
  36.     $answer=If[Not[SameQ[Head[$rat1],Plus]],
  37.                Dist[$rat1,$rat2],
  38.            If[Not[SameQ[Head[$rat2],Plus]],
  39.               Dist[$rat2,$rat1],
  40.               Sum[Dist[$rat1[[$i]],$rat2],
  41.               {$i,Length[$rat1]}]]];
  42.     TrcExit[Foil,$answer];
  43.     $answer]
  44.  
  45. Dist[$rat1_,$rat2_]:=
  46.   (* Distributive Law. *)
  47.   Block[{$j,$answer},
  48.     TrcEnter[Dist,$rat1,$rat2];
  49.     $answer=If[Not[SameQ[Head[$rat2],Plus]],
  50.            $rat1*$rat2,
  51.            Sum[$rat1*$rat2[[$j]],
  52.            {$j,Length[$rat2]}]];
  53.     TrcExit[Dist,$answer];
  54.     $answer]
  55.  
  56. AlgebraicRoot[$g_,$h_]:=
  57.   (* g^h where h is rational.  Does not have to be principle root. *)
  58.   Block[{$i,$answer},
  59.     TrcEnter[AlgebraicRoot,$g,$h];
  60.     $answer=Switch[Head[$g],
  61.                    Power, $g[[1]]^($g[[2]]*$h),
  62.            Times, Product[AlgebraicRoot[$g[[$i]],$h],
  63.                           {$i,Length[$g]}],
  64.            _, $g^$h];
  65.     TrcExit[AlgebraicRoot,$answer];
  66.     $answer]
  67.  
  68. (* ****************************************************************
  69. *
  70. *     Powers of X
  71. *
  72. **************************************************************** *)
  73.  
  74. TableMatch[X^$a_.]:=
  75.   Condition[
  76.     If[And[NumberQ[$a],$a==-1],
  77.        Log[X],
  78.        X^($a+1)/($a+1)],
  79.     And[FreeQ[$a,X],
  80.         Or[NumberQ[$a],SameQ[Head[$a],Symbol]]]]
  81.  
  82. (* ****************************************************************
  83. *
  84. *     ExpIntegralEi, LogIntegral, CosIntegral, SinIntegral
  85. *
  86. **************************************************************** *)
  87.  
  88. TableMatch[$g_^($a_.*X+$b_.)/($c_.*X+$d_.)]:=
  89.   Condition[
  90.     $g^($b-$a*$d/$c)*ExpIntegralEi[$a*Log[$g]*X+$a*Log[$g]*$d/$c]/$c,
  91.     FreeQ[{$g,$a,$b,$c,$d},X]]
  92.     
  93. TableMatch[ X^n_?OddQ Exp[a_. X^2 + c_.] ] :=
  94.   Condition[
  95.     Block[{den = 2*((-n-1)/2)!, limit = ((-n-1)/2)},
  96.         -Exp[a X^2 + c] Sum[(k-1)!/den a^(limit-k) / X^(2 k), {k, 1, limit}] +
  97.         a^limit ExpIntegralEi[a X^2] Exp[c]/den],
  98.     FreeQ[{a, c}, X] && Negative[n]]
  99.  
  100. TableMatch[ X^n_?EvenQ Exp[a_. X^2 + c_.] ] :=
  101.   Condition[
  102.     Block[{den = Factorial2[-n-1]}, 
  103.         -Exp[a X^2 + c] * Sum[(2 a)^k Abs[-n-2k-3]!!/den X^(n + 2 k + 1),
  104.                           {k, 0, (-n-2)/2}] +
  105.         (2a)^(-n/2)/den TableMatch[Exp[a X^2 + c]]],
  106.     FreeQ[{a, c}, X] && Negative[n]]
  107.  
  108. TableMatch[ E^(a_. X + b_.) (c_. X + d_.)^n_Integer?Negative ] :=
  109.   Condition[
  110.     Block[{den = (-n-1)!}, 
  111.         -E^(a X + b) * Sum[(k-1)!/den a^(-n-k-1)/(c^(-n-k) (c X + d)^k),
  112.                        {k, 1, -n-1}] +
  113.         a^(-n-1)/(den c^(-n)) E^(b-d a/c) ExpIntegralEi[a X + d a/c]],
  114.     FreeQ[{a, b, c, d}, X]]
  115.  
  116. TableMatch[ E^(a_. X + b_.)/X^2 ] := - E^(a X + b)/X +
  117.     a Exp[b] ExpIntegralEi[a X]  /; FreeQ[{a, b}, X]
  118.  
  119. TableMatch[ X / (a_ + b_. Exp[c_. X + d_.]) ] :=
  120.     X^2/(2 a) - X Log[1 + (b/a) Exp[c X + d]]/(a c) -
  121.     PolyLog[2, -b Exp[c X + d] / a] /(a c^2) /; FreeQ[{a, b, c, d}, X]
  122.  
  123. TableMatch[ X^n_Integer?Positive /(a_ + b_. Exp[c_. X + d_.]) ] :=
  124.     Block[{num = -n! /a}, X^(n+1)/(a(n+1)) -
  125.         X^n Log[1 + (b/a) Exp[c X + d]]/(a c) +
  126.         Sum[num/(k-1)! X^(k-1) PolyLog[n+2-k, -(b/a) Exp[c X + d]] /(-c)^(n+2-k),
  127.             {k, 1, n}] ] /; FreeQ[{a, b, c, d}, X]
  128.  
  129. TableC1[$f_,$u_]:=
  130.   (* Non-zero constant c==f/du or Fail. *)
  131.   Block[{$c,$du},
  132.     If[FreeQ[$u,X],Return[Fail]];
  133.     $du=Together[D[$u,X]];
  134.     If[$du==0,Return[Fail]];
  135.     $c=Together[$f/$du];
  136.     If[Not[FreeQ[$c,X]],Return[Fail]];
  137.     $c]
  138.  
  139. TableC2[$f_,$u_]:=
  140.   (* Non-zero constant c==f*u/du or Fail. *)
  141.   Block[{$c,$du},
  142.     If[FreeQ[$u,X],Return[Fail]];
  143.     $du=Together[D[$u,X]];
  144.     If[$du==0,Return[Fail]];
  145.     $c=Together[$f*$u/$du];
  146.     If[Not[FreeQ[$c,X]],Return[Fail]];
  147.     $c]
  148.  
  149. TableMatch[$f_*E^$u_]:=
  150.   Block[{$c},
  151.     Condition[
  152.       $c*ExpIntegralEi[$u],
  153.       $c=TableC2[$f,$u];
  154.       Not[SameQ[$c,Fail]]]]
  155.  
  156. TableMatch[$f_*Cos[$u_]]:=
  157.   Block[{$c},
  158.     Condition[
  159.       $c*CosIntegral[$u],
  160.       $c=TableC2[$f,$u];
  161.       Not[SameQ[$c,Fail]]]]
  162.  
  163. TableMatch[$f_*Sin[$u_]]:=
  164.   Block[{$c},
  165.     Condition[
  166.       $c*SinIntegral[$u],
  167.       $c=TableC2[$f,$u];
  168.       Not[SameQ[$c,Fail]]]]
  169.  
  170. TableMatch[$f_*Cosh[$u_]]:=
  171.   Block[{$c},
  172.     Condition[
  173.       $c*CoshIntegral[$u],
  174.       $c=TableC2[$f,$u];
  175.       Not[SameQ[$c,Fail]]]]
  176.  
  177. TableMatch[$f_*Sinh[$u_]]:=
  178.   Block[{$c},
  179.     Condition[
  180.       $c*SinhIntegral[$u],
  181.       $c=TableC2[$f,$u];
  182.       Not[SameQ[$c,Fail]]]]
  183.  
  184. TableMatch[Exp[X] ExpIntegralEi[-X] ]:=
  185.   Exp[X] ExpIntegralEi[X] - Log[X]
  186.  
  187. TableMatch[Exp[b_. X] ExpIntegralEi[a_. X] ] :=
  188.   Condition[
  189.     (Exp[b X] ExpIntegralEi[a X] + Log[1 + b/a] -
  190.             ExpIntegralEi[(a + b)X])/b,
  191.     FreeQ[{a, b}, X] && !TrueQ[b/a==-1]]
  192.  
  193. TableMatch[$a_^($b_^($c_.*X+$d_.))]:=
  194.   Condition[
  195.     ExpIntegralEi[$b^($c*X+$d)*Log[$a]]/($c*Log[$b]),
  196.     FreeQ[{$a,$b,$c,$d},X]]
  197.  
  198. TableMatch[Cos[$a_.*X+$b_.]/($c_.*X+$d_.)]:=
  199.   Condition[
  200.     Block[{$u,$v},
  201.       $u=$b-$a*$d/$c;
  202.       $v=$a*X+$a*$d/$c;
  203.       1/$c*Cos[$u]*CosIntegral[$v]-1/$c*Sin[$u]*SinIntegral[$v]],
  204.     FreeQ[{$a,$b,$c,$d},X]]
  205.     
  206. TableMatch[Sin[$a_.*X+$b_.]/($c_.*X+$d_.)]:=
  207.   Condition[
  208.     Block[{$u,$v},
  209.       $u=$b-$a*$d/$c;
  210.       $v=$a*X+$a*$d/$c;
  211.       1/$c*Sin[$u]*CosIntegral[$v]+1/$c*Cos[$u]*SinIntegral[$v]],
  212.     FreeQ[{$a,$b,$c,$d},X]]
  213.     
  214. TableMatch[$g_^($a_.*X^$n_.)/X]:=
  215.   Condition[
  216.     ExpIntegralEi[$a*Log[$g]*X^$n]/$n,
  217.     FreeQ[{$g,$a,$n},X]]
  218.  
  219. TableMatch[Cos[$a_.*X^$n_.]/X]:=
  220.   Condition[
  221.     CosIntegral[$a*X^$n]/$n,
  222.     FreeQ[{$a,$n},X]]
  223.   
  224. TableMatch[Sin[$a_.*X^$n_.]/X]:=
  225.   Condition[
  226.     SinIntegral[$a*X^$n]/$n,
  227.     FreeQ[{$a,$n},X]]
  228.  
  229. TableMatch[Sin[X]/($a_.+$b_.*X)]:=
  230.   Condition[
  231.     (SinIntegral[X+$a/$b]*Cos[$a/$b]/$b
  232.      - CosIntegral[X+$a/$b]*Sin[$a/$b]/$b),
  233.     FreeQ[{$a,$b},X]]
  234.  
  235. TableMatch[Cos[X]/($a_.+$b_.*X)]:=
  236.   Condition[
  237.     (CosIntegral[X+$a/$b]*Cos[$a/$b]/$b
  238.      + SinIntegral[X+$a/$b]*Sin[$a/$b]/$b),
  239.     FreeQ[{$a,$b},X]]
  240.  
  241. TableMatch[Log[X] Sin[X]]:=
  242.   CosIntegral[X] - Cos[X] Log[X]
  243.  
  244. TableMatch[Cos[X] Log[X]]:=
  245.   Log[X] Sin[X] - SinIntegral[X]
  246.  
  247. TableMatch[1/Log[$a_.*X+$b_.]]:=
  248.   Condition[
  249.     LogIntegral[$a*X+$b]/$a,
  250.     FreeQ[{$a,$b},X]]
  251.  
  252. TableMatch[X^$n_./Log[X]]:=
  253.   Condition[
  254.     ExpIntegralEi[($n+1)*Log[X]],
  255.     FreeQ[$n, X] && !TrueQ[$n==-1]]
  256.     
  257. TableMatch[$f_./Log[$u_]]:=
  258.   Block[{$du,$c},
  259.     Condition[
  260.       $c*LogIntegral[$u],
  261.       $c=TableC1[$f,$u];
  262.       Not[SameQ[$c,Fail]]]]
  263.  
  264. (* ****************************************************************
  265. *
  266. *     ExpIntegralE
  267. *
  268. **************************************************************** *)
  269.  
  270. TableMatch[$f_*ExpIntegralE[$n_,$u_]]:=
  271.   Block[{$c},
  272.     Condition[
  273.       $c*ExpIntegralE[$n+1,$u],
  274.       $c=TableC1[-$f,$u];
  275.       And[FreeQ[$n,X],Not[SameQ[$c,Fail]]]]]
  276.  
  277. (* ****************************************************************
  278. *
  279. *     Erf, Erfi, FresnelC, FresnelS
  280. *
  281. **************************************************************** *)
  282.  
  283. TableMatch[E^($a_.*X^2)]:=
  284.   Condition[
  285.     Block[{$sqrta},
  286.       $sqrta=AlgebraicRoot[$a,1/2];
  287.       1/2*Pi^(1/2)*Erfi[$sqrta*X]/$sqrta],
  288.     FreeQ[$a,X]]
  289.  
  290. TableMatch[E^($a_.*X^2+$b_.*X+$c_.)]:=
  291.   Condition[
  292.     Block[{$sqrta},
  293.       $sqrta=AlgebraicRoot[$a,1/2];
  294.       ((1/2*E^(-$b^2/(4*$a) + $c)*Pi^(1/2)*Erfi[$sqrta*($b/(2*$a) + X)])
  295.       /$sqrta)],
  296.     FreeQ[{$a,$b,$c},X]]
  297.  
  298. TableMatch[$g^($a_.*X^2)]:=
  299.   Condition[
  300.     Block[{$sqrta},
  301.       $sqrta=AlgebraicRoot[$a,1/2];
  302.       (1/2*Pi^(1/2)*Erfi[$sqrta*X*Log[$g]^(1/2)])/($sqrta*Log[$g]^(1/2))],
  303.     FreeQ[{$g,$a},X]]
  304.  
  305. TableMatch[$g_^($a_.*X^2+$b_.*X+$c_.)]:=
  306.   Condition[
  307.     Block[{$sqrta},
  308.       $sqrta=AlgebraicRoot[$a,1/2];
  309.       (($g^(-$b^2/(4*$a)+$c)*Pi^(1/2)*
  310.        Erfi[(($b+2*$a*X)*Log[$g]^(1/2))/(2*$sqrta)])/
  311.        (2*$sqrta*Log[$g]^(1/2)))],
  312.     FreeQ[{$g,$a,$b,$c},X]]
  313.  
  314. TableCSquared[$f_,$u_]:=
  315.   (* Non-zero constant c==f^2*u/du^2 or Fail. *)
  316.   Block[{$c,$du},
  317.     If[FreeQ[$u,X],Return[Fail]];
  318.     $du=Together[D[$u,X]];
  319.     If[$du==0,Return[Fail]];
  320.     $c=Together[$f^2*$u/$du^2];
  321.     If[Not[FreeQ[$c,X]],Return[Fail]];
  322.     $c]
  323.  
  324. TableMatch[$f_*E^$g_]:=
  325.   Block[{$dg,$csquared,$sqrtg,$c,$u},
  326.     Condition[
  327.       Block[{},
  328.         $dg=Together[D[$g,X]];
  329.         $sqrtg=AlgebraicRoot[$g,1/2];
  330.         $c=Together[2*$f/$dg*$sqrtg];
  331.         $u=Together[$c*$dg/(2*$f)];
  332.     Sqrt[Pi]/2*$c*Erfi[$u]],
  333.       Not[SameQ[TableCSquared[$f,$g],Fail]]]]
  334.  
  335. TableMatch[$f_.*Cos[$g_]]:=
  336.   Block[{$dg,$csquared,$sqrtg,$c,$u},
  337.     Condition[
  338.       Block[{},
  339.         $dg=Together[D[$g,X]];
  340.         $sqrtg=AlgebraicRoot[$g,1/2];
  341.         $c=Together[Sqrt[2]*Sqrt[Pi]*$f/$dg*$sqrtg];
  342.         $u=Together[$c*$dg/(Pi*$f)];
  343.     $c*FresnelC[$u]],
  344.       Not[SameQ[TableCSquared[$f,$g],Fail]]]]
  345.  
  346. TableMatch[$f_.*Sin[$g_]]:=
  347.   Block[{$dg,$csquared,$sqrtg,$c,$u},
  348.     Condition[
  349.       Block[{},
  350.         $dg=Together[D[$g,X]];
  351.         $sqrtg=AlgebraicRoot[$g,1/2];
  352.         $c=Together[Sqrt[2]*Sqrt[Pi]*$f/$dg*$sqrtg];
  353.         $u=Together[$c*$dg/(Pi*$f)];
  354.     $c*FresnelS[$u]],
  355.       Not[SameQ[TableCSquared[$f,$g],Fail]]]]
  356.  
  357. (* ****************************************************************
  358. *
  359. *     PolyLog
  360. *
  361. **************************************************************** *)
  362.  
  363. TableMatch[Log[X]/(X-1)]:=
  364.   -PolyLog[2,1-X]
  365.  
  366. TableMatch[Log[X]/(1-X)]:=
  367.   PolyLog[2,1-X]
  368.  
  369. TableMatch[Log[1-X]/X]:=
  370.   -PolyLog[2,X]
  371.   
  372. TableMatch[Log[a_.*X+b_]/X]:=
  373.   Condition[
  374.     Log[a*X+b]*Log[-a*X/b]+PolyLog[2, a X/b+1],
  375.     FreeQ[{a,b},X]]
  376.  
  377. TableMatch[Log[X]/(a_.*X+b_)]:=
  378.   Condition[
  379.     Log[X]*Log[a*X/b+1]/a+PolyLog[2,-a*X/b]/a,
  380.     FreeQ[{a,b},X]]
  381.  
  382. TableMatch[Log[a_.*X+b_.]/(c_.*X+d_.)]:=
  383.   Condition[
  384.     (Log[a X + b] Log[a (c X + d)/(a d - b c)]/c
  385.      +PolyLog[2, c (a X + b)/(b c - a d)]/c),
  386.     FreeQ[{a,b,c,d}, X] && !TrueQ[a d - b c == 0]]
  387.  
  388. TableMatch[PolyLog[n_Integer?Positive,X]/X]:=
  389.   PolyLog[n+1,X]
  390.   
  391. TableMatch[X^$m_.*PolyLog[$n_,X]]:=
  392.   Condition[
  393.     Block[{$c,$sum1,$sum2},
  394.       $c=-1;
  395.       $sum1=Sum[$c=-$c/($m+1);
  396.                 $c*X^($m+1)*PolyLog[$n-$i,X],
  397.             {$i,0,$n-2}];
  398.       $c=-$c/($m+1);
  399.       $sum2=-$c*X^($m+1)*Log[1-X]+$c*Log[1-X];
  400.       $sum3=Sum[$c*X^$i/$i,{$i,1,$m+1}];
  401.       $sum1+$sum2+$sum3],
  402.     And[SameQ[Head[$m],Integer],
  403.         SameQ[Head[$n],Integer],
  404.     $m>0,$n>0]]
  405.   
  406. TableMatch[$f_*Log[$g_]]:=
  407.   Block[{$c},
  408.     Condition[
  409.       $c*PolyLog[2,$u],
  410.       $c=TableC2[-$f,1-$g];
  411.       Not[SameQ[$c,Fail]]]]
  412.  
  413. TableMatch[$f_.*PolyLog[$n_,$u_]]:=
  414.   Block[{$c},
  415.     Condition[
  416.       $c*PolyLog[$n+1,$u],
  417.       $c=TableC2[$f,$u];
  418.       And[FreeQ[$n,X],Not[SameQ[$c,Fail]]]]]
  419.  
  420. (* ****************************************************************
  421. *
  422. *     Gamma, PolyGamma
  423. *
  424. **************************************************************** *)
  425.  
  426. TableMatch[$f_.*Gamma[$u_]*PolyGamma[$u_]]:=
  427.   Block[{$c},
  428.     Condition[
  429.       $c*Gamma[$u],
  430.       $c=TableC1[$f,$u];
  431.       Not[SameQ[$c,Fail]]]]
  432.  
  433. TableMatch[$f_.*PolyGamma[$n_,$u_]]:=
  434.   Block[{$c},
  435.     Condition[
  436.       $c*PolyGamma[$n-1,$u],
  437.       $c=TableC1[$f,$u];
  438.       And[FreeQ[$n,X],Not[SameQ[$c,Fail]]]]]
  439.  
  440. TableMatch[E^(-X)*X^$a_]:=
  441.   Condition[
  442.     -Gamma[$a+1,X],
  443.     FreeQ[$a,X]]
  444.  
  445. (* ****************************************************************
  446. *
  447. *     EllipticF, EllipticE, EllipticPi
  448. *
  449. **************************************************************** *)
  450.  
  451. TableMatch[$f_.*(1-$m_*Sin[$phi_]^2)^(-1/2)]:=
  452.   Block[{$dphi,$c},
  453.     Condition[
  454.       $c*EllipticF[$phi,$m],
  455.       $c=TableC1[$f,$phi];
  456.       And[FreeQ[$m,X],Not[SameQ[$c,Fail]]]]]
  457.  
  458. TableMatch[$f_.*(1-$m_*Sin[$phi_]^2)^(1/2)]:=
  459.   Block[{$dphi,$c},
  460.     Condition[
  461.       $c*EllipticE[$phi,$m],
  462.       $c=TableC1[$f,$phi];
  463.       And[FreeQ[$m,X],Not[SameQ[$c,Fail]]]]]
  464.  
  465. (* TBW:  This rule is OK, but there seems to be something wrong with
  466.    the way it is being called. *)
  467. TableMatch[$f_.*(1-$m_*Sin[$phi_]^2)^(-1/2)*(1-$n_*Sin[$phi_]^2)^(-1)]:=
  468.   Block[{$dphi,$c},
  469.     Condition[
  470.       $c*EllipticPi[$n,$phi,$m],
  471.       $c=TableC1[$f,$phi];
  472.       And[FreeQ[{$m,$n},X],Not[SameQ[$c,Fail]]]]]
  473.  
  474. (* ****************************************************************
  475. *
  476. *     TrigRules
  477. *
  478. *(1) These rules are used to clean up answers from integrals like
  479. *Integrate[E^(a*x)*Cos[b*x],x].  This is a somewhat hackish way
  480. *to avoid expressions like (a+I*b)(a-I*b)in the answer.  Not the
  481. *perfect solution, though.
  482. **************************************************************** *)
  483.  
  484. TrigRules=
  485.   {Times[($x_+$y_)^$n_.,($x_+$z_)^$n_.]:>
  486.      Condition[
  487.        ($x^2-$y^2)^$n,
  488.        And[IntegerQ[$n],SameQ[$y+$z,0]]],
  489.    Times[($x_+$z_)^$n_.,($y_+$z_)^$n_.]:>
  490.      Condition[
  491.        (-$x^2+$z^2)^$n,
  492.        And[IntegerQ[$n],SameQ[$x+$y,0]]]}
  493.  
  494. Protect[ TableLookUp]
  495.  
  496. End[]
  497.  
  498. Null
  499.  
  500.  
  501.  
  502.