Scatter and Glow - Experiments

December 29, 2008

Cleaning Exponentiation

The Two F Equations

F0=S[Exp[a1 Ar[2,1]+a2 Ar[1,2]]] /. (Sqrt[(((a2 x[1]+a1 x[2]))^2)]) -> (a2 x[1]+a1 x[2])

eq1=(
Coefficient[Ar[3,0] // S[Exp[Ar[1,3]+Ar[2,3]]] // F, Y[1,2,0]]
== Coefficient[Ar[3,0] // F // S[sigma[1,3],sigma[2,3]], Y[1,2,0]]
)

F21=S[Exp[a1 Ar[1,2]+a2 Ar[2,1]+Y[2,1,2,f1]+Y[2,1,1,f2]]]

F=S[Exp[a1 Ar[2,1]+a2 Ar[1,2]+Y[1,2,1,f1]+Y[1,2,2,f2]]]

December 28, 2008

Ar[2,1] // S[Exp[Ar[2,1]]]

Ar[2,1] // S[Exp[Ar[2,1]+Ar[3,1]]]

S[Exp[Ar[2,1]]]

S[Exp[Ar[2,1]+Ar[3,1]]]

December 27, 2008

R4 Work

F=S[Exp[(-1/2) Ar[2,1]+(0)Ar[1,2]+Y[1,2,1,f1]+Y[1,2,2,0]]];

Ar[3,0] // S[Exp[Ar[1,3]+Ar[2,3]]] // F

Ar[3,0] // F // S[sigma[1,3],sigma[2,3]]

Solve[
Coefficient[Ar[3,0] // S[Exp[Ar[1,3]+Ar[2,3]]] // F, Y[1,2,0]]
== Coefficient[Ar[3,0] // F // S[sigma[1,3],sigma[2,3]], Y[1,2,0]],
f1
]

Series[(((E^((x[2])/2)) (-1+(E^(x[1]))) (x[1]+x[2]))/((-1+(E^(x[1]+x[2]))) x[1])) /. x[i_] :> h x[i], {h,0,2}]

Der[Y[1,1,1,1]]

Der[Y[1,1,2,1]]

Der[Y[1,2,1,1]]

Der[Y[2,1,1,1]]

Der[Y[1,2,3,2]]

{Der[Ar[1,3]][Y[1,2,2,1]], Der[Ar[2,3]][Y[1,2,2,1]], Der[Ar[3,1]][Y[1,2,2,1]],Der[Ar[3,2]][Y[1,2,2,1]]}

Table[
ReducePrimitives[
Der[Y[1,2,2,1]]@Ar[i,j] + Der[Ar[i,j]]@Y[1,2,2,1]
],{i,3},{j,3}
] // MatrixForm

Der[Y[1,2,1,f1]+Y[1,2,2,f2]]

S[Exp[Y[1,2,1,f1]+Y[1,2,2,f2]]]

drules=Sequence@@Der[Y[1,2,1,f1]+Y[1,2,2,f2]]

k0 = Length[ins = First /@ {drules}]

ins

k0 = Length[ins = Take[ins, -2]]

outs={};
For[k=1, k≤Length[ins], ++k,
AppendTo[outs, newout=Der[drules][ins[[k]]]];
ins = ins ~Join~ Complement[
Union[Cases[{newout}, Y[ijk___, _] :> Y[ijk, 1], Infinity]],
ins
]
];
--k;

ins

outs

zero=Table[0,{k}];
e[{{i_}}] := ReplacePart[zero, 1, i];
mat = Replace[
outs /. Y[ijk__, h_] :> -h e[Position[ins, Y[ijk,1]]],
0 -> zero,
{1}
];

mat // MatrixForm

ReducePrimitives[Take[SH[MatrixExp[mat]].ins, k0]]

expmat=SH[PowerExpand[MatrixExp[mat]]]

ReducePrimitives[Take[SH[MatrixExp[mat]].ins, k0]] /. (Sqrt[(((f1-f2))^2) ((x[1])^2) ((x[2])^2)]) -> (f1-f2)x[1]x[2]

Union[Cases[expmat, Sqrt[y_] :> y, Infinity]]

BCH Work

S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bc]]]

Coefficient[
Ar[0,1] // S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bc]]],
Y[0,1,3]
]

bch = bc /. First[Solve[
Coefficient[
Ar[0,1] // S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bc]]],
Y[0,1,3]
] == Coefficient[
Ar[0,1] // S[sigma[1,3],sigma[2,3]],
Y[0,1,3]
],
bc
]]

S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bch]]]

