(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



\[HBar] = 1;
\[Beta]Simplify[expr_]:=expr // Together // ExpandDenominator // ExpandNumerator;
SetAttributes[\[Beta]Collect, Listable];
\[Beta]Collect[B[\[Omega]_, \[Mu]_]] := B[
\[Beta]Simplify[\[Omega]],
Collect[\[Mu], _h, Collect[#, _t, \[Beta]Simplify]&]
];
(* "L" for "Labels" *)
hL[\[Beta]_] := Union[Cases[\[Beta], h[s_] :> s, Infinity]];
tL[\[Beta]_] := Union[Cases[\[Beta], t[s_]|Subscript[c, s_] :> s, Infinity]];
dL[\[Beta]_] := Union[hL[\[Beta]], tL[\[Beta]]];
\[Beta]Form[B[\[Omega]_, \[Mu]_]] := Module[
{tails, heads, mat},
tails = tL[B[\[Omega], \[Mu]]]; heads = hL[B[\[Omega], \[Mu]]];
mat = Outer[\[Beta]Simplify[Coefficient[\[Mu], h[#1] t[#2]]]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Prepend[Transpose[mat], Prepend[h /@ heads, \[Omega]]];
MatrixForm[mat]
];
\[Beta]Form[else_] := else /. \[Beta]_B :> \[Beta]Form[\[Beta]];
Format[\[Beta]_B, StandardForm] := \[Beta]Form[\[Beta]];
B /: B[\[Omega]1_, \[Mu]1_] == B[\[Omega]2_, \[Mu]2_] := Module[
{heads, tails},
tails = tL[{B[\[Omega]1, \[Mu]1], B[\[Omega]2, \[Mu]2]}];
heads = hL[{B[\[Omega]1, \[Mu]1], B[\[Omega]2, \[Mu]2]}];
(\[Omega]1 == \[Omega]2) && (
And @@ Flatten[Outer[
(Coefficient[\[Mu]1, t[#1]h[#2]] == Coefficient[\[Mu]2, t[#1]h[#2]])&,
tails, heads
]]
)
]


PerturbativeSolveAlways[eqs_, h_, deg_Integer, cs_List] := Module[
{eqns, sol, nsol, d},
eqns = eqs /. ser_SeriesData :> Normal[ser]/. (lhs_==rhs_ :> lhs-rhs==0);
sol = SolveAlways[eqns /. \[HBar]->0, cs];
If[Length[sol]>1,Print["Warning: multiple solutions in degree 0"]];
sol=First@sol;
nsol=SolveAlways[eqns /. sol /. \[HBar]^_ :> 0 /. \[HBar] -> 1,cs];
If[Length[nsol]>1,Print["Warning: multiple solutions in degree 1"]];
nsol=First@nsol;
sol=Join[sol /. nsol, nsol];
Do[
nsol=SolveAlways[eqns /. sol /. \[HBar]^n_ /; n>d :> 0 /. \[HBar] -> 1,cs];
If[Length[nsol]>1,Print["Warning: multiple solutions in degree ", d]];
nsol=First@nsol;
sol=Join[sol /. nsol, nsol],
{d,2,deg}
];
sol
]


tm[x_, y_, z_][\[Beta]_] := \[Beta]Collect[\[Beta] /. {t[x]->t[z], t[y]->t[z], Subscript[c, x]->Subscript[c, z], Subscript[c, y]->Subscript[c, z]}];
t\[CapitalDelta][z_, x_, y_][\[Beta]_] := \[Beta]Collect[\[Beta] /. {t[z] -> t[x]+t[y], Subscript[c, z] -> Subscript[c, x]+Subscript[c, y]}];
t\[Eta][x_][\[Beta]_] := \[Beta]Collect[(\[Beta] /. t[x] -> 0) /. Subscript[c, x]->0];
tS[x_][\[Beta]_] := \[Beta]Collect[\[Beta] /. {t[x] -> -t[x], Subscript[c, x] -> -Subscript[c, x]}];
tA[_][\[Beta]_] := \[Beta]Collect[\[Beta]];
tP[rules___Rule][\[Beta]_] := \[Beta]Collect[
\[Beta] /. {t[x_] :> t[x /. {rules}], Subscript[c, x_] :> Subscript[c, x /. {rules}]}
];


hm[x_, y_, z_][B[\[Omega]_, \[Mu]_]] := Module[
{\[Gamma]x= D[\[Mu], h[x]], \[Gamma]y=D[\[Mu], h[y]], M=\[Mu] /. h[x]|h[y] -> 0},
B[\[Omega], M+h[z](\[Gamma]x+\[Gamma]y+(\[Gamma]x /. t[i_] :> \[HBar] Subscript[c, i])\[Gamma]y)] // \[Beta]Collect
];
h\[CapitalDelta][z_, x_, y_][\[Beta]_] := \[Beta]Collect[\[Beta] /. h[z] -> h[x]+h[y]];
h\[Eta][x_][\[Beta]_] := \[Beta]Collect[\[Beta] /. h[x] -> 0];
hS[x_][B[\[Omega]_, \[Mu]_]] := Module[{\[Gamma]},
\[Gamma] = 1 + D[\[Mu], h[x]] /. t[s_]:>\[HBar] Subscript[c, s];
\[Beta]Collect[B[\[Omega], \[Mu] /. h[x] -> -h[x]/\[Gamma]]]
];
hA[x_][\[Beta]_] := hS[x][\[Beta]];
hP[rules___Rule][\[Beta]_] := \[Beta]Collect[\[Beta] /. h[x_] :> h[x /. {rules}]];


thswap[x_,y_][B[\[Omega]_, \[Mu]_]] := Module[
{\[Alpha], \[Beta], \[Gamma], \[Delta], \[Epsilon]},
\[Alpha] = Coefficient[\[Mu], h[y]t[x]];
\[Beta] = D[\[Mu], t[x]] /. h[y] -> 0;
\[Gamma] = D[\[Mu], h[y]] /. t[x] -> 0;
\[Delta] = \[Mu] /. h[y]|t[x] -> 0;
\[Epsilon] = 1+\[HBar] Subscript[c, x]\[Alpha];
B[\[Omega]*\[Epsilon], Plus[
\[Alpha](1+(\[Gamma] /. t[i_] :> \[HBar] Subscript[c, i])/\[Epsilon])h[y]t[x],
\[Beta](1+(\[Gamma] /. t[i_] :> \[HBar] Subscript[c, i])/\[Epsilon])t[x],
\[Gamma]/\[Epsilon] h[y],
\[Delta]-\[HBar] Subscript[c, x]/\[Epsilon] \[Gamma]*\[Beta]
]] // \[Beta]Collect
];
htswap[x_, y_][\[Beta]_] := \[Beta] // hS[x] // thswap[y,x] // hS[x];


dm[x_,y_,z_][\[Beta]_] := \[Beta] // thswap[x,y] // hm[x,y,z] // tm[x,y,z];
d\[CapitalDelta][z_, x_, y_][\[Beta]_] := \[Beta] // t\[CapitalDelta][z,x,y] // h\[CapitalDelta][z,x,y];
dS[s_][\[Beta]_] := \[Beta] // htswap[s,s] // hS[s] // tS[s];
dA[s_][\[Beta]_] := \[Beta] // htswap[s,s] // hA[s] // tA[s];
d\[Eta][s_][\[Beta]_] := \[Beta] // h\[Eta][s] // t\[Eta][s];
dcap[s_][\[Beta]_] := \[Beta] // htswap[s,s] // h\[Eta][s];
dP[rules___][\[Beta]_] := \[Beta] // hP[rules] // tP[rules];
dP[pl_List][\[Beta]_] := Module[
{\[Sigma], len, \[Beta]1, k},
len=Length[pl];
\[Beta]1 = \[Beta] // (dP @@ Table[i-> \[Sigma][i], {i, len}]);
Do[
k=pl[[i,1]];
\[Beta]1=\[Beta]1 // dP[\[Sigma][i] -> k];
Do[
\[Beta]1 = \[Beta]1 // d\[CapitalDelta][k, k, pl[[i,j]]],
{j,2, Length[pl[[i]]]}
],
{i, len}
];
\[Beta]1
];
dP[pl___Integer] := dP[IntegerDigits /@ {pl}];


B /: B[\[Omega]1_, \[Mu]1_]B[\[Omega]2_, \[Mu]2_] := B[\[Omega]1*\[Omega]2, \[Mu]1+\[Mu]2];


Unprotect[NonCommutativeMultiply];
\[Beta]_ ** \[Nu]_ := Module[
{\[Rho], \[Sigma], labels},
\[Rho] = \[Beta]*(\[Nu] /. {h[s_] :> h[\[Sigma][s]], t[s_] :> t[\[Sigma][s]], Subscript[c, s_] :> Subscript[c, \[Sigma][s]]});
labels = Union[Cases[{\[Beta],\[Nu]}, h[s_]|t[s_]|Subscript[c, s_] :> s, Infinity]];
Do[
\[Rho] = \[Rho] // dm[s, \[Sigma][s], s],
{s, labels}
];
\[Rho]
];
B /: Inverse[B[\[Omega]_, \[Mu]_]] := Module[
{\[Rho] = B[1, \[Mu]]},
Do[\[Rho] = \[Rho] // dA[s], {s, dL[\[Rho]]}];
ReplacePart[\[Rho], 1 -> 1/\[Omega]] // \[Beta]Collect
];


R[x_, y_, p_] := \[Beta]Collect[B[1, (E^(p \[HBar] Subscript[c, x])-1)/(\[HBar] Subscript[c, x])*t[x]h[y]]];
R[x_, y_] := R[x,y,1];
Ri[x_, y_] := R[x,y,-1];
\[CapitalTheta][x_,y_,p_]:=(R[x,x,p/2] // d\[CapitalDelta][x,x,y])**R[x,x,-p/2]**R[y,y,-p/2];
\[CapitalTheta][x_,y_] := \[CapitalTheta][x,y,1];
\[CapitalTheta]i[x_,y_] := \[CapitalTheta][x,y,-1];


HardR4[V_] := (R[2,3]**R[1,3]**V)==(V**(R[1,3] // d\[CapitalDelta][1,1,2]));
TwistEq[V_] := V**\[CapitalTheta][1,2]==R[1,2]**(V // dP[2,1]);
CapEquation[V_, Cap_] := (V**(Cap // dP[12])  // dcap[1] // dcap[2]) == (Cap(Cap // dP[2]) // dcap[1] // dcap[2]);
\[CapitalPhi][V_] := (Inverse[V] // dP[12,3])**Inverse[V]**(V // dP[2,3])**(V // dP[1,23]);
Pentagon[\[CapitalPhi]_] := \[CapitalPhi] ** (\[CapitalPhi] // dP[1,23,4]) ** (\[CapitalPhi] // dP[2,3,4]) == (\[CapitalPhi] // dP[12,3,4])**(\[CapitalPhi] // dP[1,2,34]);
Hexagon[s_, \[CapitalPhi]_] := Equal[
\[CapitalTheta][1,2,s]//dP[12,3],
\[CapitalPhi]**\[CapitalTheta][2,3,s]**Inverse[\[CapitalPhi]//dP[1,3,2]]**\[CapitalTheta][1,3,s]**(\[CapitalPhi]//dP[3,1,2])
];
Rot120[\[Beta]_] := \[Beta] // dS[2] // d\[CapitalDelta][2,2,3] // dm[1,3,1] // dP[2,1];



