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



SetDirectory["~drorbn/AcademicPensieve/Projects/wEnumeration"]


A_List\[Backslash]B_List := Complement[A,B];


DrawArrow[i_,j_] := Arrow[BezierCurve[{{Abs@i,0},{(Abs@i+Abs@j)/2, 0.5Abs[Abs@i-Abs@j]},{Abs@j,0}}]];
Draw[wLDiag[ts___Integer]|wCDiag[ts___Integer]] := Module[{n,w,w1},
n=Length[w={ts}];
w1=Abs/@w;
Graphics[{
Line[{{0,0},{n+1,0}}],
Table[If[w[[j]]==0, {},
{
DrawArrow[w1[[j]]-0.5,j],
Text[If[w[[j]]>0, "+", "-"], {j,-0.1}],
Text[w1[[j]], {w1[[j]]-0.5,-0.1}]
}
],
{j,n}
]
}]
];
Draw[wLDiag[R3[top_,mid_,bot_,s1_,s2_,s3_], ts__]|wCDiag[R3[top_,mid_,bot_,s1_,s2_,s3_], ts__]] := Graphics[Join[
First@Draw[wLDiag[ts]],
{Red,
DrawArrow[top-0.5,mid],
DrawArrow[top-0.5,bot+0.5],
DrawArrow[mid,bot+0.5],
Text["bot", {bot+0.5,-0.2}],
Text["mid", {mid,-0.2}],
Text["top", {top-0.5,-0.2}],
Text["type="<>ToString@{s1,s2,s3}, {(top+mid+bot)/3, -0.4}]
}
]];
Draw[expr_] := expr /. w_wLDiag|w_wCDiag :> Draw[w]


AllLinearDiagrams[n_] := Flatten@Table[
wLDiag@@@Tuples[Range[k+1]\[Union](-Range[k+1]), k],
{k,0,n}
]


wLDiag /: RotateLeft[w_wLDiag] := Module[{n},
n=Length[w];
wLDiag@@(RotateLeft[List@@w] /. j_Integer :> Which[
j==1, n,
j==-1, -n,
j>1, j-1,
j<-1, j+1
])
];
wCDiag /: RotateLeft[w_wCDiag] := wCDiag@@RotateLeft[wLDiag@@w]


RotateToMinimal[w_wCDiag]:= Module[
{bestw=w,rotatedw=RotateLeft[w]},
While[rotatedw=!=w,
bestw=First[Sort[{bestw,rotatedw}]];
rotatedw=RotateLeft[rotatedw]
];
bestw
];


wCDiag[w_wLDiag] := Module[{n},
n=Length[w];
RotateToMinimal[wCDiag@@w /. {n+1 -> 1, -n-1->-1}]
]


AllCircularDiagrams[n_] := AllCircularDiagrams[n] = Union[RotateToMinimal/@ Flatten@Table[
wCDiag@@@Tuples[Range[k]\[Union](-Range[k]), k],
{k,0,n}
]]


RemoveR1[w_wLDiag] := Module[{j,k=0},
Do[If[MemberQ[{j,j+1}, Abs[w[[j]]]], k=j], {j,Length[w]}];
If[k==0, w,
Delete[w,k] /. j_Integer  /; Abs[j]>k :> Sign[j](Abs[j]-1)
]
]


RemoveR1[wCDiag[]]=wCDiag[];
RemoveR1[w_wCDiag] := Module[{n,j,k=0},
n=Length[w];
Do[If[MemberQ[{j,j+1}, Abs[w[[j]]]], k=j], {j,n-1}];
If[k!=0,
Delete[w,k] /. j_Integer  /; Abs[j]>k :> Sign[j](Abs[j]-1),
(*else*) If[!MemberQ[{1,n}, Abs[Last[w]]],w,
Drop[w,-1] /. {n->1, -n->-1}]
]
]


RemoveR1s[w_wLDiag|w_wCDiag] := FixedPoint[RemoveR1, w]


RemoveR2[w_wLDiag] := Module[{j,k=0},
Do[If[w[[j]]+w[[j+1]]==0 && !MemberQ[Abs[List@@w],j+1], k=j], {j,Length[w]-1}];
If[k==0, w,
Delete[w,{{k}, {k+1}}] /. j_Integer  /; Abs[j]>k :> Sign[j](Abs[j]-2)
]
]


RemoveR2[w_wCDiag] /; Length[w]<2 := w;
RemoveR2[w_wCDiag] :=  Module[{n,j,k=0},
n=Length[w];
Do[If[w[[j]]+w[[j+1]]==0 && !MemberQ[Abs[List@@w],j+1], k=j], {j,n-1}];
If[k!=0,
Delete[w,{{k}, {k+1}}] /. j_Integer  /; Abs[j]>k :> Sign[j](Abs[j]-2) /. {n-1->1, 1-n->-1},
If[w[[1]]+w[[n]]==0 && !MemberQ[Abs[List@@w],1],
w[[2;;n-1]] /. j_Integer :> Sign[j](Abs[j]-1) /. {n-1->1, 1-n->-1},
(*else*) w
]
]
]


