Tropical morphisms to trees

Introduction

The goal of this notebook is to make the constructions from our papers Catalan-many tropical morphisms to trees; Part I and Part 2 explicit.

We recommend, at first use, evaluating the Algorithms section (unopened), and then opening the later sections for examples.

Here is what happens in the Algorithms section:

-We start by introducing a data structure for pre-glueing datums: they consist of a finite tree T, a number d, and an unordered partition of [d] for each edge and vertex of T, such that if e is the edge between i and j, then the partitions at i and j are coarsenings of that e. Given such a pre-glueing datum, we construct a graph G by glueing d copies of T along these partitions. T is a glueing datum if G is connected and the natural map G->T satisfies the Riemann-Hurwitz inqualities everywhere. We also construct the combinatorial type H by iteratively deleting vertices from G that have valency 1, and replacing valency-2 vertices. We also compute the edge-length matrix and the signed multiplicity. Along the way, we introduce some functions for computations with partitions. 

-Then, to compute a full-rank glueing datum for even genera, we perform the Cools-Draisma construction of starting with a full-rank glueing datum in genus two and iteratively glue in tripods. This is done in a random fashion. As a consequence, there is no control over the trivalent graph thus obtained. Also, the part of the Cools-Draisma construction that analyses cactus graphs has not been implemented---the rationale being that, due to our results, only a single full-rank glueing datum is necessary, and from there one can walk to all other full-rank glueing datums.

-Next, we implement some functions for visualising glueing datums and the corresponding combinatorial type H.  

-Next, we implement edge contractions.

-Next, and most importantly, given a glueing datum and an edge to be contracted, we compute all full-rank glueing datum in the star around the contracted datum. We list these without multiplicities, so that balancing holds.

-Finally, we implement functions for visualising the contractions and moving to a next glueing datum as a movie.

We then proceed with some Examples on how to use our functions.

We do not yet go as far as to construct tropical morphisms from any metric graph to a tree of the right degree. This would involve either implementing the Cools-Draisma construction in full generality (including the cactus case), or else implementing the Caporaso walk in the space of genus-g graphs.

Our algorithms are prototypes, aimed primarily at visualisation, and not optimised for efficiency in any manner. Their might also be bugs, especially in the parts that dispose duplicates among the cones around a codimension-one limit. These are done very inefficiently at present.

  Jan Draisma and Alejandro Vargas, March 2020.

Algorithms 
(evaluate this part of the notebook before going to the examples)

Computations with partitions

The following tests whether unordered partition p1 is a refinement of p2.

