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



<< KnotTheory`


\[Beta]Simplify=Simplify;
SetAttributes[\[Beta]Collect, Listable];
\[Beta]Collect[B[\[Omega]_, \[Sigma]_, \[Mu]_]] := B[
\[Beta]Simplify[\[Omega]], \[Sigma],
Collect[\[Mu], _h, Collect[#, _t, \[Beta]Simplify]&]
];
hL[b_] := Union[Cases[b, h[s_] :> s, Infinity]];
tL[b_] := Union[Cases[b, t[s_]|Subscript[T, s_] :> s, Infinity]];
dL[b_] := Union[hL[b], tL[b]];
\[Sigma]_ \[RightTee]h_ := (\!\(
\*SubscriptBox[\(\[PartialD]\), \(h\)]\[Sigma]\) /. 0->1);
B[\[Omega]_, \[Sigma]_, \[Mu]_]@A := Module[
{tails, heads},
tails = tL[B[\[Omega], \[Sigma], \[Mu]]]; heads = hL[B[\[Omega], \[Sigma], \[Mu]]];
Outer[\[Beta]Simplify[\!\(
\*SubscriptBox[\(\[PartialD]\), \(t[#1], h[#2]\)]\[Mu]\)]&, tails, heads]
];
\[Beta]Form[B[\[Omega]_, \[Sigma]_, \[Mu]_]] := Module[
{tails, heads, mat},
tails = tL[B[\[Omega], \[Sigma], \[Mu]]]; heads = hL[B[\[Omega], \[Sigma], \[Mu]]];
mat = Outer[\[Beta]Simplify[\!\(
\*SubscriptBox[\(\[PartialD]\), \(h[#1], t[#2]\)]\[Mu]\)]&, heads, tails];
PrependTo[mat, t /@ tails];
mat = Join[
{Prepend[h /@ heads, \[Omega]]},
Transpose[mat],
{Prepend[(\[Sigma]\[RightTee]h[#])& /@ heads, "1+\[CapitalSigma]/\[Omega]"]}
];
MatrixForm[mat]
];
\[Beta]Form[else_] := else /. b_B :> \[Beta]Form[b];
Format[b_B, StandardForm] := \[Beta]Form[b];
B /: B[\[Omega]1_, \[Sigma]1_, \[Mu]1_] == B[\[Omega]2_, \[Sigma]2_, \[Mu]2_] := Module[
{heads, tails},
tails = tL[{B[\[Omega]1, \[Sigma]1, \[Mu]1], B[\[Omega]2, \[Sigma]2, \[Mu]2]}];
heads = hL[{B[\[Omega]1, \[Sigma]1, \[Mu]1], B[\[Omega]2, \[Sigma]2, \[Mu]2]}];
(\[Omega]1 == \[Omega]2) && (\[Sigma]1==\[Sigma]2) && (
And @@ Flatten[Outer[
(Coefficient[\[Mu]1, t[#1]h[#2]] == Coefficient[\[Mu]2, t[#1]h[#2]])&,
tails, heads
]]
)
];

B /: B[\[Omega]1_, \[Sigma]1_, \[Mu]1_]B[\[Omega]2_, \[Sigma]2_, \[Mu]2_] := B[\[Omega]1*\[Omega]2, \[Sigma]1+\[Sigma]2, \[Omega]2 \[Mu]1+\[Omega]1 \[Mu]2];
tm[x_, y_, z_][b_] := b /. {t[x]->t[z], t[y]->t[z], Subscript[T, x]->Subscript[T, z], Subscript[T, y]->Subscript[T, z]};
hm[x_, y_, z_][B[\[Omega]_, \[Sigma]_, \[Mu]_]] := B[\[Omega], 
h[z](\[Sigma]\[RightTee]h[x])(\[Sigma]\[RightTee]h[y])+(\[Sigma] /. h[x]|h[y] -> 0),
h[z](D[\[Mu], h[x]] + (\[Sigma]\[RightTee]h[x])\!\(
\*SubscriptBox[\(\[PartialD]\), \(h[y]\)]\[Mu]\)) + (\[Mu] /. h[x]|h[y] -> 0)
] // \[Beta]Collect;
swapth[y_,x_][B[\[Omega]_, \[Sigma]_, \[Mu]_]] := Module[
{\[Alpha], \[Beta], \[Gamma], \[Delta]},
({
 {\[Alpha], \[Beta]},
 {\[Gamma], \[Delta]}
})=({
 {Coefficient[\[Mu], t[y]h[x]], D[\[Mu], t[y]] /. h[x] -> 0},
 {D[\[Mu], h[x]] /. t[y] -> 0, \[Mu] /. h[x]|t[y] -> 0}
});
B[\[Omega]+\[Alpha], \[Sigma], {(\[Sigma]\[RightTee]h[x])t[y], 1}.({
 {\[Alpha], \[Beta]},
 {\[Gamma], ((\[Omega]+\[Alpha])\[Delta]-\[Gamma]*\[Beta])/\[Omega]}
}).{h[x], 1}] // \[Beta]Collect
];
dm0[x_,y_,z_][b_] := b // swapth[x,y] // hm[x,y,z] // tm[x,y,z];
dm[a_,b_,c_][B[\[Omega]0_, \[Sigma]_, \[Mu]_]] := Module[
{\[Omega],\[Alpha],\[Beta],\[Gamma],\[Delta],\[Theta],\[Epsilon],\[Phi],\[Psi],\[CapitalXi],\[Sigma]a,\[Sigma]b},
\[Omega]=\[Omega]0 /. {Subscript[T, a]->Subscript[T, c], Subscript[T, b]->Subscript[T, c]};
{\[Sigma]a,\[Sigma]b} = {\[Sigma]\[RightTee]h[a], \[Sigma]\[RightTee]h[b]} /. {Subscript[T, a]->Subscript[T, c], Subscript[T, b]->Subscript[T, c]};
({
 {\[Alpha], \[Beta], \[Theta]},
 {\[Gamma], \[Delta], \[Epsilon]},
 {\[Phi], \[Psi], \[CapitalXi]}
})=({
 {\!\(
  \*SubscriptBox[\(\[PartialD]\), \(t[a], h[a]\)]\[Mu]\), \!\(
  \*SubscriptBox[\(\[PartialD]\), \(t[a], h[b]\)]\[Mu]\), \!\(
  \*SubscriptBox[\(\[PartialD]\), \(t[a]\)]\[Mu]\) /. h[a]|h[b] -> 0},
 {\!\(
  \*SubscriptBox[\(\[PartialD]\), \(t[b], h[a]\)]\[Mu]\), \!\(
  \*SubscriptBox[\(\[PartialD]\), \(t[b], h[b]\)]\[Mu]\), \!\(
  \*SubscriptBox[\(\[PartialD]\), \(t[b]\)]\[Mu]\) /. h[a]|h[b] -> 0},
 {\!\(
  \*SubscriptBox[\(\[PartialD]\), \(h[a]\)]\[Mu]\) /. t[a]|t[b] -> 0, \!\(
  \*SubscriptBox[\(\[PartialD]\), \(h[b]\)]\[Mu]\) /. t[a]|t[b] -> 0, \[Mu] /. t[a]|t[b]|h[a]|h[b] -> 0}
}) /. {Subscript[T, a]->Subscript[T, c], Subscript[T, b]->Subscript[T, c]};
B[\[Omega]+\[Beta],
h[c]\[Sigma]a \[Sigma]b+(\[Sigma] /. h[a]|h[b] -> 0 /. {Subscript[T, a]->Subscript[T, c], Subscript[T, b]->Subscript[T, c]}),
{t[c],1}.({
 {\[Gamma]+\[Sigma]a \[Delta]+\[Sigma]b(\[Alpha]+\[Sigma]a \[Beta])+(\[Beta] \[Gamma] - \[Alpha] \[Delta])/\[Omega], \[Epsilon]+\[Sigma]b \[Theta]+(\[Beta] \[Epsilon]-\[Delta] \[Theta])/\[Omega]},
 {\[Phi]+\[Sigma]a \[Psi]+(\[Beta] \[Phi]-\[Alpha] \[Psi])/\[Omega], \[CapitalXi]+(\[Beta] \[CapitalXi]-\[Psi] \[Theta])/\[Omega]}
}).{h[c],1}
] // \[Beta]Collect
]

Unprotect[NonCommutativeMultiply];
b1_B ** b2_B := Module[
{\[Rho], \[Sigma], labels},
\[Rho] = b1*(b2 /. {h[s_] :> h[\[Sigma][s]], t[s_] :> t[\[Sigma][s]], Subscript[T, s_] :> Subscript[T, \[Sigma][s]]});
labels = dL[{b1,b2}];
Do[\[Rho] = \[Rho] // dm[s, \[Sigma][s], s], {s, labels}];
\[Rho]
];

\[Beta]bRp[x_, y_] := B[1, Subscript[T, x]h[y], (Subscript[T, x]-1)*t[x]h[y]];
\[Beta]bRm[x_, y_] := B[1, h[y]/Subscript[T, x], (1/Subscript[T, x]-1)*t[x]h[y]];

\[Beta]bZ[L_] := Module[{s, Z, c, k},
s=Skeleton[L];
Z=Times@@PD[L] /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]], \[Beta]bRp[l,i], \[Beta]bRm[j,i]];
Do[Z = Z // dm[s[[c,1]], s[[c,k]], s[[c,1]]], {c, Length[s]},{k, 2, Length[s[[c]]]}];
Z]


\[Beta]bMVA[L_Link] := Module[{Hs, \[Omega], \[Sigma], \[Mu], A, M},
{\[Omega],\[Sigma],\[Mu]} = List @@ \[Beta]bZ[L];
Hs = Rest[h /@ (First /@ Skeleton[L])];
A=Outer[Coefficient[\[Mu], #1*#2]&,Hs, Hs /. h[a_] :> t[a]];
M=A-\[Omega] DiagonalMatrix[((\[Sigma]\[RightTee]#)-1)& /@ Hs];
Factor[(\[Omega]^(2-Length@Skeleton@L) Det[M])/(1-Subscript[T, Skeleton[L][[1,1]]])]
]



