(* ::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"];
<<"../Profile/Profile.m"


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


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


(* ::Input::Initialization:: *)
\[Gamma][vd_VD] := Subscript[PP, \[Gamma]]@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=First[js];
{{s1,i1,j1}}=Cases[vd,Subscript[X, s_][i_,j1]:>{s,i,j1}];
{{s2,i2,j2}}=Cases[vd,Subscript[X, s_][j1+1,j_]:>{s,j1+1,j}];
Tidy@Union[
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-.3s1,j2+.3s2],Subscript[X, -s1 s2][i1+.3s1,j2-.3s2]]
]
]]


(* ::Input::Initialization:: *)
\[CapitalGamma][vd_VD]:=Subscript[PP, \[CapitalGamma]]@FixedPoint[\[Gamma],vd,2^8]


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


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


(* ::Input::Initialization:: *)
VD /: vd1_VD **vd2_VD := \!\(\*SubscriptBox[\(PP\), \("\<**\>"\)]\)@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:: *)
R2ReduceB[vd_VD]:=Subscript[PP, R2ReduceB]@Module[{R2s,R2},
R2s=Cases[vd,Subscript[X, s_][i_,j_]:>Subscript[X, -s][i+1,j+1]]\[Intersection](List@@vd);
If[Length[R2s]==0,vd,
R2=First@R2s;
Tidy@Complement[vd,VD[R2,R2/.Subscript[X, s_][i_,j_]:>Subscript[X, -s][i-1,j-1]]]
]]


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


(* ::Input::Initialization:: *)
R2Reduce[vd_VD]:=Subscript[PP, R2Reduce]@FixedPoint[R2ReduceB @* R2ReduceC,vd]


(* ::Input::Initialization:: *)
R1Reduce1[vd_VD]:=Subscript[PP, R1Reduce1]@Tidy@DeleteCases[vd,Subscript[X, _][i_,j_]/;Abs[i-j]==1]


(* ::Input::Initialization:: *)
R12Reduce[vd_VD]:=Subscript[PP, R12Reduce]@FixedPoint[R2ReduceB @* R2ReduceC @* R1Reduce1,vd]


(* ::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:: *)
(*CountOUForms[n_,m_]:=Module[{k},
Length@Union@Flatten@Table[R12Reduce@\[CapitalGamma]@VPB[n,Sequence@@p], {k,0,m},{p,Tuples[VPBGenerators[n],k]}]]*)


(* ::Input::Initialization:: *)
ProudFollowers[n_,Subscript[\[Sigma], i_,j_]] :=ProudFollowers[n,Subscript[\[Sigma], i,j]]= Subscript[PP, ProudFollowers]@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:: *)
ProudVPBs[n_,0]:={VPB[n]};
ProudVPBs[n_,1]:=VPB[n,#]&/@VPBGenerators[n];
ProudVPBs[n_,m_]/;m>1:=Subscript[PP, ProudVPBs][
Flatten[ProudVPBs[n,m-1]/.VPB[n,\[Sigma]s___,\[Sigma]_]:>(VPB[n,\[Sigma]s,\[Sigma],#]&/@ProudFollowers[n,\[Sigma]])]]


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



