(* ::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\\OU"];
<<KnotTheory`


(* ::Input::Initialization:: *)
SetAttributes[VD,Orderless]


(* ::Input::Initialization:: *)
bp[i_,j_]:=Subscript[\[Sigma], i,j]; bm[i_,j_]:=Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i,j];


(* ::Input::Initialization:: *)
Tidy[vd_VD]:=Module[{ps=Union@@(List@@@vd)},
Replace[vd,Thread[ps->Range@Length@ps],{2}] ]


(* ::Input::Initialization:: *)
R12Reduce1[vd_VD]:=Tidy@Module[{R2s,R2},Which[
Length[R2s=Cases[vd,Subscript[X, s_][i_,j_]:>Subscript[X, -s][i+1,j+1]]\[Intersection](List@@vd)]>0,
Complement[vd,VD[R2=First@R2s,R2/.Subscript[X, s_][i_,j_]:>Subscript[X, -s][i-1,j-1]]],
Length[R2s=Cases[vd,Subscript[X, s_][i_,j_]:>Subscript[X, -s][i+1,j-1]]\[Intersection](List@@vd)]>0,
Complement[vd,VD[R2=First@R2s,R2/.Subscript[X, s_][i_,j_]:>Subscript[X, -s][i-1,j+1]]],
True,DeleteCases[vd,Subscript[X, _][i_,j_]/;Abs[i-j]==1]  ]]


(* ::Input::Initialization:: *)
R12Reduce[vd_VD]:=FixedPoint[R12Reduce1,vd]


(* ::Input::Initialization:: *)
\[Gamma][vd_VD] :=Module[{js,s1,i1,j1,s2,i2,j2},
js=Cases[vd,Subscript[X, _][_,j_]:>j]\[Intersection]Cases[vd,Subscript[X, _][i_,_]:>i-1];
If[Length[js]==0,vd,
j1=RandomChoice[js]; i2=j1+1;
Cases[vd,Subscript[X, s_][i_,j1]:>(s1=s;i1=i)];
Cases[vd,Subscript[X, s_][i2,j_]:>(s2=s;j2=j)];
Tidy@Join[Complement[vd,VD[Subscript[X, s1][i1,j1],Subscript[X, s2][i2,j2]]],
VD[Subscript[X, s2][j1,j2],Subscript[X, s1][i1,i2],Subscript[X, s1 s2][i1-s1/3,j2+s2/3],Subscript[X, -s1 s2][i1+s1/3,j2-s2/3]]
]  ]]


(* ::Input::Initialization:: *)
\[CapitalGamma][vd_VD]:=FixedPoint[\[Gamma],vd,2^16]


(* ::Input::Initialization:: *)
\[CapitalGamma][T_] /; Head[T]=!=VD := \[CapitalGamma][VD[T]]


(* ::Input::Initialization:: *)
\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[vd_VD]:=FixedPoint[\[Gamma]@*R12Reduce,vd,2^16]


(* ::Input::Initialization:: *)
\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[T_] /; Head[T]=!=VD := \!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[VD[T]]


(* ::Input::Initialization:: *)
VPB[n_,{\[Sigma]s___}]:=VPB[n,\[Sigma]s];


(* ::Input::Initialization:: *)
VD /: vd1_VD **vd2_VD := Module[{es1, es2,m2},
es1=Cases[vd1,EOS[i_]:>i];
m2=Max[es2=Cases[vd2,EOS[i_]:>i]];
Tidy[vd1\[Union]Replace[DeleteCases[vd2,_EOS], i_:>i/m2-1+es1[[1+Count[es2,e_/;i>e]]], {2}]]
]


(* ::Input::Initialization:: *)
VD[VPB[n_]]:=VD@@(EOS/@Range[n]);
VD[VPB[n_,Subscript[\[Sigma], i_,j_]]]:=Tidy@Append[VD@@(EOS/@Range[n]),Subscript[X, +1][i-0.5,j-0.5]];
VD[VPB[n_,Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i_,j_]]]:=Tidy@Append[VD@@(EOS/@Range[n]),Subscript[X, -1][i-0.5,j-0.5]];
VD[VPB[n_,\[Sigma]_,\[Sigma]s__]]:=VD[VPB[n,\[Sigma]]]**VD[VPB[n,\[Sigma]s]]


(* ::Input::Initialization:: *)
VPBGenerators[n_]:=VPBGenerators[n]=Flatten@Table[{Subscript[\[Sigma], i,j],Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i,j]},{i,n},{j,DeleteCases[Range@n,i]}];


(* ::Input::Initialization:: *)
ProudFollowers[n_,Subscript[\[Sigma], i_,j_]] :=ProudFollowers[n,Subscript[\[Sigma], i,j]]=Module[{p,q,s},
Flatten@{Subscript[\[Sigma], i,j],Subscript[\[Sigma], j,i],Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), j,i],
Table[{Subscript[\[Sigma], p,q],Subscript[\[Sigma], q,p],Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), p,q],Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), q,p]},{p,{i,j}},{q,Complement[Range[n],{i,j}]}],
Table[{Subscript[\[Sigma], p,q],Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), p,q]},{p,Complement[Range[i+1,n],{j}]},{q,Complement[Range[n],{i,j,p}]}]
}];
ProudFollowers[n_,Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i_,j_]] := ProudFollowers[n,Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i,j]]=ProudFollowers[n,Subscript[\[Sigma], i,j]]/.Subscript[\[Sigma], i,j]->Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i,j]


(* ::Input::Initialization:: *)
ProudFollowers[n_,i_Integer]:=DeleteCases[Range[Max[Abs[i]-1,1],n-1]\[Union](-Range[Max[Abs[i]-1,1],n-1]),-i];


(* ::Input::Initialization:: *)
ProudVPBs[n_,0]:={VPB[n]};
ProudVPBs[n_,1]:=VPB[n,#]&/@VPBGenerators[n];
ProudVPBs[n_,m_]/;m>1:=Flatten[ProudVPBs[n,m-1]/.VPB[n,\[Sigma]s___,\[Sigma]_]:>(VPB[n,\[Sigma]s,\[Sigma],#]&/@ProudFollowers[n,\[Sigma]])]


(* ::Input::Initialization:: *)
CountOUForms[n_,m_]:=Module[{k},
Length@Union@Flatten@Table[\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)@vpb, {k,0,m},{vpb,ProudVPBs[n,k]}]]


(* ::Input::Initialization:: *)
ProudBs[n_,0]:={BR[n,{}]};
ProudBs[n_,1]:=BR[n,{#}]&/@(Range[n-1]\[Union](-Range[n-1]));
ProudBs[n_,m_]/;m>1:=Flatten[ProudBs[n,m-1]/.BR[n,{\[Sigma]s___,\[Sigma]_}]:>(BR[n,{\[Sigma]s,\[Sigma],#}]&/@ProudFollowers[n,\[Sigma]])]


(* ::Input::Initialization:: *)
CountBs[n_,m_]:=Module[{k},
Length@Union@Flatten@Table[\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)@b, {k,0,m},{b,ProudBs[n,k]}]]


(* ::Input::Initialization:: *)
AllBs[n_,m_]:=DeleteDuplicatesBy[\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)]@Flatten@Table[b, {k,0,m},{b,ProudBs[n,k]}]


(* ::Input::Initialization:: *)
AllOUs[n_,0]:={VD@@Flatten@Table[{BT[2i-1],EOS[2i]},{i,n}]};
AllOUs[n_,m_] /; m>0 := Sort@Flatten[AllOUs[n,m-1] /. vd_VD:>Module[{BTs,EOSs,k,maxO,s},
BTs=Sort@Cases[vd, BT[i_]:>i];
EOSs=Sort@Cases[vd, EOS[i_]:>i];
maxO=Max[1,Max[Cases[vd,Subscript[X, _][i_,_]:>i]]];
Table[
Tidy[Append[vd,Subscript[X, s][p-0.5,q+0.5]]],
{s,{-1,1}},{k,Length[BTs]},{q,BTs[[k]],EOSs[[k]]-1},{p,Select[BTs,(#>=maxO)&]}
]]]


(* ::Input::Initialization:: *)
AllROUs[n_,m_]:= Select[AllOUs[n,m]/.vd_VD:>Tidy@DeleteCases[vd,_BT], (#===R12Reduce[#])&]


(* ::Input::Initialization:: *)
\[Xi][vd_VD]:=Count[\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[vd], Subscript[X, _][_,_]]


(* ::Input::Initialization:: *)
VD/:(Subscript[\[Sigma], i_,j_]\[Divides]vd_VD):=Switch[Order[\[Xi][vd],\[Xi][VD[VPB[Count[vd,_EOS],Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i,j]]]**vd]],
0, Print["\!\(\*
StyleBox[\"OMG\",\nFontColor->RGBColor[1, 0, 0]]\)\!\(\*
StyleBox[\",\",\nFontColor->RGBColor[1, 0, 0]]\)\!\(\*
StyleBox[\" \",\nFontColor->RGBColor[1, 0, 0]]\)\!\(\*
StyleBox[\"Trouble\",\nFontColor->RGBColor[1, 0, 0]]\)\!\(\*
StyleBox[\"!\",\nFontColor->RGBColor[1, 0, 0]]\)"],
1, False, -1, True];
VD/:(Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i_,j_]\[Divides]vd_VD):=Switch[Order[\[Xi][vd],\[Xi][VD[VPB[Count[vd,_EOS],Subscript[\[Sigma], i,j]]]**vd]],
0, Print["\!\(\*
StyleBox[\"OMG\",\nFontColor->RGBColor[1, 0, 0]]\)\!\(\*
StyleBox[\",\",\nFontColor->RGBColor[1, 0, 0]]\)\!\(\*
StyleBox[\" \",\nFontColor->RGBColor[1, 0, 0]]\)\!\(\*
StyleBox[\"Trouble\",\nFontColor->RGBColor[1, 0, 0]]\)\!\(\*
StyleBox[\"!\",\nFontColor->RGBColor[1, 0, 0]]\)"],
1, False, -1, True];


(* ::Input::Initialization:: *)
VD/:Divisors[vd_VD]:=Select[VPBGenerators[Count[vd,_EOS]], (#\[Divides]vd)&];
VD/:Quotients[vd_VD]:=\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[VD[VPB[Count[vd,_EOS],#/.{\[Sigma]->\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\),\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\)->\[Sigma]}]]**vd]& /@ Divisors[vd];


(* ::Input::Initialization:: *)
OUGraph[n_,m_]:=Module[{gens,OUs,k,d,g,q,m1,m2},
gens=VPBGenerators[n];
OUs=Flatten@Table[AllROUs[n,k],{k,0,m}];
OURule=Dispatch@Thread[OUs->Range@Length@OUs];
Graph[
Range@Length@OUs,
Union@Flatten@Table[
m1=Count[d,Subscript[X, _][_,_]];
m2=Count[q=\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[VD[VPB[n,g]]**d],Subscript[X, _][_,_]];
If[m2<m1,Labeled[(d\[DirectedEdge]q)/.OURule,g],Nothing],
{d,OUs},{g,gens}
]
]
]


(* ::Input::Initialization:: *)
ExtractVPB[vd_VD]:=Module[{n,ds,d},
n=Count[vd,_EOS];
If[Length[ds=Divisors[vd]]==0, VPB[n],
d=First@Sort[ds];
q=\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[VD[VPB[n,d/.{\[Sigma]->\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\),\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\)->\[Sigma]}]]**vd];
Insert[ExtractVPB[q],d,2]
]];
CF[vpb_VPB]:=ExtractVPB[\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[vpb]];


(* ::Input::Initialization:: *)
ExtractionGraph[\[ScriptCapitalO]_,opts___]:=Module[{vd,n,gs,vs,es,p,m1,m2,g,q,k},
gs=VPBGenerators[n=Count[vd=\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[\[ScriptCapitalO]],_EOS]];
vs={vd}; es={}; p=0;
While[p<Length[vs],
m1=Count[vd=vs[[++p]],Subscript[X, _][_,_]];
Do[
m2=Count[q=\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[VD[VPB[n,g/.{\[Sigma]->\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\),\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\)->\[Sigma]}]]**vd],Subscript[X, _][_,_]];
If[m2<m1,
If[!MemberQ[vs,q],AppendTo[vs,q]];
k=Position[vs,q][[1,1]];
AppendTo[es,Labeled[p\[DirectedEdge]k,g]]
],
{g,gs}
]
];
Graph[Table[Labeled[k,Subscript[k, Length[vs[[k]]]-n]],{k,p}],es,opts]
]


(* ::Input::Initialization:: *)
VPB[BR[n_,is_List]] := VPB[n,Module[{\[Pi],i},
\[Pi]=Range[n];
Sequence@@Table[
If[i>0,
\[Pi][[{i,i+1}]]=\[Pi][[{i+1,i}]]; Subscript[\[Sigma], \[Pi][[i+1]],\[Pi][[i]]],
\[Pi][[{-i,-i+1}]]=\[Pi][[{-i+1,-i}]]; Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), \[Pi][[-i]],\[Pi][[-i+1]]]
],
{i,is}
] ]];
VD[br_BR]:=VD[VPB@br]


(* ::Input::Initialization:: *)
RandomBraid[n_,m_]:=BR[n,Table[RandomChoice[Range[n-1]\[Union](-Range[n-1])],{m}]]