S[sigma[1,3],sigma[2,3]]

S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bch]]]==S[sigma[1,3],sigma[2,3]]

drules=Sequence@@Der[Ar[1,3]+Ar[2,3]+Y[1,2,3,bch]]

ins

k0 = Length[ins = First /@ {drules}]

outs={};
For[k=1, k≤Length[ins], ++k,
AppendTo[outs, newout=Der[drules][ins[[k]]]];
ins = ins ~Join~ Complement[
Union[Cases[{newout}, Y[ijk___, _] :> Y[ijk, 1], Infinity]],
ins
]
];
--k;

ins

Print /@ outs;

zero=Table[0,{k}];
e[{{i_}}] := ReplacePart[zero, 1, i];
mat = Replace[
outs /. Y[ijk__, h_] :> -h e[Position[ins, Y[ijk,1]]],
0 -> zero,
{1}
]

MatrixExp[mat] // MatrixForm

SH[MatrixExp[mat]] // MatrixForm

(1-(E^x-1)(x+y)/x/(E^(x+y)-1))/y

Simplify[(1/y)(1-(((E^x)-1)/x) ((x+y)/((E^(x+y))-1)))]

bch

Simplify[(bch /. {x[1]->x, x[2]->y})]

Test[Simplify[(bch /. {x[1]->x, x[2]->y}) ==(1/y)(1-(((E^x)-1)/x) ((x+y)/((E^(x+y))-1)))]]

December 26, 2008

drules=Sequence@@Der[Ar[1,3]+Ar[2,3]+Y[1,2,3,f[x[1],x[2]]]]

drules=Sequence@@Der[Ar[1,2]]

k0 = Length[ins = First /@ {drules}];
outs={};
For[k=1, k≤Length[ins], ++k,
AppendTo[outs, newout=Der[drules][ins[[k]]]];
ins = ins ~Join~ Complement[
Union[Cases[{newout}, Y[ijk___, _] :> Y[ijk, 1], Infinity]],
ins
]
];
--k;
zero=Table[0,{k}];
e[{{i_}}] := ReplacePart[zero, 1, i];
mat = Replace[
outs /. Y[ijk__, h_] :> -h e[Position[ins, Y[ijk,1]]],
0 -> zero,
{1}
];
S @@ Sort[Thread[
Take[ins, k0] -> 
ReducePrimitives[Take[MatrixExp[mat].ins, k0]]
]]

S[sigma[1,2]]

MatrixExp[mat] //Simplify// MatrixForm

ins

outs

k0

Cases[outs, _f, Infinity]

Length[ins]

Length[outs]

BCH Work

S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bch]]]/. Y[ijk__,h_] :> Y[ijk, Factor[h]]

Ar[0,1] // S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bch]]]

Coefficient[
Ar[0,1] // S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bch]]],
Y[0,1,3]
]

Ar[0,1] // S[sigma[2,3],sigma[1,3]]

Coefficient[
Ar[0,1] // S[sigma[1,3],sigma[2,3]],
Y[0,1,3]
]

bch = bch /. First[Solve[
Coefficient[
Ar[0,1] // S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bch]]],
Y[0,1,3]
] == Coefficient[
Ar[0,1] // S[sigma[1,3],sigma[2,3]],
Y[0,1,3]
],
bch
]]

S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bch]]] /. Y[ijk__,h_] :> Y[ijk, Simplify[h]]

S[sigma[1,3],sigma[2,3]]/. Y[ijk__,h_] :> Y[ijk, Simplify[h]]

Factor[(((x[1])/((((-1+(E^(x[1]+x[2]))))^2) (x[1]+x[2])))-((2 (E^(x[1]+x[2])) x[1])/((((-1+(E^(x[1]+x[2]))))^2) (x[1]+x[2])))+(((E^(2 x[1]+2 x[2])) x[1])/((((-1+(E^(x[1]+x[2]))))^2) (x[1]+x[2])))+((x[2])/((((-1+(E^(x[1]+x[2]))))^2) (x[1]+x[2])))-((2 (E^(x[1]+x[2])) x[2])/((((-1+(E^(x[1]+x[2]))))^2) (x[1]+x[2])))+(((E^(2 x[1]+2 x[2])) x[2])/((((-1+(E^(x[1]+x[2]))))^2) (x[1]+x[2]))))]

Compare with Kurlin

Simplify[(bch /. {x[1] -> x, x[2] -> y})== (1-(E^x-1)(x+y)/x/(E^(x+y)-1))/y]