scalarEDCcode

version 3.6.7 - June 2008

To start a new set of calculations, just re-evaluate this notebook without first quitting the kernel. All symbols defined previously and all In/Out lines will be cleared, though memory used will not be recovered.

Off[General::"spell", General::"spell1", Remove::"rmnsm", 
      UpSet::"write"];

Unprotect["Global`*"]; ClearAll["Global`*"]; 
    Remove["Global`*"]; ClearAll[Wedge]; Unprotect[In, Out]; 
    Clear[In, Out]; 
    Protect[In, Out]; $Line = 0; $RecursionLimit = 256; $IterationLimit = 
      4096;

Forms[i_] := {}; AllScalForms = {}; AllDifForms = {}; AllSymbols = {}; 
    FormVars = {_Wedge, _d}; HeadList = {}; ScalHeadList = {}; 
    nodHeads = {Bar, Pattern, Condition, RuleDelayed, SeriesData}; $EDCversion
       = 367;

zeroQ[0] = True; zeroQ[x_List] := And@@(zeroQ/@Union[Flatten[x]]); 
    zeroQ[x_SeriesData] := If[x[[3]] === {}, True, False]; 
    zeroQ[x_] := False;

SetAttributes[Bar, {Listable}]; Bar[Bar[x_]] = x; 
    Bar[Complex[u_, v_]] := Complex[u, -v]; 
    Bar[x_Plus | x_Times | x_Wedge | x_Power | x_Rule | x_Equal] := Bar/@x; 
    Bar[x_?NumericQ] := x; 
    Bar[x_RuleDelayed] := 
      Rule[Bar[x[[1]]], Bar[x[[2]]]] /. Rule -> RuleDelayed; 
    Bar[x_SeriesData] := 
      x /. {First[x] -> Bar[First[x]], x[[2]] -> Bar[x[[2]]], 
          x[[3]] -> Bar/@x[[3]]}; 
    Bar[DirectedInfinity[x_]] := DirectedInfinity[Bar[x]]; 
    Bar[d[x_]] := d[Bar[x]]; 
    Bar[x_Condition] := Condition[Bar[x[[1]]], x[[2]]]; 
    Bar[Derivative[x__][y_][z__]] := 
      If[Union[Bar[{z}]] === Union[{z}], 
        Derivative[Sequence@@Coefficient[{x}.{z}, Bar[{z}]]][Bar[y]][
          z], Derivative[x][Bar[y]][Sequence@@Bar[{z}]]]; 
    Bar[h_[y__] /; FreeQ[nodHeads, h]] := 
      If[Union[Bar[{y}]] === Union[{y}], Bar[h][y], 
          Bar[h][Sequence@@Bar[{y}]]] /; 
        FreeQ[{Integer, Blank, Pattern, Condition}, Head[First[{y}]]];

\(FormDegree[x_Plus] := FormDegree[First[x]]; 
    FormDegree[x_Times] := Plus@@\(FormDegree/@\(List@@x\)\); 

    FormDegree[x_Wedge] := Plus@@\(FormDegree/@\(List@@x\)\); 

    FormDegree[d[x_]] := \(FormDegree[d[x]] = 1 + FormDegree[x]\); 

    FormDegree[x_List] := FormDegree[Last[Union[Flatten[x]]]]; 

    FormDegree[Bar[x_]] := \(FormDegree[Bar[x]] = FormDegree[x]\); 
    FormDegree[x_SeriesData] := 
      If[x[\([3]\)] === {}, 0, FormDegree[x[\([3]\)]]]; 

    FormDegree[x_] := 0; \)

\(\(DeclareForms[z__] := 
      Block[{h, x = {{z}}, xi, rxi, k, oldHeads, newHeads}, 
        While[Head[x[\([1, 1]\)]] === List, x = First[x]]; 
        Do[xi = x[\([i]\)]; rxi = Rest[xi]; 
          Forms[First[xi]] = Union[Forms[First[xi]], rxi]; 
          
AllScalForms = Union[AllScalForms, rxi]; 
          
Do[h = Head[rxi[\([j]\)]]; 
            If[h === Symbol, FormDegree[rxi[\([j]\)]] = First[xi]; 
              \(BasicScalFormQ[rxi[\([j]\)]] = True; \), 
              FormDegree[_h] = First[xi]; BasicScalFormQ[_h] = True; ], {j, 
              Length[rxi]}], {i, Length[x]}]; 
        
AllDifForms = Union[AllScalForms]; 
        oldHeads = ScalHeadList; 
        ScalHeadList = 
          Complement[Union[Head/@AllScalForms, ScalHeadList], {Symbol}]; 
        newHeads = Complement[ScalHeadList, oldHeads]; 
        AllSymbols = Union[AllDifForms]; 
        
HeadList = Union[Head/@AllSymbols]; 
        DifFormSymbols = Drop[AllDifForms, \(-Length[ScalHeadList]\)]; 

        k = Thread[Blank[ScalHeadList]]; 
        FormVars = 
          Flatten[{_Wedge, _d, Union[k, Bar[k]], 
              u_ | Bar[u_] /; MemberQ[DifFormSymbols, u], _tr}]; ]; \)\)

