(* ::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"]


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


(* ::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]  ]];
R12Reduce[vd_VD]:=FixedPoint[R12Reduce1,vd]


(* ::Input::Initialization:: *)
\[CapitalGamma]1[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[\[CapitalGamma]1,vd,2^24]


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


(* ::Input::Initialization:: *)
\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[vd_VD]:=FixedPoint[\[CapitalGamma]1@*R12Reduce,vd,2^24];
\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[T_] /; Head[T]=!=VD := \!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[VD[T]]


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


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


(* ::Input::Initialization:: *)
A_\[Backslash]B_:=Complement[A,B];
VPBGens[n_]:=VPBGens[n]=Flatten@Table[{Subscript[\[Sigma], i,j],Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i,j]},{i,n},{j,Range[n]\[Backslash]{i}}];


(* ::Input::Initialization:: *)
PF[n_,Subscript[\[Sigma], i_,j_]] :=PF[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,Range[n]\[Backslash]{i,j}}],
Table[{Subscript[\[Sigma], p,q],Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), p,q]},{p,Range[i+1,n]\[Backslash]{j}},{q,Range[n]\[Backslash]{i,j,p}}] }];
PF[n_,Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i_,j_]] := PF[n,Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i,j]]=PF[n,Subscript[\[Sigma], i,j]]/.Subscript[\[Sigma], i,j]->Subscript[\!\(\*OverscriptBox[\(\[Sigma]\), \(_\)]\), i,j]


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


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


(* ::Input::Initialization:: *)
VPB[BR[n_,is_List]] := VPB[n,Module[{\[Pi]=Range@n,i},Sequence@@Table[
If[i>0,
\[Pi][[{i,i+1}]]=\[Pi][[{i+1,i}]]; Subscript[\[Sigma], \[Pi][[i+1]],\[Pi][[i]]],
(* else *) \[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:: *)
PF[n_,i_Integer]:=(Range[Max[Abs[i]-1,1],n-1]\[Union](-Range[Max[Abs[i]-1,1],n-1]))\[Backslash]{-i};


(* ::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],#}]&/@PF[n,\[Sigma]])]


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


(* ::Input::Initialization:: *)
Options[EG]={Labels->False, GraphLayout->"SpringElectricalEmbedding",EdgeStyle->Automatic};


(* ::Input::Initialization:: *)
EG[\[ScriptCapitalO]_,opts___]:=Module[{vd,n,gs,vs,es={},e,p=0,m1,m2,g,q,k,lbl},
lbl=Labels/.{opts}/.Options[EG];
gs=VPBGens[n=Count[vd=\!\(\*OverscriptBox[\(\[CapitalGamma]\), \(_\)]\)[\[ScriptCapitalO]],_EOS]]; vs={vd};
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]];
e=p\[DirectedEdge]Position[vs,q][[1,1]];
AppendTo[es,If[lbl,Labeled[e,g],e] ] ],
{g,gs} ] ];
Graph[Table[If[lbl,Labeled[k,Length[vs[[k]]]-n],k],{k,p}],es,
FilterRules[Join[{opts},Options[EG]],Options[Graph]]] ]



