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



BeginPackage["FusionAtlas`TriplePointTest`",{"FusionAtlas`","FusionAtlas`Bigraphs`","FusionAtlas`GraphPairs`","FusionAtlas`RelativeDimensions`"}];


TriplePointObstruction::usage="";


EvenTriplePointObstruction::usage="";


OddTriplePointObstruction::usage="";


Begin["`Private`"];


TriplePoints[g_GradedBigraph]:=With[{m=GraphAdjacencyMatrix[g]},Flatten[Table[{n,k},{n,0,GraphDepth[g]},{k,1,RankAtDepth[g,n]}],1][[Flatten[Position[Table[(m.m)[[i,i]],{i,1,Length[m]}],3,1]]]]]


VertexNeighbours[g_GradedBigraph,{n_,k_}]:=If[n>0,{n-1,#}&/@Flatten[Position[g[[n,k]],1,1]],{}]~Join~If[n<GraphDepth[g],{n+1,#}&/@Flatten[Position[g[[n+1,All,k]],1,1]],{}]


VertexLeftNeighbours[g1_BigraphWithDuals,g2_BigraphWithDuals,{m_,n_,k_}]:=
Module[{g},
g[1]=g1[[1]];g[2]=g2[[1]];
If[n>0,{m,n-1,#}&/@Flatten[Position[g[m][[n,k]],1,1]],{}]~Join~If[n<GraphDepth[g[m]],{m,n+1,#}&/@Flatten[Position[g[m][[n+1,All,k]],1,1]],{}]
]


DualVertex[g1_BigraphWithDuals,g2_BigraphWithDuals,{m_,n_/;OddQ[n],k_}]:={3-m,n,k}
DualVertex[g1_BigraphWithDuals,g2_BigraphWithDuals,{m_,n_/;EvenQ[n],k_}]:=Module[{d},
d[1]=g1[[2]];d[2]=g2[[2]];
{m,n,d[m][[n/2+1,k]]}
]


VertexRightNeighbours[g1_BigraphWithDuals,g2_BigraphWithDuals,{m0_,n0_,k0_}]:=
Module[{g,d,m,n,k},
g[1]=g1[[1]];g[2]=g2[[1]];
d[1]=g1[[2]];d[2]=g2[[2]];
{m,n,k}=DualVertex[g1,g2,{m0,n0,k0}];
DualVertex[g1,g2,#]&/@(If[n>0,{m,n-1,#}&/@Flatten[Position[g[m][[n,k]],1,1]],{}]~Join~If[n<GraphDepth[g[m]],{m,n+1,#}&/@Flatten[Position[g[m][[n+1,All,k]],1,1]],{}])
]


TriplePointsWithDimensions[g_GradedBigraph]:=TriplePoints[g]/.{d_Integer,k_Integer}:>{{d,k},DimensionsByDepth[g][[#[[1]]+1,#[[2]]]]&/@VertexNeighbours[g,{d,k}]}


TriplePointsWithRelativeDimensions[g1_BigraphWithDuals,g2_BigraphWithDuals]:=
Function[{d,n,q},Evaluate[{Flatten[TriplePoints[g1[[1]]]/.{depth_Integer,k_Integer}:>{{depth,k}->(RelativeDimensionsByDepth[g1,g2,1][d,n,q][[1,#[[1]]+1,#[[2]]]]&/@VertexNeighbours[g1[[1]],{depth,k}])},1],Flatten[TriplePoints[g2[[1]]]/.{depth_Integer,k_Integer}:>{{depth,k}->(RelativeDimensionsByDepth[g1,g2,1][d,n,q][[2,#[[1]]+1,#[[2]]]]&/@VertexNeighbours[g2[[1]],{depth,k}])},1]}
]
]


(* broken? *)
TriplePointsWithRelativeDimensions=TriplePointsWithClumps;


DimensionCoincidences[g1_,g2_]:=
Module[{g,vertices,mostVertices,clumps,deepestClumps,clump,neighbouringClumps,updateClumps},
{g[1],g[2]}={g1,g2};
vertices=Flatten[Table[{i,n,k},{i,1,2},{n,0,GraphDepth[g[i]]},{k,1,RankAtDepth[g[i],n]}],2];
mostVertices=Flatten[Table[{i,n,k},{i,1,2},{n,0,GraphDepth[g[i]]-1},{k,1,RankAtDepth[g[i],n]}],2];
clumps=Flatten[Table[{{1,n,k},{2,n,k}},{n,1,GraphDepth[g[1]]-1,2},{k,1,RankAtDepth[g[1],n]}],1];
clumps=clumps~Join~Union[Flatten[Table[Union[{{i,n,k},{i,n,g[i][[2]][[n/2+1]][[k]]}}],{i,1,2},{n,0,GraphDepth[g[i]]-1,2},{k,1,RankAtDepth[g[i],n]}],2]];
deepestClumps=If[EvenQ[GraphDepth[g1]]\[Or]EvenQ[GraphDepth[g2]],
With[{n=Max[GraphDepth[g1],GraphDepth[g2]]},Flatten[Table[Union[{{i,n,k},{i,n,g[i][[2]][[n/2+1]][[k]]}}],{i,1,2},{k,1,RankAtDepth[g[i],n]}],1]],
With[{n=GraphDepth[g1]},Table[{{1,n,k},{2,n,k}},{k,1,RankAtDepth[g[1],n]}]]
];
clumps=clumps~Join~deepestClumps;
clump[x_]:=Select[clumps,MemberQ[#,x]&,1][[1]];
neighbouringClumps[x_]:=Sort[clump/@FusionAtlas`TriplePointTest`Private`VertexLeftNeighbours[g1,g2,x]];
updateClumps[_]:=Union[Function[p,Union[Join@@(clump/@p)]]/@SplitBy[SortBy[mostVertices,neighbouringClumps],neighbouringClumps]];
FixedPoint[(clumps=updateClumps[#]~Join~deepestClumps;clumps)&,clumps]
]


TriplePointsWithClumps[g1_BigraphWithDuals,g2_BigraphWithDuals]:=
Function[{d0,n0,q0},Evaluate[
Module[{clumps=DimensionCoincidences[g1,g2],clump},
clump[x_]:=Select[clumps,MemberQ[#,x]&,1][[1]];
{Flatten[TriplePoints[g1[[1]]]/.{depth_Integer,k_Integer}:>{{depth,k}->(clump[{1,#[[1]],#[[2]]}]&/@VertexNeighbours[g1[[1]],{depth,k}])},1],Flatten[TriplePoints[g2[[1]]]/.{depth_Integer,k_Integer}:>{{depth,k}->(clump[{2,#[[1]],#[[2]]}]&/@VertexNeighbours[g2[[1]],{depth,k}])},1]}
]
]]


MatchingOddTriplePoints[g1_BigraphWithDuals,g2_BigraphWithDuals]:=
Module[{d,n,q},Cases[Cases[{#,Sort/@(#/.TriplePointsWithRelativeDimensions[g1,g2][d,n,q])}&/@(Intersection@@(Cases[#,{_?OddQ,_}]&/@(TriplePoints/@{g1[[1]],g2[[1]]}))),{v_,{D_,D_}}:>v],{a_,b_}/;(Sort[VertexRightNeighbours[g1,g1,{1,a,b}]]==Sort[VertexLeftNeighbours[g1,g1,{2,a,b}]])\[And](Sort[VertexRightNeighbours[g1,g1,{2,a,b}]]==Sort[VertexLeftNeighbours[g1,g1,{1,a,b}]])]
]


EvenTriplePoints[g1_BigraphWithDuals,g2_BigraphWithDuals]:=
Module[{},
Flatten[{Cases[TriplePoints[g1[[1]]],{d_?EvenQ,k_}:>{1,d,k}],Cases[TriplePoints[g2[[1]]],{d_?EvenQ,k_}:>{2,d,k}]},1]
]


Clear[TriplePointObstruction,OddTriplePointObstruction,EvenTriplePointObstruction]


OddTriplePointObstruction[g1_,g2_]:=OddTriplePointObstruction[g1,g2]=
Module[{pathLengths,extraPaths},
pathLengths=LengthTwoPathsNearTriplePoints[g1,g2,#]&/@MatchingOddTriplePoints[g1,g2];
extraPaths=Map[Length[Complement[#,{1}]]>0&,pathLengths,{2}];
And@@(Flatten[extraPaths])
]


OddTriplePointObstruction[{g1_BigraphWithDuals,g2_BigraphWithDuals}]:=OddTriplePointObstruction[g1,g2]


EvenTriplePointObstruction[g1_,g2_]:=EvenTriplePointObstruction[g1,g2]=
Module[{pathLengths,extraPaths},
pathLengths=LengthTwoPathsNearTriplePoints[g1,g2,#]&/@NeighbourlyEvenTriplePoints[g1,g2];
extraPaths=Map[Length[Complement[#,{1}]]>0&,pathLengths,{2}];
And@@(Flatten[extraPaths])
]


EvenTriplePointObstruction[{g1_BigraphWithDuals,g2_BigraphWithDuals}]:=EvenTriplePointObstruction[g1,g2]


TriplePointObstruction[g1_,g2_]:=EvenTriplePointObstruction[g1,g2]\[And]OddTriplePointObstruction[g1,g2]


TriplePointObstruction[{g1_BigraphWithDuals,g2_BigraphWithDuals}]:=TriplePointObstruction[g1,g2]


TriplePointBijections[g1_BigraphWithDuals,g2_BigraphWithDuals,{depth_,k_}/;OddQ[depth]]:=Module[{d,n,q,dimensions},
dimensions={depth,k}/.TriplePointsWithRelativeDimensions[g1,g2][d,n,q];
Thread[VertexNeighbours[g1[[1]],{depth,k}]->VertexNeighbours[g2[[1]],{depth,k}][[#]]]&/@Cases[Permutations[3],p_/;dimensions[[1]]==dimensions[[2,p]]]/.({a_,b_}->{c_,d_}):>({1,a,b}->{2,c,d})
]


TriplePointBijections[g1_BigraphWithDuals,g2_BigraphWithDuals,{m_,depth_,k_}/;EvenQ[depth]]:=Module[{g,d,n,q,dimensions},
{g[1],g[2]}={g1,g2};
dimensions={depth,k}/.TriplePointsWithRelativeDimensions[g1,g2][d,n,q][[m]];
Thread[VertexNeighbours[g[m][[1]],{depth,k}]->VertexNeighbours[g[m][[1]],{depth,k}][[#]]]&/@
Cases[Permutations[3],p_/;dimensions==dimensions[[p]]]/.({a_,b_}->{c_,d_}):>({m,a,b}->{m,c,d})
]


LengthTwoPaths[g1_,g2_,{1,a_,b_}->{2,a_,d_}]/;EvenQ[a]:=If[a<GraphDepth[g1],(Transpose[g2[[1,a+1]]].g1[[1,a+1]])[[d,b]],U]+If[a>0,(g2[[1,a]].Transpose[g1[[1,a]]])[[d,b]],0]


LengthTwoPaths[g1_,g2_,{1,a_,b_}->{2,c_,d_}]/;EvenQ[a]\[And]c==a+2:=(g2[[1,a+2]].g1[[1,a+1]])[[d,b]]
LengthTwoPaths[g1_,g2_,{1,a_,b_}->{2,c_,d_}]/;EvenQ[a]\[And]c==a-2:=(Transpose[g2[[1,a-1]]].Transpose[g1[[1,a]]])[[d,b]]


PermutationMatrix[v_]:=IdentityMatrix[Length[v]][[v]]


LengthTwoPaths[g1_,g2_,{1,a_,b_}->{2,a_,d_}]/;OddQ[a]:=If[a<GraphDepth[g1],(Transpose[g1[[1,a+1]]].PermutationMatrix[g1[[2,(a+1)/2+1]]].g1[[1,a+1]])[[d,b]],U]+If[a>0,(g1[[1,a]].PermutationMatrix[g1[[2,(a-1)/2+1]]].Transpose[g1[[1,a]]])[[d,b]],0]


LengthTwoPaths[g1_,g2_,{1,a_,b_}->{2,c_,d_}]/;OddQ[a]\[And]c==a+2:=(g1[[1,a+2]].PermutationMatrix[g1[[2,(a+1)/2+1]]].g1[[1,a+1]])[[d,b]]
LengthTwoPaths[g1_,g2_,{1,a_,b_}->{2,c_,d_}]/;OddQ[a]\[And]c==a-2:=(Transpose[g1[[1,a-1]]].PermutationMatrix[g1[[2,(a-1)/2+1]]].Transpose[g1[[1,a]]])[[d,b]]


LengthTwoPaths[g1_,g2_,{m_,a_,b_}->{m_,a_,d_}]/;OddQ[a]:=
Module[{g={g1,g2}[[m]]},
If[a<GraphDepth[g],(Transpose[g[[1,a+1]]].(IdentityMatrix[RankAtDepth[g,a+1]][[g[[2,(a+1)/2+1]]]]).g[[1,a+1]])[[d,b]],U]+If[a>0,(g[[1,a]].(IdentityMatrix[RankAtDepth[g,a-1]][[g[[2,(a-1)/2+1]]]]).Transpose[g[[1,a]]])[[d,b]],0]
]


LengthTwoPaths[g1_,g2_,{m_,a_,b_}->{m_,c_,d_}]/;OddQ[a]\[And]c==a+2:=
Module[{g={g1,g2}[[m]]},
(g[[1,a+2]].(IdentityMatrix[RankAtDepth[g,a+1]][[g[[2,(a+1)/2+1]]]]).g[[1,a+1]])[[d,b]]
]
LengthTwoPaths[g1_,g2_,{m_,a_,b_}->{m_,c_,d_}]/;OddQ[a]\[And]c==a-2:=
Module[{g={g1,g2}[[m]]},
(Transpose[g[[1,a-1]]].(IdentityMatrix[RankAtDepth[g,a-1]][[g[[2,(a-1)/2+1]]]]).Transpose[g[[1,a]]])[[d,b]]
]


LengthTwoPathsNearTriplePoints[g1_BigraphWithDuals,g2_BigraphWithDuals,v_]:=
Map[LengthTwoPaths[g1,g2,#]&,{#[[1,1]]->#[[2,2]],#[[1,1]]->#[[3,2]],#[[2,1]]->#[[1,2]],#[[2,1]]->#[[3,2]],#[[3,1]]->#[[1,2]],#[[3,1]]->#[[2,2]]}&/@TriplePointBijections[g1,g2,v],{2}]


NeighbourlyEvenTriplePoints[g1_BigraphWithDuals,g2_BigraphWithDuals]:=Module[{e=EvenTriplePoints[g1,g2]},
Cases[Flatten[Outer[List,Cases[e,{1,_,_}],Cases[e,{2,_,_}],1],1],{v1_,v2_}/;(VertexLeftNeighbours[g1,g2,v1]==VertexRightNeighbours[g1,g2,v2])\[And](VertexLeftNeighbours[g1,g2,v2]==VertexRightNeighbours[g1,g2,v1])]
]


TriplePointBijections[g1_BigraphWithDuals,g2_BigraphWithDuals,{{1_,depth_,k1_},{2,depth_,k2_}}]/;EvenQ[depth]:=Module[{g,d,n,q,dimensions1,dimensions2,permutations},
{g[1],g[2]}={g1,g2};
dimensions1={depth,k1}/.TriplePointsWithRelativeDimensions[g1,g2][d,n,q][[1]];
dimensions2={depth,k2}/.TriplePointsWithRelativeDimensions[g1,g2][d,n,q][[2]];
permutations=Cases[Permutations[3],p_/;dimensions1==dimensions2[[p]]];
Thread[VertexLeftNeighbours[g1,g2,{1,depth,k1}]->VertexLeftNeighbours[g1,g2,{2,depth,k2}][[#]]]&/@permutations
]


End[];


EndPackage[];