NoDif[z__] := (nodHeads = Union[nodHeads, Flatten[{z}]]; )

BasicScalFormQ[Bar[x_]] := BasicScalFormQ[x]; 
    BasicScalFormQ[_d] = True; BasicScalFormQ[x_] := False;

ScalFormQ[x_Times] := Or@@ScalFormQ/@List@@x; 
    ScalFormQ[x_Wedge | x_Plus] := And@@ScalFormQ/@List@@x; 
    ScalFormQ[x_] := BasicScalFormQ[x];

SetAttributes[d, {Listable}]; 
    d[x_Times | x_Wedge] := 
      d[First[x]]⋀Rest[x] + 
        (-1)^FormDegree[First[x]]*First[x]⋀d[Rest[x]]; 
    d[x_?NumericQ | x_d] = 0; 
    d[Power[y_, n_]] := n y^(n - 1) d[y] + y^n Log[y] d[n]; 
    d[x_Plus] := d/@x; 
    HoldPattern[d[Bar[x_]]] := 
      With[{evalHx = d[x]}, Bar[evalHx] /; Head[evalHx] =!= d]; 
    d[x_Rule | x_Equal] := reWrite[d/@x]; 
    d[x_SeriesData] := 
      (x /. x[[3]] -> d[x[[3]]]) + 
        Wedge[d[First[x]], D[x, First[x]]]; 
    d[h_[y__] /; FreeQ[nodHeads, h]] := 
      Sum[(Derivative[
                    Sequence@@
                      RotateRight[Append[Table[0, {Length[{y}] - 1}], 1], i]]
                    [h][y]) d[{y}[[i]]], {i, Length[{y}]}] /; 
        FormDegree[h[y]] === 0 && 
          FreeQ[{Integer, Blank, Pattern, Condition}, Head[First[{y}]]];

newSer$[x_SeriesData, k_] := 
      SeriesData[First[x], x[[2]], 
        Flatten[Transpose[
            Prepend[Table[Table[0, {Length[x[[3]]]}], {k - 1}], 
              x[[3]]]]], k x[[4]], k x[[5]], k Last[x]]

Wedge[x_] := x /; Length[{x}] < 2 && Head[{x}[[1]]] =!= Pattern

