TriplePointTest package

A subpackage for FusionAtlas v0.
February, 2010, Scott Morrison

Introduction

---text goes here---

Implementation

Start of package

Specify package dependencies:

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

Usage messages

TriplePointObstruction::usage="";

EvenTriplePointObstruction::usage="";

OddTriplePointObstruction::usage="";

Internals

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]]∨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}]])∧(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]∧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]∧c==a+2:=(g2[[1,a+2]].g1[[1,a+1]])[[d,b]]
LengthTwoPaths[g1_,g2_,{1,a_,b_}->{2,c_,d_}]/;EvenQ[a]∧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]∧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]∧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]∧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]∧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])∧(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

End[];

End of package

EndPackage[];