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



(* ::Input::Initialization:: *)
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\MetaCalculi"];
Once[<< KnotTheory`]


(* ::Input::Initialization:: *)
Subscript[R, a_,b_] :=\[CapitalGamma]@<|\[FinalSigma]->{Subscript[t, a],Subscript[t, b],Subscript[h, a],Subscript[h, b]},\[Omega]->1,\[Sigma]->Subscript[h, a]+Subscript[h, b] Subscript[T, a],\[Lambda]->{Subscript[t, a],Subscript[t, b]} . ({
 {Subscript[T, a], 1-Subscript[T, a]},
 {0, 1}
}) . {Subscript[h, a],Subscript[h, b]}|>;
Subscript[\!\(\*OverscriptBox[\(R\), \(_\)]\), a_,b_]:= \[CapitalGamma]@<|\[FinalSigma]->{Subscript[t, b],Subscript[t, a],Subscript[h, b],Subscript[h, a]},\[Omega]->1,\[Sigma]->Subscript[h, a]+Subscript[h, b] \!\(\*SubsuperscriptBox[\(T\), \(a\), \(-1\)]\),\[Lambda]->{Subscript[t, a],Subscript[t, b]} . ({
 {\!\(\*SubsuperscriptBox[\(T\), \(a\), \(-1\)]\), 1-\!\(\*SubsuperscriptBox[\(T\), \(a\), \(-1\)]\)},
 {0, 1}
}) . {Subscript[h, a],Subscript[h, b]}|>;


(* ::Input::Initialization:: *)
\[CapitalGamma][\[Alpha]_][\[Kappa]_]:=\[Alpha][\[Kappa]];
\[CapitalGamma][\[Alpha]_][S]:=Union@Cases[\[Alpha][\[FinalSigma]],Subscript[t, a_]:>a,\[Infinity]];
\[CapitalGamma][\[Alpha]_][n]:=Length[\[CapitalGamma][\[Alpha]][S]];
\[CapitalGamma][\[Alpha]_][\[CapitalSigma]] := (\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(h\), \(#\)]]\(\[Alpha][\[Sigma]]\)\))& /@ \[CapitalGamma][\[Alpha]][S];
\[CapitalGamma][\[Alpha]_][A] := Outer[Factor[\!\(
\*SubscriptBox[\(\[PartialD]\), \(#1, #2\)]\(\(\[CapitalGamma][\[Alpha]]\)[\[Lambda]]\)\)]&, Cases[\[Alpha][\[FinalSigma]],Subscript[t, _]], Cases[\[Alpha][\[FinalSigma]],Subscript[h, _]]];


(* ::Input::Initialization:: *)
\[CapitalGamma]Collect[\[Gamma]_\[CapitalGamma]]:=\[CapitalGamma][<|\[FinalSigma]->\[Gamma]@\[FinalSigma],\[Omega]->Factor@\[Gamma]@\[Omega],\[Sigma]->Expand@\[Gamma]@\[Sigma],
\[Lambda]->Total[CoefficientRules[\[Gamma]@\[Lambda],\[Gamma]@\[FinalSigma]]/.(ps_->c_):>Factor[c]Times@@((\[Gamma]@\[FinalSigma])^ps)]|>]


(* ::Input::Initialization:: *)
ConservativeQ[\[Gamma]_\[CapitalGamma]]:=Simplify[Expand[\[Gamma]@\[Lambda]/.Subscript[h, _]->1]==Sum[Subscript[t, a],{a,\[Gamma]@S}]]


(* ::Input::Initialization:: *)
T\[Conjugate]^:=T^-1;
Subscript[vpn, \[FinalSigma]_][c_,d_]:=Expand@Module[{e,f}, (* Vortex Pairing North *)
Expand[c(d/.{T->T\[Conjugate],Subscript[t, i_]:>Subscript[t, i]\[Conjugate],Subscript[h, i_]:>Subscript[h, i]\[Conjugate]})]/.{Subscript[t, i_]\[Conjugate] Subscript[t, i_]->0, Subscript[h, i_]\[Conjugate] Subscript[h, i_]->T-T\[Conjugate],Subscript[(f:t|h), j_]\[Conjugate] Subscript[(e:t|h), i_]:>If[Position[\[FinalSigma],Subscript[e, i]][[1,1]]<Position[\[FinalSigma],Subscript[f, j]][[1,1]],T-1,1-T\[Conjugate]]}
];
Subscript[vps, \[FinalSigma]_][c_,d_]:=Expand@Module[{e,f}, (* Vortex Pairing South (rel. to north, T->T\[Conjugate] and t\[LeftRightArrow]h) *)
Expand[c(d/.{T->T\[Conjugate],Subscript[t, i_]:>Subscript[t, i]\[Conjugate],Subscript[h, i_]:>Subscript[h, i]\[Conjugate]})]/.{Subscript[t, i_]\[Conjugate] Subscript[t, i_]->T\[Conjugate]-T, Subscript[h, i_]\[Conjugate] Subscript[h, i_]->0,Subscript[(f:t|h), j_]\[Conjugate] Subscript[(e:t|h), i_]:>If[Position[\[FinalSigma],Subscript[e, i]][[1,1]]<Position[\[FinalSigma],Subscript[f, j]][[1,1]],T\[Conjugate]-1,1-T]}
];
UnitaryQ[\[Gamma]_\[CapitalGamma]]:=Module[{vs},
vs=Table[-Subscript[t, i]+\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(t\), \(i\)]]\(\[Gamma]@\[Lambda]\)\)/.Subscript[T, _]->T,{i,\[Gamma]@S}];
And@@Flatten@Table[Simplify[Subscript[vpn, \[Gamma]@\[FinalSigma]][vs[[i]],vs[[j]]]==0==Subscript[vps, \[Gamma]@\[FinalSigma]][vs[[i]],vs[[j]]]],{i,\[Gamma]@n},{j,\[Gamma]@n}]
];


(* ::Input::Initialization:: *)
\[CapitalGamma]Form[\[Gamma]_\[CapitalGamma]] := Module[{M},
M = \[Gamma][A] // Transpose;
PrependTo[M, Subscript[t, #]& /@ \[Gamma][S]];
M = Join[
{Prepend[Subscript[h, #]& /@ \[Gamma][S], \[Gamma][\[Omega]]]},
Transpose[M],
{Prepend[\[Gamma][\[CapitalSigma]],If[TrueQ[ConservativeQ@\[Gamma]\[And]UnitaryQ@\[Gamma]],RGBColor[0, 1, 0],RGBColor[1, 0, 0]]]}
];
Column[{\[Gamma][\[FinalSigma]],MatrixForm[M]}]
];
\[CapitalGamma]Form[else_] := else /. \[Gamma]_\[CapitalGamma] :> \[CapitalGamma]Form[\[Gamma]];
Format[\[Gamma]_\[CapitalGamma], StandardForm] := \[CapitalGamma]Form[\[Gamma]];


(* ::Input::Initialization:: *)
Subscript[dm, i_\[InvisibleComma]j_->k_][\[Gamma]_\[CapitalGamma]] := Module[{a,b,c,d,\[Theta],\[Epsilon],\[Phi],\[Psi],\[CapitalXi],\[Mu]},
({
 {a, b, \[Theta]},
 {c, d, \[Epsilon]},
 {\[Phi], \[Psi], \[CapitalXi]}
})=({
 {\!\(
  \*SubscriptBox[\(\[PartialD]\), \(
   \*SubscriptBox[\(t\), \(i\)], 
   \*SubscriptBox[\(h\), \(i\)]\)]\(\[Gamma]@\[Lambda]\)\), \!\(
  \*SubscriptBox[\(\[PartialD]\), \(
   \*SubscriptBox[\(t\), \(i\)], 
   \*SubscriptBox[\(h\), \(j\)]\)]\(\[Gamma]@\[Lambda]\)\), \!\(
  \*SubscriptBox[\(\[PartialD]\), 
   SubscriptBox[\(t\), \(i\)]]\(\[Gamma]@\[Lambda]\)\)},
 {\!\(
  \*SubscriptBox[\(\[PartialD]\), \(
   \*SubscriptBox[\(t\), \(j\)], 
   \*SubscriptBox[\(h\), \(i\)]\)]\(\[Gamma]@\[Lambda]\)\), \!\(
  \*SubscriptBox[\(\[PartialD]\), \(
   \*SubscriptBox[\(t\), \(j\)], 
   \*SubscriptBox[\(h\), \(j\)]\)]\(\[Gamma]@\[Lambda]\)\), \!\(
  \*SubscriptBox[\(\[PartialD]\), 
   SubscriptBox[\(t\), \(j\)]]\(\[Gamma]@\[Lambda]\)\)},
 {\!\(
  \*SubscriptBox[\(\[PartialD]\), 
   SubscriptBox[\(h\), \(i\)]]\(\[Gamma]@\[Lambda]\)\), \!\(
  \*SubscriptBox[\(\[PartialD]\), 
   SubscriptBox[\(h\), \(j\)]]\(\[Gamma]@\[Lambda]\)\), \[Gamma]@\[Lambda]}
})/.Subscript[(t|h), i|j]->0;
\[CapitalGamma]Collect[\[CapitalGamma][<|
\[FinalSigma]->DeleteCases[\[Gamma]@\[FinalSigma],Subscript[h, i]|Subscript[t, j]]/.{Subscript[t, i]->Subscript[t, k],Subscript[h, j]->Subscript[h, k]},
\[Omega]->(\[Mu]=1-c)\[Gamma]@\[Omega],
\[Sigma]->Subscript[h, k](\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(h\), \(i\)]]\[Sigma]\))(\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(h\), \(j\)]]\[Sigma]\))+(\[Sigma] /. Subscript[h, i|j]->0),
\[Lambda]->{Subscript[t, k],1} . \!\(\*
TagBox[
RowBox[{"(", "", GridBox[{
{
RowBox[{"b", "+", 
RowBox[{"a", " ", 
RowBox[{"d", "/", "\[Mu]"}]}]}], 
RowBox[{"\[Theta]", "+", 
RowBox[{"a", " ", 
RowBox[{"\[Epsilon]", "/", "\[Mu]"}]}]}]},
{
RowBox[{"\[Psi]", "+", 
RowBox[{"d", " ", 
RowBox[{"\[Phi]", "/", "\[Mu]"}]}]}], 
RowBox[{"\[CapitalXi]", "+", 
RowBox[{"\[Epsilon]", " ", 
RowBox[{"\[Phi]", "/", "\[Mu]"}]}]}]}
},
GridBoxAlignment->{"Columns" -> {{Center}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.7]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}}], "", ")"}],
Function[BoxForm`e$, MatrixForm[BoxForm`e$]]]\) . {Subscript[h, k],1}
|>] /. {Subscript[T, i]->Subscript[T, k], Subscript[T, j]->Subscript[T, k]}]
];


(* ::Input::Initialization:: *)
\[CapitalGamma]/:RotateLeft[\[CapitalGamma][\[Alpha]_],n___]:=\[CapitalGamma]@ReplacePart[\[Alpha],Key@\[FinalSigma]->RotateLeft[\[Alpha]@\[FinalSigma],n]]


(* ::Input::Initialization:: *)
\[CapitalGamma]/:Insert[\[Gamma]1_\[CapitalGamma],\[Gamma]2_\[CapitalGamma],k_]:=\[CapitalGamma]@<|
\[FinalSigma]->Flatten[Insert[\[Gamma]1@\[FinalSigma],\[Gamma]2@\[FinalSigma],k]],
\[Omega]->\[Gamma]1@\[Omega] \[Gamma]2@\[Omega],
\[Sigma]->\[Gamma]1@\[Sigma]+\[Gamma]2@\[Sigma],
\[Lambda]->\[Gamma]1@\[Lambda]+\[Gamma]2@\[Lambda]
|>
\[CapitalGamma]/:Insert[\[Gamma]2_\[CapitalGamma],k_][\[Gamma]1_\[CapitalGamma]]:=Insert[\[Gamma]1,\[Gamma]2,k]


(* ::Input::Initialization:: *)
\[CapitalGamma][\[Alpha]_][NO\[Lambda]]:=Module[{\[FinalSigma]0=\[Alpha][\[FinalSigma]],hc},
hc=Thread[\[FinalSigma]0->Most@FoldList[Plus,0,If[MatchQ[#,Subscript[h, _]],1,0]&/@\[FinalSigma]0]];
Plus[
\[Alpha][\[Lambda]]/.Cases[\[FinalSigma]0,Subscript[t, i_]:>(Subscript[t, i]->\!\(
\*SubsuperscriptBox[\(T\), \(i\), \(-\((
\*SubscriptBox[\(t\), \(i\)] /. hc)\)\)] 
\*SubscriptBox[\(t\), \(i\)]\))],
Total@ReplaceList[\[FinalSigma]0,{___,Subscript[h, i_],___,Subscript[t, j_],___}:>\!\(
\*SubsuperscriptBox[\(T\), \(j\), \(-\((
\*SubscriptBox[\(h\), \(i\)] /. hc)\)\)] \((1 - 
\*SubsuperscriptBox[\(T\), \(j\), \(-1\)])\) 
\*SubscriptBox[\(h\), \(i\)] 
\*SubscriptBox[\(t\), \(j\)]\)]
]];
\[CapitalGamma][\[Alpha]_][NOA] := Outer[Factor[\!\(
\*SubscriptBox[\(\[PartialD]\), \(#1, #2\)]\(\(\[CapitalGamma][\[Alpha]]\)[NO\[Lambda]]\)\)]&, Cases[\[Alpha][\[FinalSigma]],Subscript[t, _]], Cases[\[Alpha][\[FinalSigma]],Subscript[h, _]]];