RemoveR12s[w_wLDiag|w_wCDiag] := FixedPoint[RemoveR2[RemoveR1[#]]&, w]


RF[w_wCDiag] := RF[w] = RotateToMinimal[RemoveR12s[w]];
RF[w_wLDiag] := RemoveR12s[w];


wLDiag /: Resolve[wLDiag[R3[top_,mid_,bot_,s1_,s2_,s3_], ts__]] := UndirectedEdge[
RF@ReplacePart[wLDiag@ts, {bot+(1-s3)/2->s2 s3 top,bot+(1+s3)/2->s1 s3(mid+1), mid->s2 top}],
RF@ReplacePart[wLDiag@ts, {bot+(1-s3)/2->s1 s3 mid,bot+(1+s3)/2->s2 s3 top, mid->s2 top}]
];
wCDiag /: Resolve[wCDiag[R3[top_,mid_,bot_,s1_,s2_,s3_], ts__]] := (RF[wCDiag[#]])& /@ Resolve[wLDiag[R3[top,mid,bot,s1,s2,s3],ts]]


AllLinearR3s[n_] /; n<3 := {};
AllLinearR3s[n_] := Flatten@Table[
Prepend[
ReplacePart[wLDiag@@Table[0,{n}],Thread[Range[n]\[Backslash]{bot,bot+1,mid}->#]],
R3[top,mid,bot,s1,s2,s3]
]& /@ Tuples[Range[-n-1,n+1]\[Backslash]{-bot-1,0,bot+1}, n-3],
{bot, Range[n-1]}, {mid, Range[n]\[Backslash]{bot, bot+1}}, {top, Range[n+1]\[Backslash]{bot+1}},
{s1,{-1,1}}, {s2,{-1,1}}, {s3,{-1,1}}
];
AllCircularR3s[n_] /; n<3 := {};
AllCircularR3s[n_] := Flatten@Table[
Prepend[
ReplacePart[wCDiag@@Table[0,{n}],Thread[Range[n]\[Backslash]{1,2,mid}->#]],
R3[top,mid,1,s1,s2,s3]
]& /@ Tuples[Range[-n,n]\[Backslash]{-2,0,2}, n-3],
{mid, Range[n]\[Backslash]{1,2}}, {top, Range[n]\[Backslash]{2}},
{s1,{-1,1}}, {s2,{-1,1}}, {s3,{-1,1}}
];


wCircularK[n_] := wCircularK[n] = Module[{VS, vs, rule, ES, es},
VS=AllCircularDiagrams[n];
$k=0; vs=Union[(++$k; RF[#])& /@ VS];
Print[Length@vs];
rule=Dispatch[Thread[vs->Range[Length@vs]]];
ES=AllCircularR3s[n];
Print[Length@ES];
$k=0; es=Union[(++$k; Resolve[#] /. rule)& /@ ES];
{vs, Graph[Range[Length@vs],es]}
];
wCircularK[n_, k_] := wCircularK[n, k] = Module[{vs,g,cc},
{vs,g}=wCircularK[n];
cc=ConnectedComponents[g];
Select[Table[
First@MinimalBy[vs[[#]]& /@ c, Length],
{c,cc}
], Length[#]==k&]
]


wLinearK[n_] := wLinearK[n] = Module[{VS, vs, rule, ES, es},
VS=AllLinearDiagrams[n];
$k=0; vs=Union[(++$k; RF[#])& /@ VS];
Print[Length@vs];
rule=Dispatch[Thread[vs->Range[Length@vs]]];
ES=AllLinearR3s[n];
Print[Length@ES];
$k=0; es=Union[(++$k; Resolve[#] /. rule)& /@ ES];
{vs, Graph[Range[Length@vs],es]}
];
wLinearK[n_, k_] := wLinearK[n, k] = Module[{vs,g,cc},
{vs,g}=wLinearK[n];
cc=ConnectedComponents[g];
Select[Table[
First@MinimalBy[vs[[#]]& /@ c, Length],
{c,cc}
], Length[#]==k&]
]


HMirror[w_wCDiag|w_wLDiag] := RF[(-#)& /@ w]


ReduceMod[{vs_,g_}] := ReduceMod[{vs,g}] = Module[{cc,md},
Dispatch[Flatten@Table[
md = First@MinimalBy[vs[[#]]& /@ cc, Length];
(vs[[#]] -> md)& /@ cc,
{cc, ConnectedComponents[g]}
]]
];
ReduceMod[w_, {vs_, g_}] := (w /. ReduceMod[{vs,g}])


VeryNonTrivialQ[diag_wCDiag, sp_] := And@@((ReduceMod[RF[#], sp]=!= wLDiag[])& /@ NestList[RotateLeft, wLDiag@@diag, Max[0,Length[diag]-1]])