\(Default[Wedge] := 1; SetAttributes[Wedge, {Flat, OneIdentity}]; 
    Wedge[0, y__] = 0; Wedge[x__, 0] = 0; 
    Wedge[x_SeriesData, y_SeriesData] := 
      Block[{x$, y$, r1, r2, res, x3, y3}, 
          If[Last[x] === Last[y], x$ = x; y$ = y, 
            x$ = newSer$[x, LCM[Last[x], Last[y]]/Last[x]]; 
            y$ = newSer$[y, LCM[Last[x], Last[y]]/Last[y]]]; 
          r1 = x$[\([\(-3\)]\)] + y$[\([\(-3\)]\)]; 
          r2 = Min[x$[\([\(-2\)]\)] + y$[\([\(-3\)]\)], 
              x$[\([\(-3\)]\)] + y$[\([\(-2\)]\)]]; 
          If[Length[x$[\([3]\)]] < x$[\([\(-2\)]\)] - x$[\([\(-3\)]\)], 
            x3 = Join[x$[\([3]\)], 
                Table[0, {
                    x$[\([\(-2\)]\)] - x$[\([\(-3\)]\)] - 
                      Length[x$[\([3]\)]]}]], x3 = x$[\([3]\)]]; 
          If[Length[y$[\([3]\)]] < y$[\([\(-2\)]\)] - y$[\([\(-3\)]\)], 
            y3 = Join[y$[\([3]\)], 
                Table[0, {
                    y$[\([\(-2\)]\)] - y$[\([\(-3\)]\)] - 
                      Length[y$[\([3]\)]]}]], y3 = y$[\([3]\)]]; 
          Which[r2 === r1, res = {}, 
            r2 - r1 === x$[\([\(-2\)]\)] - x$[\([\(-3\)]\)], 
            res = Sum[
                Map[Wedge[x3[\([i]\)], #]&, 
                  Join[Table[0, {i - 1}], Drop[y3, \(-i\) + 1]]], {i, 
                  Length[x3]}], True, 
            res = Sum[
                Map[Wedge[#, y3[\([i]\)]]&, 
                  Join[Table[0, {i - 1}], Drop[x3, \(-i\) + 1]]], {i, 
                  Length[y3]}]]; 
          SeriesData[First[x$], x$[\([2]\)], res, r1, r2, Last[x$]]] /; 
        First[x] === First[y] && x[\([2]\)] === y[\([2]\)]; 
    Wedge[y_, x_SeriesData] := 
      x /. x[\([3]\)] -> Map[Wedge[y, #]&, x[\([3]\)]]; 
    Wedge[x_SeriesData, y_] := 
      x /. x[\([3]\)] -> Map[Wedge[#, y]&, x[\([3]\)]]; 

    Wedge[x__, y_Plus] := Plus@@Map[Wedge[x, #]&, List@@y]; 

    Wedge[x_Plus, y__] := Plus@@Map[Wedge[#, y]&, List@@x]; 
    Wedge[u__, Times[x_, y_]] := 
      Times[x, Wedge[u, y]] /; NumericQ[x] || FormDegree[x] === 0; 

    Wedge[Times[x_, y_], z__] := 
      Times[x, Wedge[y, z]] /; NumericQ[x] || FormDegree[x] === 0; 
    x_^n_.⋀y_\  := x^n*y /; FormDegree[x] === 0; 

    y_⋀x_^n_. := x^n*y /; FormDegree[x] === 0; 

    Wedge[x_, y___, x_] := 0 /; OddQ[FormDegree[x]] && ScalFormQ[x]; 
    Wedge[x__] := 
      Block[{doubL = Transpose[{FormDegree/@{x}, {x}}]}, 
          Signature[Select[doubL, OddQ[First[#]]&]] 
            Wedge@@Map[Last[#1]&, Sort[doubL]]] /; 
        Union[BasicScalFormQ/@{x}] === {True} && 
          Map[Last[#1]&, Sort[Transpose[{FormDegree/@{x}, {x}}]]] =!= {x}; 
    \)

simpRules  =  {Cos[z_]^2*(x_.) + (x_.)*Sin[z_]^2  ->  x}; 
    varList = {};

coll[x_] := Collect[x, {_Wedge, _tr}, Factor] /. simpRules;

SetAttributes[reWrite, {Listable}]; reWrite[0] = 0; 
    reWrite[x_Equal] := Equal[reWrite[First[x] - Last[x]], 0]; 
    reWrite[x_Rule] := Rule[First[x], reWrite[Last[x]]]; 
    reWrite[x_RuleDelayed] := 
      Rule[First[x], reWrite[x[[2]]]] /. Rule -> RuleDelayed; 
    reWrite[x_SeriesData] := (x /. x[[3]] -> reWrite[x[[3]]]); 
    reWrite[x_Condition] := Condition[reWrite[x[[1]]], x[[2]]]; 
    reWrite[x_] := 
      (Collect[coll[x /. simpRules], FormVars, bestFacRul] /. simpRules)
           /; FormDegree[x] > 0; 
    reWrite[x_] := bestFacRul[x /. simpRules] /. simpRules;

FreeALLQ[x_, y_List] := And@@Map[FreeQ[x, #]&, y];

bestFacRul[x_] := 
      If[varList === {} || FreeALLQ[x, varList], minFacRul[x], varFacRul[x]]; 
    varFacRul[x_] := 
      Collect[Expand[x] /. simpRules, varList, Factor] /. simpRules; 
    minFacRul[x_] := Factor[Expand[x] /. simpRules] /. simpRules;

Unprotect[SeriesData]; 
    If[$VersionNumber < 5, Times[x_SeriesData, 0] ^= 0]; 
    SeriesData[x1_, x2_, x3_, x4_, x5_, x6_] :=  
      Plus@@If[x2 === Infinity, 
            Map[First[#]/x1^((x4 + Last[#] - 1)/x6)&, 
                Transpose[{x3, Range[Length[x3]]}]] + 
              SeriesData[x1, x2, {}, x4, x5, x6],    
            Map[First[#]*(x1 - x2)^((x4 + Last[#] - 1)/x6)&, 
                Transpose[{x3, Range[Length[x3]]}]] + 
              SeriesData[x1, x2, {}, x4, x5, x6]] /; ! FreeQ[x3, x1]; 
    Protect[SeriesData];

On[General::"spell", General::"spell1", UpSet::"write"];