(* ::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.                                                         *)
(************************************************************************)



\[Beta]Simplify=Factor;


ar[i_,j_] := t[i]h[j];


W /: W[a_] + W[b_] := W[\[Beta]Simplify[a*b]];
W /: n_*W[a_] := W[\[Beta]Simplify[a^n]];


SetAttributes[\[Beta]Collect, Listable];
\[Beta]Collect[\[Beta]_] := Collect[\[Beta], _h, Collect[#, _t, \[Beta]Simplify]&] /. W[ws_] :> W[\[Beta]Simplify[ws]];
(* "L" for "Labels" *)
hL[\[Beta]_] := Union[Cases[\[Beta], h[s_] :> s, Infinity]];
tL[\[Beta]_] := Union[Cases[\[Beta], (t|c)[s_] :> s, Infinity]];
dL[\[Beta]_] := Union[hL[\[Beta]], tL[\[Beta]]];
SetAttributes[\[Beta]Form, Listable];
\[Beta]Form[\[Beta]_] := Module[
{tails, heads, mat},
tails = tL[\[Beta]]; heads = hL[\[Beta]];
mat = Outer[\[Beta]Simplify[Coefficient[\[Beta], h[#1] t[#2]]]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Prepend[Transpose[mat], Prepend[h /@ heads, \[Beta] /. (h[_]|t[_]) -> 0]];
MatrixForm[mat]
];
\[Beta]Equations[\[Beta]1_ == \[Beta]2_] := Module[
{tails, heads, l1,l2},
tails = tL[{\[Beta]1, \[Beta]2}]; heads = hL[{\[Beta]1, \[Beta]2}];
l1 = Flatten[Outer[\[Beta]Simplify[Coefficient[\[Beta]1, h[#1] t[#2]]]&, heads, tails]];
l2 = Flatten[Outer[\[Beta]Simplify[Coefficient[\[Beta]2, h[#1] t[#2]]]&, heads, tails]];
Append[
MapThread[Equal, {l1, l2}],
(\[Beta]1==\[Beta]2) /. (h[_]|t[_]) -> 0 /. W[\[Omega]_] :> \[Omega]
]
];


DeWheel[\[Beta]_] := Module[
{heads, \[Xi]s, nheads},
heads = Union[Cases[\[Beta], h[s_] :> s, Infinity]];
\[Xi]s = (D[\[Beta], h[#]] /. t[s_] :>c[s])& /@ heads;
nheads = MapThread[(h[#1]*Log[1+#2]/#2)&, {heads, \[Xi]s}];
\[Beta]Collect[\[Beta] /. Thread[(h/@heads) -> nheads]]
];
Wheel[\[Alpha]_] := Module[
{heads, \[Eta]s, nheads},
heads = Union[Cases[\[Alpha], h[s_] :> s, Infinity]];
\[Eta]s = (D[\[Alpha], h[#]] /. t[s_] :>c[s])& /@ heads;
nheads = MapThread[(h[#1]*(Exp[#2]-1)/#2)&, {heads, \[Eta]s}];
\[Beta]Collect[\[Alpha] /. Thread[(h/@heads) -> nheads]]
];


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


hm[x_,y_,z_][\[Beta]_] := Module[
{\[Xi], \[Eta]},
\[Xi] = D[\[Beta], h[x]];
\[Eta] = D[\[Beta], h[y]];
\[Beta]Collect[(\[Beta] /. h[x|y]->0) + \[Xi] h[z] + (1+\[Xi] /. t[s_]:>c[s])\[Eta] h[z]]
];
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_][\[Beta]_] := Module[{\[Gamma]},
\[Gamma] = 1 + D[\[Beta], h[x]] /. t[s_]:>c[s];
\[Beta]Collect[\[Beta] /. h[x] -> -h[x]/\[Gamma]]
];
hA[x_][\[Beta]_] := hS[x][\[Beta]];
hP[rules___Rule][\[Beta]_] := \[Beta]Collect[\[Beta] /. h[x_] :> h[x /. {rules}]];


hfac[z_, xtails_List -> x_, y_][\[Beta]_] := Module[
{ytails},
ytails = Complement[
Union[Cases[\[Beta], t[s_] :> s, Infinity]],
xtails
];
hfac[z,xtails -> x, ytails -> y][\[Beta]]
];
hfac[z_, x_,  ytails_List -> y_][\[Beta]_] := Module[
{xtails},
xtails = Complement[
Union[Cases[\[Beta], t[s_] :> s, Infinity]],
ytails
];
hfac[z,xtails -> x, ytails -> y][\[Beta]]
];
hfac[z_, xtails_List -> x_, ytails_List -> y_][\[Beta]_] := Module[
{\[Zeta], \[Xi], \[Eta]},
\[Zeta] = D[\[Beta], h[z]];
\[Xi] = \[Zeta] /. ((t[#]->0)& /@ ytails);
\[Eta] = \[Zeta] /. ((t[#]->0)& /@ xtails);
\[Beta]Collect[\[Beta]-h[z]\[Zeta] + h[x]\[Xi] + h[y]\[Eta]/(1+\[Xi] /. t[s_]->c[s])]
]


conj[y_,x_][\[Beta]_] := Module[
{\[Nu], x0, x1, \[Gamma], \[Xi], \[Eta], a},
\[Nu] = \[Beta] // hfac[x, {y} -> x0, x1];
\[Gamma] = Coefficient[\[Nu], ar[y,x0]];
\[Nu] = \[Beta]Collect[\[Nu] /. W[ws_] :> W[ws*(c[y]\[Gamma]+1)]];
\[Xi] = D[\[Nu], h[x1]];
\[Eta] = D[\[Nu], t[y]];
a = 1 + \[Xi] /. t[s_] :> c[s];
\[Nu] = \[Beta]Collect[(\[Nu] /. t[y] -> a t[y]) -c[y] \[Xi] \[Eta]];
\[Nu] // hm[x0,x1,x]
];
conji[y_,x_][\[Beta]_] := \[Beta] // hS[x] // conj[y,x] // hS[x];


dm[x_,y_,z_][\[Beta]_] := \[Beta] // conji[y,x] // hm[x,y,z] // tm[x,y,z];
d\[CapitalDelta][z_, x_, y_][\[Beta]_] := \[Beta] // h\[CapitalDelta][z,x,y] // t\[CapitalDelta][z,x,y];
d\[Eta][x_][\[Beta]_] := \[Beta] // h\[Eta][x] // t\[Eta][x];
dS[x_][\[Beta]_] := \[Beta] // tS[x] // conj[x,x] // hS[x];
dA[x_][\[Beta]_] := \[Beta] // tA[x] // conj[x,x] // hA[x];
dP[rules___Rule][\[Beta]_] := \[Beta] // hP[rules] // tP[rules];
dP[ks__Integer][\[Beta]_] := \[Beta] // (dP @@ Thread[Range[Length[{ks}]] -> {ks}]);
dd[k_][\[Beta]_] := Module[
{shifts},
shifts = Select[dL[\[Beta]], (#>k)&];
\[Beta] // (dP @@ Thread[shifts -> (1+shifts)]) // d\[CapitalDelta][k, k, k+1]
];


Unprotect[NonCommutativeMultiply];
\[Beta]_ ** \[Nu]_ := Module[
{\[Rho], \[Sigma], labels},
\[Rho] = \[Beta] + (\[Nu] /. {h[s_] :> h[\[Sigma][s]], t[s_] :> t[\[Sigma][s]], c[s_] :> c[\[Sigma][s]]});
labels = Union[Cases[{\[Beta],\[Nu]}, h[s_]|t[s_]|c[s_] :> s, Infinity]];
Do[
\[Rho] = \[Rho] // dm[s, \[Sigma][s], s],
{s, labels}
];
\[Rho]
]


R[i_, j_] := W[1]+ar[i,j](E^c[i]-1)/c[i];
RInv[i_, j_] /; i!=j := R[i,j] // dS[i];
(* R[i, i, p] is R[i,i]^p. Two cases were computed in "120103 Calculator.nb", the rest guessed and checked there. *)
R[i_, i_, p_] := W[1]+(-1+E^(p*c[i]))/c[i] ar[i,i];
RInv[i_, i_] := R[i,i,-1];


Rot90[\[Beta]_] := \[Beta] // dP[2,1] // dS[1]


Rot120[\[Beta]_] := \[Beta] // dS[2] // d\[CapitalDelta][2,2,3] // dm[1,3,1] // dP[2,1]