IsRefinement[p1_,p2_]:=Apply[And,Map[Apply[Or,#]&,Outer[Complement[#1,#2]=={}&,p1,p2,1]]]

It’ll be convenient to have a normal form for partitions.

PartitionSort[p_]:=Sort[Map[Sort,p]]

The following computes the coarsest common refinement of two partitions.

CoarsestCommonRefinement[p1_,p2_]:=Complement[Flatten[Outer[Intersection[#1,#2]&,p1,p2,1],1],{{}}]

The following computes the finest common coarsening of two partitions.

FinestCommonCoarsening[p1_,p2_]:=Module[{q=p1,i},
For[i=1,i≤Length[p2],i++,
pos=Map[Position[q,#][[1,1]]&,p2[[i]]]//Union;
q[[pos[[1]]]]=Apply[Join,Map[q[[#]]&,pos]];
q=Delete[q,Map[{#}&,Drop[pos,1]]]
];
PartitionSort[q]]

The following adds i in all possible ways to parts of p.

add[p_,i_]:=Table[Insert[Delete[p,j],Append[p[[j]],i],j],{j,1,Length[p]}]

The following computes all partitions of a list.

Partitions[S_]:=Module[{ps},
Map[PartitionSort,If[S=={},{{}},ps=Map[Append[#,{}]&,Partitions[Drop[S,-1]]];
Apply[Join,Table[Map[Complement[#,{{}}]&,add[ps[[j]],S[[-1]]]],{j,1,Length[ps]}]]]]//Sort]

The following computes all refinements of a given partition.

Refinements[p_]:=Map[PartitionSort,Flatten[Outer[Join,Apply[Sequence,Map[Partitions,p]],1],Length[p]-1]]//Sort

Coarser[p_,q_]:=Map[(p[[#]]//Flatten)&,q]//PartitionSort

The following computes all coarsenings of a given partition.

Coarsenings[p_]:=Map[Coarser[p,#]&,Partitions[Range[Length[p]]]]//Sort

Construction of the combinatorial type and edge length matrix from a glueing datum

Needs["GraphUtilities`"];

The following tests whether a quintuple (V,E,d,gV,gE) is a pre-glueing datum (we don’t check whether the graph is a tree, just the condition on the glueing relations.)

IsPreDatum[{V_,E_,d_,gV_,gE_}]:=Module[{e=1,b=True,i,j},
While[b&&e≤Length[E],
i=Position[V,E[[e,1]]][[1,1]];
j=Position[V,E[[e,2]]][[1,1]];
b=IsRefinement[gE[[e]],gV[[i]]]&&IsRefinement[gE[[e]],gV[[j]]];
e=e+1;
];
b]

The following constructs a graph from a glueing datum together with the morphism from G to T.

GFromM[{VT_,ET_,d_,gV_,gE_}]:=Module[{VG=Flatten[Outer[List,VT,Range[d]],1],EG,i,j,k,c,e1,e,v1,v,hV=VT,mVG,mEG},
EG=Apply[Join,Table[Table[{{ET[[i]][[1]],j},{ET[[i]][[2]],j}},{j,1,d}],{i,1,Length[ET]}]];
mVG=Table[1,{Length[VG]}];
mEG=Table[1,{Length[EG]}];
For[i=1,i≤Length[ET],i++,
For[j=1,j≤Length[gE[[i]]],j++,
c=gE[[i,j]];
e1={{ET[[i]][[1]],c[[1]]},{ET[[i]][[2]],c[[1]]}};
mEG[[Position[EG,e1][[1,1]]]]=Length[c]; 
(*c is a class in the partition above edge i; the corresponding edge in G gets multiplicity the cardinality of c.*)
For[k=2,k≤Length[c],k++,
e={{ET[[i]][[1]],c[[k]]},{ET[[i]][[2]],c[[k]]}};
(*This deletes all other edges in the same class.*)
mEG=Delete[mEG,Position[EG,e][[1,1]]];
EG=Delete[EG,Position[EG,e][[1,1]]];
]]];
For[i=1,i≤Length[VT],i++,
For[j=1,j≤Length[gV[[i]]],j++,
c=gV[[i,j]];
v1={VT[[i]],c[[1]]};
mVG[[Position[VG,v1][[1,1]]]]=Length[c];
For[k=2,k≤Length[c],k++,
v={VT[[i]],c[[k]]};
mVG=Delete[mVG,Position[VG,v][[1,1]]];
VG=Complement[VG,{v}];
EG=EG/.{v->v1}]]];
{VG,EG,mVG,mEG}]

The following turns a pair of two lists into a Mathematica graph.

GraphFromG[G_]:=Graph[G[[1]],Map[UndirectedEdge[#[[1]],#[[2]]]&,G[[2]]]]

The following determines the edges attached to a given vertex.

IncidentEdges[G_,v_]:=Select[G[[2]],Complement[{v},#]=={}&]

The following computes the valency of a vertex in a graph. The last bit adds 1 for each loop at v.

Valency[G_,v_]:=Module[{e=IncidentEdges[G,v]},Length[e]+Length[Select[e,#[[1]]==#[[2]]&]]]

Now we can check wether M is a glueing datum:

IsGlueingDatum[M_]:=Module[{G=GFromM[M],VG,mVG,b,i=1},
b=IsPreDatum[M]; If[!b,Return[False]];
b=Length[ConnectedComponents[GraphFromG[G]]]==1;If[!b,Return[False]];
VG=G[[1]];mVG=G[[3]];
While[b && i≤Length[G[[1]]],
b=((Valency[G,VG[[i]]]-2)-(Valency[{M[[1]],M[[2]]},VG[[i]][[1]]]-2)*mVG[[i]]≥0);
i++
];
b]

The next thing is to compute H from G, as well as the edge-length matrix of H. Instead of a single weight, an edge in H has nonnegative weights on all the edges of T.
The first two entries of H indicate the graph itself, the last two yield the edge length matrix and the list of edges of G corresponding to edges of H.

CombinatorialType[M_]:=Module[{ET,VG,EG,mVG,mEG,VH,EH,EHG,elmat,vals,pos,i,e,j,j1,j2},
ET=M[[2]];
{VG,EG,mVG,mEG}=GFromM[M];
VH=VG;
EH=EG;(*We start with H=G, and then we'll first iteratively delete valency-one vertices and subsequently contract valency-two vertices.*)
elmat=Table[If[(Map[#[[1]]&,EH[[i]]]//Sort)==(ET[[j]]//Sort),1/mEG[[i]],0],{i,1,Length[EH]},{j,1,Length[ET]}];
vals=Map[Valency[{VH,EH},#]&,VH];
pos=Position[vals,1];
While[pos≠{},
i=pos[[1,1]];
e=IncidentEdges[{VH,EH},VH[[i]]][[1]];
j=Position[EH,e][[1,1]];
VH=Delete[VH,i];
EH=Delete[EH,j];
elmat=Delete[elmat,j];
vals=Map[Valency[{VH,EH},#]&,VH];
pos=Position[vals,1]];
EHG=Map[{#}&,EH]; (*This list will eventually contain the edges of G corresponding to each edge of H.*)
pos=Position[vals,2];
While[pos≠{},
i=pos[[1,1]];
e=IncidentEdges[{VH,EH},VH[[i]]]; (*These are two edges now.*)
j1=Position[EH,e[[1]]][[1,1]];
j2=Position[EH,e[[2]]][[1,1]];If[j2==j1,j2=Position[EH,e[[2]]][[2,1]]]; (*The latter happens if the two edges are between the same vertices.*)
EH[[j1]]=Join[Complement[e[[1]],{VH[[i]]}],Complement[e[[2]],{VH[[i]]}]];
(*The new edge is the union of the two edges minus their common vertex. It might be a loop.*)
EHG[[j1]]=Join[EHG[[j1]],EHG[[j2]]];
VH=Delete[VH,i];
vals=Delete[vals,i];
EH=Delete[EH,j2];
EHG=Delete[EHG,j2];
elmat[[j1]]+=elmat[[j2]];
elmat=Delete[elmat,j2];
pos=Position[vals,2];
];{VH,EH,elmat,EHG}];

The following yields the signed multiplicity of a (full-rank) glueing datum.

SignedMultiplicity[M_]:=Module[{A=CombinatorialType[M][[-2]],i,pos},
For[i=1,i≤Length[A],i++,A[[i]]=Apply[LCM,Denominator[A[[i]]]]*A[[i]]];
A=Transpose[A];
For[i=1,i≤Length[A],i++,
pos=Map[#[[1]]&,Position[A[[i]],0]];
If[(Length[pos]==Length[A[[i]]]-1)&&(A[[i,Complement[Range[Length[A[[i]]]],pos][[1]]]]==2),A[[i]]=A[[i]]/2]];
Det[A]]

We define two glueing datums we’ll need later on.

DoubleLollipop={{1,2,3,4},{{1,2},{2,3},{3,4}},2,{{{1,2}},{{1,2}},{{1,2}},{{1,2}}},{{{1},{2}},{{1,2}},{{1},{2}}}};

ThetaDatum={{1,2,3,4},{{1,2},{1,3},{1,4}},2,{{{1},{2}},{{1,2}},{{1,2}},{{1,2}}},{{{1},{2}},{{1},{2}},{{1},{2}}}};

IsTrivalent[H_]:=Apply[And,Map[Valency[H,#]==3&,H[[1]]]]

The Cools-Draisma construction

We proceed from a glueing datum for the theta graph, and then repeatedly glue in tripods: take three arbitrary edges in the tree, subdivide, add extra leaves, and connect an extra copy on top. Here we have g even. We only obtain a full-rank glueing datum when we glue a tripod into non-dangling edges. Below, we do not choose these edges carefully, but rather choose them at random, discarding the result when we do not obtain a full-rank glueing datum.

AddRandomTripod[{V_,E_,d_,gV_,gE_}]:=Module[{pos,is,es,m=Length[V],MM,VV,EE,gVV,gEE,ges,b=True},
While[b,
pos=RandomSample[Range[Length[E]],3];
is=Table[RandomInteger[{1,d}],3];
VV=Join[V,Range[m+1,m+6]]; (*six new vertices; the first three inserted in edges, the last three new leaves.*)
es=E[[pos]];ges=gE[[pos]];
(*These are the glueing relations above the chosen edges.*)
gVV=Join[gV,ges]; (*Those glueing relations hold at the first three new vertices.*)
gVV=Map[Append[#,{d+1}]&,gVV]; (*A new copy of the tree.*)
gVV=Join[gVV,Table[If[j==is[[i]],{j,d+1},{j}],{i,1,3},{j,1,d}]]; (*The new leaves at level d+1 are glued to those at level is[[i]], i=1,2,3.*)
EE=Join[Complement[E,es],
{{es[[1,1]],m+1},{es[[1,2]],m+1},
{es[[2,1]],m+2},{es[[2,2]],m+2},
{es[[3,1]],m+3},{es[[3,2]],m+3},
{m+1,m+4},{m+2,m+5},{m+3,m+6}}];
(*This inserts new vertices in those edges, and attaches edges to new leaves.*)
gEE=Delete[gE,Map[{#}&,pos]];
gEE=Join[gEE,ges[[{1,1,2,2,3,3}]],Table[Array[{#}&,d],{3}]];
(*The subdivided edges must have the glueing relations of the original edges, and the new leaf edges the trivial relations.*)
gEE=Map[Append[#,{d+1}]&,gEE];
MM={VV,EE,d+1,gVV,gEE};
b=(Det[CombinatorialType[MM][[-2]]]==0)];
MM];

We now construct three glueing datums that we’ll use later on in the random walks.

M0=ThetaDatum;H0=CombinatorialType[M0];

M1=AddRandomTripod[M0];H1=CombinatorialType[M1];

M2=AddRandomTripod[M1];H2=CombinatorialType[M2];

M3=AddRandomTripod[M2];H3=CombinatorialType[M3];

Visualising glueing datums

We implement three-dimensional visualisations of glueing datums. Apart from the datum, these require a labelling of the vertices and edges of the combinatorial type. These labellings are crucial in the neighbourhoods to be implemented next.

VisualiseGlueingDatum[{VT_,ET_,d_,gV_,gE_},VHLabelling_,EHLabelling_]:=
Module[
{xycoords=GraphEmbedding[GraphFromG[{VT,ET}]],
VG,EG,mVG,mEG,ballsVG,cylindersEG,cyl,p,q,ELabels,VLabels,posV,VH,EH,elmat,EHG,i,j,es,mw},
{VG,EG,mVG,mEG}=GFromM[{VT,ET,d,gV,gE}];
{VH,EH,elmat,EHG}=CombinatorialType[{VT,ET,d,gV,gE}];
posV=Map[Position[VT,#[[1]]][[1,1]]&,VG];
(*This finds the indices in VT above which the vertices of G are, and similary for the edges.*)
ballsVG=Table[j=Position[VH,VG[[i]]];If[j!={},{Opacity[1],Hue[VHLabelling[[j[[1,1]]]]/Length[VH]],Sphere[Append[xycoords[[posV[[i]]]],VG[[i,2]]*.2],.04*1.5]},
j=Position[EHG,VG[[i]]];
es=IncidentEdges[{VG,EG},VG[[i]]];
es=Map[Position[EG,#][[1,1]]&,es];
mw=Max[mEG[[es]]];
If[j≠{},{Opacity[1],Hue[EHLabelling[[j[[1,1]]]]/Length[EH]],Sphere[Append[xycoords[[posV[[i]]]],VG[[i,2]]*.2],.02*(2-1/mw)]},
{Opacity[0.15],Hue[0.2],Sphere[Append[xycoords[[posV[[i]]]],VG[[i,2]]*.2],.02*(2-1/mw)]}]],
{i,1,Length[VG]}
];
cylindersEG=
Table[j=Position[EHG,EG[[i]]];
{If[j=={},{Opacity[0.15],Hue[0.2],EdgeForm[Opacity[0]]},{Opacity[1],Hue[EHLabelling[[j[[1,1]]]]/Length[EH]],EdgeForm[Opacity[0]]}],Cylinder[
{Append[xycoords[[posV[[Position[VG,EG[[i,1]]][[1,1]]]]]],EG[[i,1,2]]*.2],
Append[xycoords[[posV[[Position[VG,EG[[i,2]]][[1,1]]]]]],EG[[i,2,2]]*.2]},2*.01*(2-1/mEG[[i]])]},{i,1,Length[EG]}];
i=1;While[i≤Length[cylindersEG],
cyl=cylindersEG[[i,2]];
j=Position[cylindersEG[[Range[i-1]]],cyl];
If[j≠{},j=j[[1,1]];
p=cyl[[1,1]];q=cyl[[1,2]];
cylindersEG[[i,2]]=Tube[BSplineCurve[{p,(p+q)/2 + {p[[2]]-q[[2]],q[[1]]-p[[1]],0}*.1,q}],2*.01*(2-1/mEG[[i]])];
cylindersEG[[j,2]]=Tube[BSplineCurve[{p,(p+q)/2 - {p[[2]]-q[[2]],q[[1]]-p[[1]],0}*.1,q}],2*.01*(2-1/mEG[[i]])]];
i++];
cylindersEG=Map[Flatten,cylindersEG];
ELabels=Table[Text[ToString[i],Append[Apply[Plus,Map[xycoords[[Position[VT,#][[1,1]]]]&,ET[[i]]]]/2,0]],{i,1,Length[ET]}];
VLabels=Table[{White,Text[ToString[VT[[i]]],Append[xycoords[[i]],0]]},{i,1,Length[VT]}];
{ballsVG,cylindersEG,ELabels,VLabels}
]

VGD[M_,VHLabelling_,EHLabelling_]:=Graphics3D[VisualiseGlueingDatum[M,VHLabelling,EHLabelling],Boxed->False,Background->Darker[Gray]]

We also want to visualise the combinatorial type itself, without the map to a tree.

VisualiseH[{VH_,EH_,elmat_,EHG_},VHLabelling_,EHLabelling_]:=
Module[{xycoords,zcoords,ballsVH,edgesEH,j1,j2,H,p,q,v,p1,p2,w},
H=GraphFromG[{VH,EH}];
xycoords=Map[#+{3.5,3.5}&,GraphEmbedding[H]];
zcoords=Table[.5*RandomReal[],{Length[VH]}];
ballsVH=Table[{Opacity[1],Hue[VHLabelling[[i]]/Length[VH]],Sphere[Append[xycoords[[i]],zcoords[[i]]],1.5*.04]},{i,1,Length[VH]}];
edgesEH=Table[j1=Position[VH,EH[[i,1]]][[1,1]];j2=Position[VH,EH[[i,2]]][[1,1]];
p=Append[xycoords[[j1]],zcoords[[j1]]];q=Append[xycoords[[j2]],zcoords[[j2]]];
If[p≠q,
v=RandomReal[{-1,1},3];
v=v-(v.(p-q))/((p-q).(p-q));
v=.1*v/Sqrt[v.v];
p1=2p/3+v+q/3;
p2=p/3+v+2q/3,
v=RandomReal[{-1,1},3];v=.5*v/Sqrt[v.v];
w=RandomReal[{-1,1},3];w=.5*w/Sqrt[w.w];
p1=p+v;p2=p+w];
{Opacity[1],Hue[EHLabelling[[i]]/Length[EH]],Tube[BSplineCurve[{p,p1,p2,q}],0.01*2]},{i,1,Length[EH]}];
{ballsVH,edgesEH}]

VCT[H_,VHLabelling_,EHLabelling_]:=Graphics3D[VisualiseH[H,VHLabelling,EHLabelling],Boxed->False,Background->Darker[Gray]]

Contracting edges

We implement edge contraction on glueing datums. Below, j is the *index* of the edge being contracted.

Contract[{V_,E_,d_,gV_,gE_},j_]:=
Module[{i1,i2,VV,EE,posloop,gEE,gVV},
{i1,i2}=E[[j]];
VV=Delete[V,Position[V,i2][[1,1]]];
EE=E/.{i2->i1}; (*Perhaps this works only when the vertex labels are "atomic", but that's a safe assumption.*)
(*posloop=Position[EE,{i1,i1}][[1,1]];*)
EE=Delete[EE,j];
gEE=Delete[gE,j];
gVV=gV;
gVV[[Position[V,i1][[1,1]]]]=FinestCommonCoarsening[gVV[[Position[V,i1][[1,1]]]],gVV[[Position[V,i2][[1,1]]]]];
gVV=Delete[gVV,Position[V,i2][[1,1]]];
{VV,EE,d,gVV,gEE}
]

The following computes the genus of a connected graph.

genus[G_]:=Length[G[[2]]]-Length[G[[1]]]+1;

The following checks whether the combinatorial type of a certain contraction has the same genus as the original.

ContractionAllowed[M_,j_]:=(genus[GFromM[M]]==genus[GFromM[Contract[M,j]]]);

A neighbourhood of a limit

Now we will proceed as follows: given a full-dimensional glueing datum and an edge to be contracted, compute the contraction, compute all possible trees contracting to that same tree by looking at all partitions of the edges around the special vertex into 2 subsets, for each of those compute all pairs of partitions whose finest common coarsening is the glueing partition at the special vertex, and choose an arbitrary partition on the edges that refines both of those partitions. Then check if it is a glueing datum of the right genus, and if it is full rank. Finally, due to the programming, some glueing datums appear more often than others; remove these duplicates.

The following computes all branch swaps at a vertex i.  It’s probably a little overkill. The output is a list of pairs {glueing datum , permutation tuple leading to this glueing datum}.

Swaps[{V_,E_,d_,gV_,gE_},i_]:=Module[{Bs,EE,perms,permtuples,j,k,l,gens,datums},
EE=Delete[E,Map[{#[[1]]}&,Position[E,V[[i]]]]];
Bs=ConnectedComponents[GraphFromG[{Delete[V,i],EE}]];
(*These are the connected components of the forest obtained by deleting the i-th vertex.*)
(*If[Length[Bs]==1,{{{V,E,d,gV,gE},{Cycles[{}]}}}, *)
gens=Table[Cycles[{{gV[[i,j,k]],gV[[i,j,k+1]]}}],{j,1,Length[gV[[i]]]},{k,1,Length[gV[[i,j]]]-1}]//Flatten;
perms=GroupElements[PermutationGroup[gens]];
(*This is the list of all group elements of the product of symmetric groups corresponding to the glueing classes above vertex i.*)
permtuples=Flatten[Outer[List,Apply[Sequence,Table[perms,{Length[Bs]}]]],Length[Bs]-1];
(*permtuples=Map[Prepend[#,Cycles[{}]]&,permtuples];*)
(*Here we have chosen one permutation for each branch around i.*)
datums={};
For[j=1,j≤Length[permtuples],j++,
AppendTo[datums,{V,E,d}];
AppendTo[datums[[-1]],Table[k=Position[Bs,V[[l]]];If[k≠{},Map[Sort,PermutationReplace[gV[[l]],permtuples[[j,k[[1,1]]]]]]//Sort,gV[[l]]],{l,1,Length[V]}]];
AppendTo[datums[[-1]],Table[k=Position[Bs,E[[l,1]]];
If[k=={},k=Position[Bs,E[[l,2]]]];Map[Sort,PermutationReplace[gE[[l]],permtuples[[j,k[[1,1]]]]]]//Sort,{l,1,Length[E]}]];
datums[[-1]]={datums[[-1]],permtuples[[j]]};
];
datums
(*]*)
]

The following function checks whether two glueing datums, along with labellings of vertices and edges of H, produced in the function Neighbourhood, should be considered the same, and hence the second should be discarded in the output of Neighbourhood.

Same[M_,VHLabelling_,EHLabelling_,MM_,VHHLabelling_,EHHLabelling_,j_]:=
(*Pick permutation tuples at the endpoints of the j-th edge, and apply these to the glueing datum M. The result is a new glueing datum MMM. If this datum, along with the colouring given by VHLabelling and EHLabelling, equals MM with VHHLabelling and EHHLabelling, then we return "True", otherwise "False".*)
Module[{V,E,gVV,VH,EH,EHG,VHH,EHH,EHHG,i1,i2,v1,v2,EE1,Bs1,EE2,Bs2,swaps1,same,s1,perms1,perms2,MMM,MMM1,MMM2,swaps2,s2,i,k,l,e,v,w,oldswaps,newswaps,Vperms,pos,oldperms},

(*Print["Start same"];*)
{V,E}={M[[1]],M[[2]]};
gVV=MM[[4]];

{VH,EH,EHG}=CombinatorialType[M][[{1,2,4}]];
{VHH,EHH,EHHG}=CombinatorialType[MM][[{1,2,4}]];

v1=E[[j]][[1]];
v2=E[[j]][[2]];
i1=Position[V,v1][[1,1]];
i2=Position[V,v2][[1,1]];

EE1=Delete[E,Map[{#[[1]]}&,Position[E,v1]]];
Bs1=ConnectedComponents[GraphFromG[{Delete[V,i1],EE1}]];

EE2=Delete[E,Map[{#[[1]]}&,Position[E,v2]]];
Bs2=ConnectedComponents[GraphFromG[{Delete[V,i2],EE2}]];

oldswaps={}; oldperms={};
newswaps={{M,Table[Cycles[{}],{Length[V]}]}};
(*We will record a list of pairs of a glueing datum and a permutation for each vertex, obtained by alternatingly swapping at i1 and at i2. Once this list is complete, or once we have found a swap coinciding with MMM, we stop.*)

same=False;

While[(newswaps≠{}) && (!same) ,
{MMM,Vperms}=newswaps[[1]];
newswaps=Drop[newswaps,1];

swaps1=Swaps[MMM,i1];
s1=1;
While[(!same)&&(s1≤Length[swaps1]),

MMM1=swaps1[[s1,1]];
perms1=Table[PermutationProduct[Vperms[[l]],
If[l==i1,Cycles[{}],
swaps1[[s1,2]][[Position[Bs1,V[[l]]][[1,1]]]]]],{l,1,Length[V]}];

swaps2=Swaps[MMM1,i2];
s2=1;
While[(!same)&&(s2≤Length[swaps2]),
MMM2=swaps2[[s2,1]];
perms2=Table[PermutationProduct[perms1[[l]],
If[l==i2,Cycles[{}],
swaps2[[s2,2]][[Position[Bs2,V[[l]]][[1,1]]]]]],{l,1,Length[V]}];

If[!MemberQ[oldswaps,{MMM2,perms2}],

(*Print[{M,perms}];
Print["\n"];
Pause[1];*)

(*
pos=Position[oldswaps,perms2];
If[pos≠{},

Print[M];
Print[oldswaps[[pos[[1,1]]]]];
Print[{MMM2,perms2}];
Print["\n"];

Return[]];*)

AppendTo[oldswaps,{MMM2,perms2}];
AppendTo[newswaps,{MMM2,perms2}];
(*oldperms=Union[oldperms,{perms2}];
Print[perms2];*)

If[{MMM2[[1]],MMM2[[2]],MMM2[[3]],Map[Sort,MMM2[[4]]],Map[Sort,MMM2[[5]]]}==
{MM[[1]],MM[[2]],MM[[3]],Map[Sort,MM[[4]]],Map[Sort,MM[[5]]]},

same=True;

k=1;
While[same && (k≤Length[VH]),
v=VH[[k]];i=Position[V,v[[1]]][[1,1]];
v[[2]]=PermutationReplace[v[[2]],perms2[[i]]];
v[[2]]=Min[gVV[[i,Position[gVV[[i]],v[[2]]][[1,1]]]]];
pos=Position[VHH,v][[1,1]];
same=(VHLabelling[[k]]==VHHLabelling[[pos]]);
k++
];

k=1;
While[same&& (k≤Length[VH]),
{v,w}=EHG[[k,1]]; (*We just pick a single edge of G through which the k-th edge of H passes.*)
i=Position[V,v[[1]]][[1,1]];
v[[2]]=PermutationReplace[v[[2]],perms2[[i]]];
v[[2]]=Min[gVV[[i,Position[gVV[[i]],v[[2]]][[1,1]]]]];
i=Position[V,w[[1]]][[1,1]];
w[[2]]=PermutationReplace[w[[2]],perms2[[i]]];
w[[2]]=Min[gVV[[i,Position[gVV[[i]],w[[2]]][[1,1]]]]];
pos=Position[EHHG,{v,w}][[1,1]];

same=(EHLabelling[[k]]==EHHLabelling[[pos]]);
k++
]
]
];
s2++
];
s1++
]
];
same
]

The following computes the neighbours of a full-dimensional glueing datum after contracting the j-th edge.

Neighbourhood[{V_,E_,d_,gV_,gE_},VHLabelling_,EHLabelling_,j_]:=
Module[{Bs,
g,V0,E0,d0,gV0,gE0,v1,v2,nb,partnbs,i,p,oldes,newesv1,newesv2,EE,EE0,gEE,gVV,i01,i1,i2,p1,p2,l,sw,datums,s,refs1,refs2,refs,triples,k,M,pos,
VG,EG,VH,EH,EHG,VHH,EHH,EHHG,EHHLabelling,VHHLabelling,VGG,EGG,mVGG,mEGG,contractededgeHH,contractededgeH,ee,b,e,r,w,w1,pos1,pos2,q,q1,posw,posw1,q2,c,c1,cw,pi,piq,piq2,qq,qq1,edge,edgesaroundverticesH,labelsaroundverticesH,edgesaroundverticesHH,labelsaroundverticesHH,vv,posv,edges,labels,TTedgepos,ww1,posww1,innf,same,ii},
{V0,E0,d0,gV0,gE0}=Contract[{V,E,d,gV,gE},j];
{VH,EH,EHG}=CombinatorialType[{V,E,d,gV,gE}][[{1,2,4}]];
{VG,EG}=GFromM[{V,E,d,gV,gE}][[{1,2}]];edgesaroundverticesH=Map[Union[IncidentEdges[{VH,EH},#]]&,VH];
labelsaroundverticesH=Map[Sort[Map[Function[p,EHLabelling[[p]]],Union[Flatten[Map[Function[e,Position[EH,e]],#]]]]]&,edgesaroundverticesH];
(*Print[labelsaroundverticesH];*)
g=genus[GFromM[{V,E,d,gV,gE}]];
v1=E[[j,1]];
v2=E[[j,2]]; (*This is the vertex that was deleted in the contraction.*)
i01=Position[V0,v1][[1,1]];

EE0=Delete[E0,Map[{#[[1]]}&,Position[E0,v1]]];
Bs=ConnectedComponents[GraphFromG[{Delete[V0,i01],EE0}]];

sw=Swaps[{V0,E0,d0,gV0,gE0},i01];
(*sw={{{V0,E0,d0,gV0,gE0},Table[Cycles[{}],{Length[Bs]}]}};*)
(* Print[sw] *);
datums={};
(*Print[Length[sw]];*)
For[s=1,s≤Length[sw],s++,
{V0,E0,d0,gV0,gE0}=sw[[s,1]];
nb=Map[Complement[#,{v1}][[1]]&,IncidentEdges[{V0,E0},v1]];
(*Print[nb];*)
(*These are the neighbours of v0 in T0.*)
partnbs=Select[Partitions[nb],Length[#]≤2&];
partnbs=Map[If[Length[#]==1,Append[#,{}],#]&,partnbs];
(*This yields all partitions of the edges in T0 incident to v1 into two parts, the second of which may be empty.*)
(*Perhaps, for visualisation, it will be more convenient to insert the new vertex at the same position as the originally deleted vertex.*)
For[i=1,i≤Length[partnbs],i++,
(*In this manner, we run over all trees contracting to the given limit.*)
p=partnbs[[i]];
oldes=Map[Sort[{v1,#}]&,p[[2]]]; (*These are the old edges.*)
newesv2=Map[Sort[{v2,#}]&,p[[2]]]; (*These are the new edges.*)
EE=Table[l=Position[oldes,Sort[E0[[k]]]];If[l≠{},newesv2[[l[[1,1]]]],Sort[E0[[k]]]],{k,1,Length[E0]}];
EE=Insert[EE,Sort[{v1,v2}],j];(*This yields a tree.*)
gEE=Insert[gE0,Null,j];(*We will change this glueing relation later at position j.*)
gVV=Insert[gV0,Null,Position[V,v2][[1,1]]];(*We will change this glueing relation later, but only at the positions of v1 and v2.*)
i1=Position[V,v1][[1,1]];
i2=Position[V,v2][[1,1]];
newesv1=Map[Sort[{v1,#}]&,p[[1]]];
(*Print[GraphFromG[{V,EE}]];*)
(*Now we need to find all possible glueing relations above the new edge and above the vertices v1,v2. The latter two are restricted by the fact that their finest common coarsening is the one in gV0 above v1,and also that they are coarsenings of the edge glueings leading to v1 and v2. We do this by running over all possible pairs of refinements, check that the finest common coarsening is the correct one.*)
p1=Fold[FinestCommonCoarsening[#1,#2]&,Map[{#}&,Range[d0]],Map[gEE[[Position[EE,#][[1,1]]]]&,newesv1]];
(*This computes the FinestCommonCoarsening of the edges leading to v1.*)
p2=Fold[FinestCommonCoarsening[#1,#2]&,Map[{#}&,Range[d0]],Map[gEE[[Position[EE,#][[1,1]]]]&,newesv2]];
(*Same thing for v2.*)
(*Print[p1,p2,p];*)
refs1=Coarsenings[p1];
refs2=Coarsenings[p2];
refs=Flatten[Outer[List,refs1,refs2,1],1];
refs=Select[refs,FinestCommonCoarsening[#[[1]],#[[2]]]==PartitionSort[gV0[[i01]]]&]; 
(*This keeps only those pairs of refinements whose finest common coarsening is the partition seen above v1 in the limit datum.*)
triples={};
For[k=1,k≤Length[refs],k++,
triples=Join[triples,Map[Append[refs[[k]],#]&,Refinements[CoarsestCommonRefinement[refs[[k,1]],refs[[k,2]]]]]]];
(*Print[p];
Print[triples];*)
For[k=1,k≤Length[triples],k++,
gVV[[i1]]=triples[[k,1]];
gVV[[i2]]=triples[[k,2]];

(*Now that we have determined the glueings above v1 and v2, we will check whether the permutations used there are in normal form in that they are strictly increasing on each glueing class above v1 resp v2. Othwerwise, we discard the current tuple. This could have been done more efficiently, but not in the current set-up. *)
innf=True;

(*Print[gVV[[i1]]];*)

innf=innf&&Apply[And,Table[
PermutationReplace[gVV[[i1,kk,ll]],
sw[[s,2,Position[Bs,p[[1,qq]]][[1,1]]]]]<
PermutationReplace[gVV[[i1,kk,ll+1]],
sw[[s,2,Position[Bs,p[[1,qq]]][[1,1]]]]],
{qq,1,Length[p[[1]]]},
{kk,1,Length[gVV[[i1]]]},
{ll,1,Length[gVV[[i1,kk]]]-1}]//Flatten];



innf=innf&&Apply[And,Table[
PermutationReplace[gVV[[i2,kk,ll]],
sw[[s,2,Position[Bs,p[[2,qq]]][[1,1]]]]]<
PermutationReplace[gVV[[i2,kk,ll+1]],
sw[[s,2,Position[Bs,p[[2,qq]]][[1,1]]]]],
{qq,1,Length[p[[2]]]},
{kk,1,Length[gVV[[i2]]]},
{ll,1,Length[gVV[[i2,kk]]]-1}]//Flatten];



gEE[[j]]=triples[[k,3]];
M={V,EE,d,gVV,gEE};
If[innf&&IsGlueingDatum[M],
{VHH,EHH,EHHG}=CombinatorialType[M][[{1,2,4}]];
{VGG,EGG,mVGG,mEGG}=GFromM[M];
If[genus[{VHH,EHH}]==g&&(Length[EHH]==3g-3)&&(SignedMultiplicity[M]≠0),

(*Now we need to compute the new VH-labelling and EH-labelling. Perhaps it is easiest to first compute the EH-labelling, and use this to compute the VH-labelling.

We proceed as follows: 

* If {w,q} is a vertex of G with w in the rth connected component obtained from T0 by deleting v1, then we have applied the rth permutation pi from the permutation tuple to it to get {w,pi(q)}. This may not be literally a vertex of GG, because in the construction of GG we always take the representative of the class of pi(q) in the glueing above w with the smallest number. So we have to take the first entry of that glueing class to get the corresponding vertex of GG. This sets up a bijection between vertices of G not above v1 or v2 to vertices of GG not above v1 or v2.

* If an edge of G is between such a vertex {w,q} and a vertex {w1,q1} (where w1 may be above v1 or v2), then there must be a q2 in the intersection of the class of q above p and the class of q1 above p1. One possible candidate for this edge is the edge in the class of q2 above the edge p-p1 in T. To this edge the same pi is applied, so you get the edge in the class of pi(q2) above the edge w-something in TT, and you can compute its other endpoint in GG.
Now I think that by full rank, all q2 in said intersection are in the same class above p-p1 (otherwise you have a loop).
So if an edge of H passes through {w,q} and {w1,q1}, then we can compute its image in HH (the new H).

* Finally, H may have exactly one edge not of the type above, which is above v1-v2. Then so does HH, and so we know how to label.

* Once we have labelled the edges, we need to label the vertices. Pick a vertex of H, and look at the labels of its incident edges. In HH, there is a unique vertex which sees exactly the same edge labels, so we know how to label that vertex. This only fails when H has an edge that gets contracted, and then only for the endpoints of that edge. Then HH has such an edge, and it doesn't matter how to map the two endpoints to the two endpoints. 
*)

(*
Print[M];
Print[sw[[s,2]]];
Print[{V0,E0,i01,v1,v2}];
*)

EHHLabelling=Table[0,{Length[EH]}];
VHHLabelling=Table[0,{Length[VH]}];



contractededgeHH={};
contractededgeH={};
For[ee=1,ee≤Length[EHH],ee++,
(*We want to label ee.*)
(*Print[ee]; *)
If[Union[Map[Sort[{#[[1,1]],#[[2,1]]}]&,EHHG[[ee]]]]=={Sort[{v1,v2}]},
contractededgeHH=EHH[[ee]]//Sort; (*This means e is an edge of H above v1,v2 and gets contracted.*)
b=True;e=1;While[b,If[Union[Map[Sort[{#[[1,1]],#[[2,1]]}]&,EHG[[e]]]]=={Sort[{v1,v2}]},
contractededgeH=EH[[e]]//Sort;
EHHLabelling[[ee]]=EHLabelling[[e]];b=False];e++],
(*Now we know that e contains at least some vertex in one of the components of Bs. We find such a vertex, and an edge attached to it.*)
b=True;r=1;While[b,w=Complement[{EHHG[[ee,r,1,1]],EHHG[[ee,r,2,1]]},{v1,v2}];If[w=={},r++,b=False]];
w=w[[1]];If[EHHG[[ee,r,1,1]]==w,{pos,pos1}={1,2},{pos,pos1}={2,1}];
q=EHHG[[ee,r,pos,2]];
w1=EHHG[[ee,r,pos1,1]];
q1=EHHG[[ee,r,pos1,2]];
(*So the ee-th edge of H passes consecutively through {w,q} and {w1,q1}.*)
posw=Position[V,w][[1,1]];
posw1=Position[V,w1][[1,1]];
c=gVV[[  posw,Position[gVV[[posw]],q][[1,1]]  ]];
c1=gVV[[ posw1,Position[gVV[[posw1]],q1][[1,1]] ]];
(*These are the glueing classes of q and q1 above w and w1, respectively.*)
q2=Intersection[c,c1][[1]]; (*This is guaranteed to be nonempty, and indeed by full rank probably a single class.*)
cw=Position[Bs,w][[1,1]]; (*This says to which component of T0 minus i0 the vertex w belongs.*)
pi=InversePermutation[sw[[s,2,cw]]]; (*This is the permutation applied to the glueing relations above w and above the edges above w-w1 to get from HH to H.*)
piq=PermutationReplace[q,pi];
piq2=PermutationReplace[q2,pi];
qq=gV[[posw,Position[gV[[posw]],piq][[1,1]] ]] [[1]];

TTedgepos=Join[Position[EE,{w,w1}],Position[EE,{w1,w}]][[1,1]];
ww1=Complement[E[[TTedgepos]],{w}][[1]];
posww1=Position[V,ww1][[1,1]];
qq1=gV[[posww1,Position[gV[[posww1]],piq2][[1,1]] ]] [[1]]; (*The q2 on the right is not a typo. There should now be a unique edge in H that passes through the edge {w,qq}-{w1,qq1} of GG. We look for it as follows.*)

edge=Intersection[EG,{{{w,qq},{ww1,qq1}},{{ww1,qq1},{w,qq}}}][[1]]; (*This determines the right order in which these vertices appear as an edge in EGG.*)
b=True;e=1;While[b,If[Position[EHG[[e]],edge]≠{},EHHLabelling[[ee]]=EHLabelling[[e]];b=False,e++]];
]];
(*Now we want to label the vertices.*)

edgesaroundverticesHH=Map[Union[IncidentEdges[{VHH,EHH},#]]&,VHH];
labelsaroundverticesHH=Map[Sort[Map[Function[p,EHHLabelling[[p]]],Union[Flatten[Map[Function[e,Position[EHH,e]],#]]]]]&,edgesaroundverticesHH];

(*Print[labelsaroundverticesHH];*)
(*
Print[Map[Position[VH,#]&,contractededgeH]];
Print[Map[Position[VHH,#]&,contractededgeHH]];*)

For[vv=1,vv≤Length[VHH],vv++,
posv=Position[contractededgeHH,VHH[[vv]]];
If[posv≠{},posv=posv[[1,1]];VHHLabelling[[vv]]=VHLabelling[[Position[VH,contractededgeH[[posv]]][[1,1]]]],
(*Now we know that the vertex is not one of the endpoints of the potential edge being contracted.*)

VHHLabelling[[vv]]=VHLabelling[[Position[labelsaroundverticesH,labelsaroundverticesHH[[vv]]][[1,1]]]]
];
]; 
(*Now we check that a locally equivalent datum does not already occur in the list.*)
same=False;

ii=1;
While[!same &&(ii≤Length[datums]),
same=Same[datums[[ii,1]],datums[[ii,2]],datums[[ii,3]],M,VHHLabelling,EHHLabelling,j];
ii++;
];
If[!same,
AppendTo[datums,{M,VHHLabelling,EHHLabelling,sw[[s,2]]}];
(*If[partnbs[[i,-1]]=={},AppendTo[datums,{M,VHHLabelling,EHHLabelling,sw[[s,2]]}]]*) (*If a leaf was attached, you have to count twice.*)
]
]]
]
];
];
datums]

The following function determines the sign of a permutation. It will  be used to determine the sign of the permutation needed to reorder the edges of H, so as to compute the right signed multiplicity.

sgn[l1_,l2_]:=Module[{i,j},Apply[Times,Flatten[Table[Sign[Position[l2,l1[[j]]][[1,1]]-Position[l2,l1[[i]]][[1,1]]],{i,1,Length[l1]},{j,i+1,Length[l1]}]]]]

Gradual change from a datum to a neighbouring datum

To contract an edge and move to a neighbouring datum, we do the following: first, in the original datum M1, we make the edge darker, shorten it by shortening the corresponding edge in T (both vertices move to the middle). Then we look at the datum M2. We apply the swaps needed to go from M1 to M2 (these should be added to the output of Neighbourhood). By the same computation, we compute a path from M2 to its limit, which we later reverse. And finally we need a path from the (swapped) limit of M1 to the limit of M2. These are the same limits, sure enough, but may be laid out differently, and we have to follow where the vertices go. We start with the easy part.

ContractingMovie[{VT_,ET_,d_,gV_,gE_},VHLabelling_,EHLabelling_,j_,N_,bH_,cH_]:=
(*N is the number of steps in the movie; N+1 frames.*)
Module[{v1,v2,ballsVG,cylindersEG,VG,EG,comps,i1,i2,tv,i,t,vgd,f,dvs,H,ballsH,cylindersH,VH,EH,w1,w2,j1,j2,av,EHG,es,pos},
v1=ET[[j,1]];v2=ET[[j,2]];
vgd=VisualiseGlueingDatum[{VT,ET,d,gV,gE},VHLabelling,EHLabelling][[{1,2}]];
{ballsVG,cylindersEG}=vgd;
(*We don't use the vertex and edge labels now.*)
{VG,EG}=GFromM[{VT,ET,d,gV,gE}][[{1,2}]];
comps=ConnectedComponents[GraphFromG[{VT,Delete[ET,j]}]]; (*These should be two components.*)
If[MemberQ[comps[[1]],v2],comps=Reverse[comps]]; (*This makes sure the first vertex of edge j is in the first component.*)
i1=Position[VG,{v1,_}][[1,1]];
i2=Position[VG,{v2,_}][[1,1]];
tv=ballsVG[[i1,3,1]]-ballsVG[[i2,3,1]]; 
tv[[3]]=0; (*This is the horizontal vector over which points will have to be translated.*)
f=FinestCommonCoarsening[gV[[Position[VT,v1][[1,1]]]],gV[[Position[VT,v2][[1,1]]]]];

dvs={}; (*This is the list of displacement vectors of the balls.*)

For [i=1,i≤Length[VG],i++,
If[Position[comps,VG[[i,1]]][[1,1]]==1&&VG[[i,1]]≠v1,AppendTo[dvs,-tv]];
If[Position[comps,VG[[i,1]]][[1,1]]==2&&VG[[i,1]]≠v2,AppendTo[dvs,tv]];
If[VG[[i,1]]==v1,AppendTo[dvs,(-tv-2(VG[[i,2]]-Min[f[[Position[f,VG[[i,2]]][[1,1]]]]])*0.2*{0,0,1})]];
If[VG[[i,1]]==v2,AppendTo[dvs,(tv-2(VG[[i,2]]-Min[f[[Position[f,VG[[i,2]]][[1,1]]]]])*0.2*{0,0,1})]];
ballsVG[[i,3,1]]=ballsVG[[i,3,1]]+t*dvs[[i]];
];

For[i=1,i≤Length[EG],i++,

If[({EG[[i,1,1]],EG[[i,2,1]]}//Sort)==({v1,v2}//Sort),
cylindersEG[[i,2]]=Lighter[Lighter[Lighter[cylindersEG[[i,2]]]]]];

If[Position[cylindersEG[[i]],BSplineCurve]=={},
cylindersEG[[i,4,1]]=cylindersEG[[i,4,1]]+t*{dvs[[Position[VG,EG[[i,1]]][[1,1]]]],
dvs[[Position[VG,EG[[i,2]]][[1,1]]]]},
cylindersEG[[i,4,1,1]]=cylindersEG[[i,4,1,1]]+t*{dvs[[Position[VG,EG[[i,1]]][[1,1]]]],
(dvs[[Position[VG,EG[[i,1]]][[1,1]]]]+dvs[[Position[VG,EG[[i,2]]][[1,1]]]])/2,dvs[[Position[VG,EG[[i,2]]][[1,1]]]]}]
];

H=CombinatorialType[{VT,ET,d,gV,gE}];
{ballsH,cylindersH}={bH,cH};
{VH,EH,EHG}=H[[{1,2,4}]];

es=Map[Union[Apply[Join,#]]&,EHG];
es=Table[Map[#[[1]]&,es[[i]]],{i,1,Length[es]}];
es=Map[Union,es];
pos=Position[es,Union[{v1,v2}]];

If[pos≠{},pos=pos[[1,1]];
{w1,w2}=EH[[pos]];
{j1,j2}=Map[Position[VH,#][[1,1]]&,{w1,w2}];
{ballsH[[j1,3,1]],ballsH[[j2,3,1]]}={ballsH[[j1,3,1]]+t(ballsH[[j2,3,1]]-ballsH[[j1,3,1]]),ballsH[[j2,3,1]]+t(ballsH[[j1,3,1]]-ballsH[[j2,3,1]])};
av=ballsH[[j1,3,1]]/.{t->1/2};
cylindersH[[pos,3,1,1]]=(1-2t)cylindersH[[pos,3,1,1]]+(2t)*{av,av,av,av};
cylindersH[[pos,2]]=Lighter[Lighter[Lighter[cylindersH[[pos,2]]]]];
For[i=1,i≤Length[EH],i++,
If[i≠pos,
If[EH[[i,1]]==w1,cylindersH[[i,3,1,1,1]]=ballsH[[j1,3,1]]];
If[EH[[i,1]]==w2,cylindersH[[i,3,1,1,1]]=ballsH[[j2,3,1]]];
If[EH[[i,2]]==w1,cylindersH[[i,3,1,1,4]]=ballsH[[j1,3,1]]];
If[EH[[i,2]]==w2,cylindersH[[i,3,1,1,4]]=ballsH[[j2,3,1]]];
]
]
];

Join[Table[Graphics3D[{vgd,bH,cH},Boxed->False,Background->Darker[Gray],ViewPoint->{100,-100,100}],{Floor[N/2]}],
Table[Graphics3D[{ballsVG,cylindersEG,ballsH,cylindersH}/.t->0,Boxed->False,Background->Darker[Gray],ViewPoint->{100,-100,100}],{Floor[N/4]}],
Table[Graphics3D[{ballsVG,cylindersEG,ballsH,cylindersH}/.t->i/(2N),Boxed->False,Background->Darker[Gray],ViewPoint->{100,-100,100}],{i,0,N}]]
]

ContractAndSwapMovie[{VT_,ET_,d_,gV_,gE_},VHLabelling_,EHLabelling_,j_,N_,M_,perms_,bH_,cH_]:=
Module[{movie1,ballsVG,cylindersEG,VG,EG,V0,E0,d0,gV0,gE0,v1,v2,i01,EE0,Bs,vd,i,i1,i2,movie2,t,f,ballsH,cylindersH},
movie1=ContractingMovie[{VT,ET,d,gV,gE},VHLabelling,EHLabelling,j,N,bH,cH];
ballsVG=movie1[[-1]][[1,1]];
cylindersEG=movie1[[-1]][[1,2]];
ballsH=movie1[[-1]][[1,3]];
cylindersH=movie1[[-1]][[1,4]];

{VG,EG}=(GFromM[{VT,ET,d,gV,gE}])[[{1,2}]];
{V0,E0}=(Contract[{VT,ET,d,gV,gE},j])[[{1,2}]];

v1=ET[[j,1]];
v2=ET[[j,2]]; (*This is the vertex that was deleted in the contraction.*)
i01=Position[V0,v1][[1,1]];

EE0=Delete[E0,Map[{#[[1]]}&,Position[E0,v1]]];
Bs=ConnectedComponents[GraphFromG[{Delete[V0,i01],EE0}]];

vd={}; (*This will be the vertical displacement for each vertex of G.*)

For[i=1,i≤Length[VG],i++,
pos=Position[Bs,VG[[i,1]]];
If[pos≠{},
pos=pos[[1,1]];
f=PermutationReplace[gV[[Position[VT,VG[[i,1]]][[1,1]]]],perms[[pos]]];
AppendTo[vd,t{0,0,(Min[f[[Position[f,PermutationReplace[VG[[i,2]],perms[[pos]]]][[1,1]]]]]-VG[[i,2]])*0.2}],
AppendTo[vd,{0,0,0}]];
ballsVG[[i,3,1]]=ballsVG[[i,3,1]]+vd[[i]]
];


For[i=1,i≤Length[EG],i++,
i1=Position[VG,EG[[i,1]]][[1,1]];i2=Position[VG,EG[[i,2]]][[1,1]];
If[Position[cylindersEG[[i]],BSplineCurve]≠{},
cylindersEG[[i,4,1,1]]=cylindersEG[[i,4,1,1]]+{vd[[i1]],vd[[i1]],vd[[i2]]},
cylindersEG[[i,4,1]]=cylindersEG[[i,4,1]]+{vd[[i1]],vd[[i2]]}];
]; 

movie2=
Table[Graphics3D[{ballsVG,cylindersEG,ballsH,cylindersH}/.t->i/M,Boxed->False,Background->Darker[Gray],ViewPoint->{100,-100,100}],{i,0,M}];

Join[movie1,movie2]
]

Align[{VT_,ET_,d_,gV_,gE_},j_,perms_,{VTT_,ETT_,dd_,gVV_,gEE_}]:=
Module[{f,VG,EG,VGG,EGG,V0,E0,v1,v2,i01,map,EE0,Bs,i,i1,i2,fcc,pos},
(*This computes a map that sends the vertices of G for the first glueing datum, with j-th edge length zero, to the vertices of G for the second glueing datum.*)
{VG,EG}=(GFromM[{VT,ET,d,gV,gE}])[[{1,2}]];
{VGG,EGG}=(GFromM[{VTT,ETT,dd,gVV,gEE}])[[{1,2}]];
{V0,E0}=(Contract[{VT,ET,d,gV,gE},j])[[{1,2}]];

v1=ET[[j,1]];
v2=ET[[j,2]]; (*This is the vertex that was deleted in the contraction.*)
i01=Position[V0,v1][[1,1]];
i1=Position[VT,v1][[1,1]];
i2=Position[VT,v2][[1,1]];
fcc=FinestCommonCoarsening[gV[[i1]],gV[[i2]]];

map={}; (*This will be the map sending a vertex in VG to a vertex in VGG.*)

EE0=Delete[E0,Map[{#[[1]]}&,Position[E0,v1]]];
Bs=ConnectedComponents[GraphFromG[{Delete[V0,i01],EE0}]];
For[i=1,i≤Length[VG],i++,
If[VG[[i,1]]≠v1&&VG[[i,1]]≠v2,
pos=Position[Bs,VG[[i,1]]][[1,1]];
f=gVV[[Position[VTT,VG[[i,1]]][[1,1]]]];
AppendTo[map,Position[VGG,{VG[[i,1]],Min[f[[Position[f,PermutationReplace[VG[[i,2]],perms[[pos]]]][[1,1]]]]]}][[1,1]]],
AppendTo[map,Position[VGG,{VG[[i,1]],Min[fcc[[Position[fcc,VG[[i,2]]][[1,1]]]]]}][[1,1]]]
(*AppendTo[map,Position[VGG,VG[[i]]][[1,1]]]*)
]
];
map
]

MovieFromOneToNext[{VT_,ET_,d_,gV_,gE_},VHLabelling_,EHLabelling_,j_,N_,M_,perms_,{VTT_,ETT_,dd_,gVV_,gEE_},VHHLabelling_,EHHLabelling_,bH_,cH_,bHH_,cHH_]:=
Module[{movie1,movie2,movie3,ballsVG,cylindersEG,ballsVGG,cylindersEGG,a,dvs,i,t,i1,i2,ii1,ii2,VG,EG,ballsH,cylindersH,ballsHH,cylindersHH,pos,VH,EH,VHH,EHH},
movie1=ContractAndSwapMovie[{VT,ET,d,gV,gE},VHLabelling,EHLabelling,j,N,M,perms,bH,cH];
movie2=ContractingMovie[{VTT,ETT,dd,gVV,gEE},VHHLabelling,EHHLabelling,j,N,bHH,cHH]//Reverse;

{VG,EG}=GFromM[{VT,ET,d,gV,gE}][[{1,2}]];

{VH,EH}=CombinatorialType[{VT,ET,d,gV,gE}][[{1,2}]];

{VHH,EHH}=CombinatorialType[{VTT,ETT,dd,gVV,gEE}][[{1,2}]];

{ballsVG,cylindersEG,ballsH,cylindersH}=movie1[[-1,1]];

{ballsVGG,cylindersEGG,ballsHH,cylindersHH}=movie2[[1,1]];

a=Align[{VT,ET,d,gV,gE},j,perms,{VTT,ETT,dd,gVV,gEE}];
dvs={};

For[i=1,i≤Length[ballsVG],i++,
AppendTo[dvs,-t*ballsVG[[i,3,1]]+t*ballsVGG[[a[[i]],3,1]]];
ballsVG[[i,3,1]]=ballsVG[[i,3,1]]+dvs[[i]];
];

For[i=1,i≤Length[cylindersEG],i++,
{i1,i2}=Map[Position[VG,EG[[i,#]]][[1,1]]&,{1,2}];
If[Position[cylindersEG[[i]],BSplineCurve]≠{},
cylindersEG[[i,4,1,1]]=cylindersEG[[i,4,1,1]]+{dvs[[i1]],(dvs[[i1]]+dvs[[i2]])/2,dvs[[i2]]},
cylindersEG[[i,4,1]]=cylindersEG[[i,4,1]]+{dvs[[i1]],dvs[[i2]]}
]
];

For[i=1,i≤Length[ballsH],i++,
ballsH[[i,3,1]]=(1-t)ballsH[[i,3,1]]+t ballsHH[[Position[VHHLabelling,VHLabelling[[i]]][[1,1]],3,1]]
];

For[i=1,i≤Length[cylindersH],i++,
pos=Position[EHHLabelling,EHLabelling[[i]]][[1,1]];
{i1,i2}=Map[VHLabelling[[Position[VH,EH[[i,#]]][[1,1]]]]&,{1,2}];
{ii1,ii2}=Map[VHHLabelling[[Position[VHH,EHH[[pos,#]]][[1,1]]]]&,{1,2}];
If[i1==ii1||i2==ii2,
cylindersH[[i,3,1,1]]=(1-t)cylindersH[[i,3,1,1]]+t cylindersHH[[pos,3,1,1]],
cylindersH[[i,3,1,1]]=(1-t)cylindersH[[i,3,1,1]]+t Reverse[cylindersHH[[pos,3,1,1]]]
]
];

movie3=
Table[Graphics3D[{ballsVG,cylindersEG,ballsH,cylindersH}/.t->i/M,Boxed->False,Background->Darker[Gray],ViewPoint->{100,-100,100}],{i,0,M}];

Join[movie1,movie3,movie2]

]

A movie command

The following command takes as input a glueing datum and a list of pairs {j,k} indicating which edge to shrink (j) and which entry of the neigbourhood to follow. The output is a movie.

Movie[M1_,steps_]:=
Module[{M=M1,MM,H,VHLabelling,EHLabelling,bH,cH,bHH,cHH,Mov,i,NB},
H=CombinatorialType[M];
VHLabelling=Range[Length[H[[1]]]];
EHLabelling=Range[Length[H[[2]]]];
{bH,cH}=VCT[CombinatorialType[M],VHLabelling,EHLabelling][[1]];
Mov={};
For[i=1,i≤Length[steps],i++,
NB=Neighbourhood[M,VHLabelling,EHLabelling,steps[[i,1]]];
MM=NB[[steps[[i,2]]]];
{bHH,cHH}=VCT[CombinatorialType[MM[[1]]],MM[[2]],MM[[3]]][[1]];
Mov=Join[Mov,MovieFromOneToNext[M,VHLabelling,EHLabelling,steps[[i,1]],15,15,MM[[-1]],MM[[1]],MM[[2]],MM[[3]],bH,cH,bHH,cHH]];
{bH,cH}={bHH,cHH};
{M,VHLabelling,EHLabelling}=MM[[{1,2,3}]]];
Mov];

Examples

Examples with partitions

The following is self-explanatory.

FinestCommonCoarsening[{{1,2},{3},{4,5}},{{1},{2,4},{3},{5}}]

CoarsestCommonRefinement[{{1,2},{3},{4,5}},{{1,2,4},{3},{5}}]

Refinements[{{1,2},{3},{4,5}}]

Coarsenings[{{1,2},{3},{4,5}}]

IsRefinement[{{1,2},{3},{4,5}},{{3},{1,2,4,5}}]

Examples of the combinatorial type and edge length matrix from a glueing datum

Example 1.

M={{1,2,3},
{{1,2},{2,3}},
3,
{{{1,2,3}},{{1,2},{3}},{{1,2,3}}},
{{{1},{2},{3}},{{1,2},{3}}}
};

IsGlueingDatum[M]

G=GFromM[M]

GraphFromG[G]

Valency[G,G[[1,1]]]

GraphFromG[{M[[1]],M[[2]]}]

H=CombinatorialType[M]

GraphFromG[{H[[1]],H[[2]]}]

The following yields the edge length matrix.

H[[3]]//MatrixForm

The following yields the edges of G comprising the various edges of H.

H[[4]]

Example 2: the double lollipop

DoubleLollipop

CombinatorialType[DoubleLollipop][[-2]]//MatrixForm

GraphFromG[CombinatorialType[DoubleLollipop]]

Example 3: the theta datum

ThetaDatum

GraphFromG[GFromM[ThetaDatum]]

GraphFromG[CombinatorialType[ThetaDatum]]

Outcome of the Cools-Draisma construction

The following graphs, along with full-rank glueing datums, have been constructed from the theta datum (M0) by repeatedly glueing in a tripod. The datums are called M0,M1,M2,M3, and the combinatorial types H0,H1,H2,H3.

M0 and H0

GraphFromG[GFromM[M0]]

GraphFromG[H0]

M1 and H1

GraphFromG[GFromM[M1]]

GraphFromG[H1]

M2 and H2

GraphFromG[GFromM[M2]]

GraphFromG[H2]

M3 and H3

GraphFromG[GFromM[M3]]

GraphFromG[H3]

Examples of visualisation

Double Lollipop

{VGD[DoubleLollipop,Range[2],Range[3]],VCT[CombinatorialType[DoubleLollipop],Range[2],Range[3]]}

M0 and H0

{VGD[M0,Range[2],Range[3]],VCT[H0,Range[2],Range[3]]}

M1 and H1

{VGD[M1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]],VCT[H1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]]}

M2 and H2

{VGD[M2,Range[Length[H2[[1]]]],Range[Length[H2[[2]]]]],VCT[H2,Range[Length[H2[[1]]]],Range[Length[H2[[2]]]]]}

M3 and H3

{VGD[M3,Range[Length[H3[[1]]]],Range[Length[H3[[2]]]]],VCT[H3,Range[Length[H3[[1]]]],Range[Length[H3[[2]]]]]}

Examples of contraction

A contraction of M1

M11=Contract[M1,7]

IsGlueingDatum[M11]

H11=CombinatorialType[M11];

{VGD[M1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]],VGD[M11,Range[Length[H11[[1]]]],Range[Length[H11[[2]]]]]}

Note that edge 7 of the tree has been contracted. This does not affect the combinatorial type:

{VCT[H1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]],VCT[H11,Range[Length[H11[[1]]]],Range[Length[H11[[2]]]]]}

All edges in M1 can be contracted

{VGD[M1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]],VCT[H1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]]}

genus[GFromM[M1]]

Map[ContractionAllowed[M1,#]&,Range[Length[M1[[2]]]]]

Not all edges in the doublelollipop can be contracted

{VGD[DoubleLollipop,{1,2},{1,2,3}],VCT[CombinatorialType[DoubleLollipop],{1,2},{1,2,3}]}

genus[GFromM[DoubleLollipop]]

Map[ContractionAllowed[DoubleLollipop,#]&,Range[3]]

Examples of neighbourhood

A first neigbourhood of M1

{VGD[M1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]],VCT[H1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]]}

NB=Neighbourhood[M1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]],7];

Map[VGD[#[[1]],#[[2]],#[[3]]]&,NB]

Map[SignedMultiplicity[#[[1]]]*sgn[Range[Length[H1[[2]]]],#[[3]]]&,NB]

The balancing condition says that these numbers should add up to zero. Note that the combinatorial type of H doesn’t change upon contracting 7.

A second neighbourhood of M1

{VGD[M1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]],VCT[H1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]]]}

NB=Neighbourhood[M1,Range[Length[H1[[1]]]],Range[Length[H1[[2]]]],1];

Map[VGD[#[[1]],#[[2]],#[[3]]]&,NB]

Map[SignedMultiplicity[#[[1]]]*sgn[Range[Length[H1[[2]]]],#[[3]]]&,NB]

The balancing condition here says that all signed determinants are equal. Note that the combinatorial type *does* change.

A neighbourhood of the ThetaDatum

VGD[ThetaDatum,{1,2},{1,2,3}]

NB=Neighbourhood[ThetaDatum,{1,2},{1,2,3},1];

Map[VGD[#[[1]],#[[2]],#[[3]]]&,NB]

Map[SignedMultiplicity[#[[1]]]*sgn[{1,2,3},#[[3]]]&,NB]

Again, balancing says that the two determinants are equal.

Examples of movies

From double lollipop to theta and back

Mov=Movie[DoubleLollipop,{{2,1},{2,2},{2,1},{2,2}}];

(*ListAnimate[Mov]*)

The movie from our paper, followed by a random walk

Mtriangleineq={{1,2,3,4,5,6,7,8,9,10},
{{1,2},{1,3},{1,4},{2,6},{2,7},{3,8},{3,9},{4,5},{4,10}},
3,
{
{{1},{2},{3}},
{{1},{2},{3}},
{{1},{2},{3}},
{{1},{2},{3}},
{{1,2},{3}},
{{1,3},{2}},
{{1,3},{2}},
{{2,3},{1}},
{{2,3},{1}},
{{1,2},{3}}},
{{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}}}};

Htriangleineq=CombinatorialType[Mtriangleineq];

VGD[Mtriangleineq,Range[Length[Htriangleineq[[1]]]],Range[Length[Htriangleineq[[2]]]]]

Here, orange is <=yellow + green

NB=Neighbourhood[Mtriangleineq,Range[Length[Htriangleineq[[1]]]],Range[Length[Htriangleineq[[2]]]],2];

Map[VGD[#[[1]],#[[2]],#[[3]]]&,NB]

M=NB[[2]];

Here, yellow+green<=orange<=yellow+green+purple

NB=Neighbourhood[M[[1]],M[[2]],M[[3]],7];

Map[VGD[#[[1]],#[[2]],#[[3]]]&,NB]

M=NB[[2]];

Here, yellow+green+purple<=orange<=yellow+2*green+purple

NB=Neighbourhood[M[[1]],M[[2]],M[[3]],3];

Map[VGD[#[[1]],#[[2]],#[[3]]]&,NB]

M=NB[[2]];

Here, yellow+2*green+purple<=orange<=yellow+purple+2*green+red

NB=Neighbourhood[M[[1]],M[[2]],M[[3]],9];

Map[VGD[#[[1]],#[[2]],#[[3]]]&,NB]

M=NB[[2]];

Mov=Movie[Mtriangleineq,{{2,2},{7,2},{3,2},{9,2}}];

(*Export["~/tropmorphmovies/originalmovie.avi",Mov,ImageResolution->200,"FrameRate"->10]*)

VHLabelling=M[[2]];EHLabelling=M[[3]];M=M[[1]];
{bH,cH}={Mov[[-1,1,2]],Mov[[-1,1,3]]};
j=0;

For[i=1,i≤5,i++,
b=False;
While[!b,j=Mod[j+RandomInteger[{1,2}],Length[EHLabelling],1];b=ContractionAllowed[M,j]];
NB2=Neighbourhood[M,VHLabelling,EHLabelling,j];
dets=Map[Sign[sgn[EHLabelling,#[[3]]]*SignedMultiplicity[#[[1]]]]&,NB2];
k=Position[dets,-Sign[SignedMultiplicity[M]]]; (*This makes sure we move to a different glueing datum, if there is one of a different sign (i.e., in the case where the combinatorial type doesn't change.*)
If[k≠{},k=k[[1,1]],
b=False;
While[!b,k=RandomInteger[{1,Length[NB2]}];b=({M,VHLabelling,EHLabelling}≠NB2[[k]][[{1,2,3}]])]
];
{bHH,cHH}=VCT[CombinatorialType[NB2[[k,1]]],NB2[[k,2]],NB2[[k,3]]][[1]];
Mov=Join[Mov,MovieFromOneToNext[M,VHLabelling,EHLabelling,j,15,15,NB2[[k,-1]],NB2[[k,1]],NB2[[k,2]],NB2[[k,3]],bH,cH,bHH,cHH]];
{bH,cH}={bHH,cHH};
{M,VHLabelling,EHLabelling}=NB2[[k]][[{1,2,3}]]]

(*ListAnimate[Mov]*)

(*Export["~/tropmorphmovies/finalmoviegenus4b.avi",Mov,ImageResolution->200,"FrameRate"->10]*)

Three random walks

A random walk starting at M1

M=M1;VHLabelling=Range[Length[H1[[1]]]];EHLabelling=Range[Length[H1[[2]]]];

VGD[M,VHLabelling,EHLabelling]

The following does a walk of 100 steps, and checks balancing.

For[i=1,i≤100,i++,
b=False;
While[!b,j=RandomInteger[{1,Length[M[[2]]]}];b=ContractionAllowed[M,j]];
NB2=Neighbourhood[M,VHLabelling,EHLabelling,j];
dets=Map[sgn[EHLabelling,#[[3]]]*SignedMultiplicity[#[[1]]]&,NB2];
Print["signed multiplicities in the neighbourhood: ",dets];
If[!IsTrivalent[CombinatorialType[Contract[M,j]]],Print["Combinatorial Type changes"];If[Length[Union[dets]]≠1,Return[]],If[Apply[Plus,dets]≠0,Return[]]];
j=RandomInteger[{1,Length[NB2]}];
{M,VHLabelling,EHLabelling}=NB2[[j]][[{1,2,3}]]]

VGD[M,VHLabelling,EHLabelling]

A loop of three loops as seed

We now start at a glueing datum of multiplicity 2 from the paper.

Mtriangleineq={{1,2,3,4,5,6,7,8,9,10},
{{1,2},{1,3},{1,4},{2,6},{2,7},{3,8},{3,9},{4,5},{4,10}},
3,
{
{{1},{2},{3}},
{{1},{2},{3}},
{{1},{2},{3}},
{{1},{2},{3}},
{{1,2},{3}},
{{1,3},{2}},
{{1,3},{2}},
{{2,3},{1}},
{{2,3},{1}},
{{1,2},{3}}},
{{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}},{{1},{2},{3}}}};

{VH,EH,EHG}=CombinatorialType[Mtriangleineq][[{1,2,4}]];

EHLabelling=Range[Length[EH]];VHLabelling=Range[Length[VH]];

VGD[Mtriangleineq,VHLabelling,EHLabelling]

M=Mtriangleineq;

For[i=1,i≤100,i++,
b=False;
While[!b,j=RandomInteger[{1,Length[M[[2]]]}];b=ContractionAllowed[M,j]];
NB2=Neighbourhood[M,VHLabelling,EHLabelling,j];
dets=Map[sgn[EHLabelling,#[[3]]]*SignedMultiplicity[#[[1]]]&,NB2];
Print["signed multiplicities in the neighbourhood: ",dets];
If[!IsTrivalent[CombinatorialType[Contract[M,j]]],Print["Combinatorial Type changes"];If[Length[Union[dets]]≠1,Return[]],If[Apply[Plus,dets]≠0,Return[]]];
j=RandomInteger[{1,Length[NB2]}];
{M,VHLabelling,EHLabelling}=NB2[[j]][[{1,2,3}]]]

VGD[M,Range[Length[VH]],Range[Length[EH]]]

Another seed, now of multiplicity 2 and genus 6.

MSpaceShip={{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16},{{1,2},{1,3},{1,4},{2,5},{2,6},{6,7},{6,8},{3,9},{3,10},{10,11},{10,12},{4,13},{4,14},{14,15},{14,16}},4,{{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}}, {{1},{2},{3},{4}},
{{1},{2,3},{4}},{{1},{2},{3},{4}},{{1,2},{4},{3}},{{2},{1,3},{4}},{{1},{3},{2,4}},{{2},{4},{1},{3}},{{2},{3},{1,4}},{{1,2},{3},{4}},{{2},{1},{4,3}}, {{1},{2},{3},{4}},{{1,3},{2},{4}},{{1,4},{2},{3}}},{{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{2},{3},{1},{4}},{{2},{3},{1},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}},{{1},{2},{3},{4}}}};
VHLabelling={1,5,7,10,3,6,2,4,9,8};
EHLabelling={13,8,7,9,2,5,6,12,1,11,14,10,4,15,3};

VGD[MSpaceShip,VHLabelling,EHLabelling]

HSpaceShip=CombinatorialType[MSpaceShip];

VCT[HSpaceShip,VHLabelling,EHLabelling]

M=MSpaceShip;

For[i=1,i≤100,i++,
b=False;
While[!b,j=RandomInteger[{1,Length[M[[2]]]}];b=ContractionAllowed[M,j]];
NB2=Neighbourhood[M,VHLabelling,EHLabelling,j];
dets=Map[sgn[EHLabelling,#[[3]]]*SignedMultiplicity[#[[1]]]&,NB2];
Print["signed multiplicities in the neighbourhood: ",dets];
If[!IsTrivalent[CombinatorialType[Contract[M,j]]],Print["Combinatorial Type changes"];If[Length[Union[dets]]≠1,Return[]],If[Apply[Plus,dets]≠0,Return[]]];
j=RandomInteger[{1,Length[NB2]}];
{M,VHLabelling,EHLabelling}=NB2[[j]][[{1,2,3}]]]