(* ::Package:: *)

Print["This is PQM.m, version 1.0, 
a tool for computing peculiar modules for 4-ended tangles,
written in Mathematica 10.3.1.0 for Linux x86 (64-bit). 
For more background on peculiar modules for 4-ended tangles, see

   [Zib17] C.B. Zibrowius, ",Style["Peculiar modules for 4-ended tangles", Italic],", arXiv: 1712.05050v2. 

For questions, suggestions or comments, please email claudius.zibrowius-deleteme","@","posteo.net. 

    Copyright (C) 2019 Claudius Zibrowius

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU Affero General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU Affero General Public License for more details.

    You should have received a copy of the GNU Affero General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>."
];


regionsInput::usage="regionsInput is a matrix with five columns and a row for each region of the nice Heegaard diagram. The first entry of the \!\(\*SuperscriptBox[\(i\), \(th\)]\) row should be equal to i. The other four entries of the \!\(\*SuperscriptBox[\(i\), \(th\)]\) row are the vertices of the \!\(\*SuperscriptBox[\(i\), \(th\)]\) region, ordered by their boundary orientation. Our orientation conventions are as in [Zib17]: The normal vector field, determined by the right hand rule, points into the plane, so the boundary orientation is clockwise. We start with a vertex which is the start of a segment of an \[Alpha]-curve in the boundary of the region.  For bigons, the last two entries remain empty, ie occupied by the symbol \[Placeholder]. Note: The first column is not used anywhere in the program, it only helps a human being to translate between the picture of the Heegaard diagram and the Mathematica notebook.";
alphasInput::usage="alphasInput is a table whose rows are indexed by the \[Alpha]-curves. Again, the first entry should be the index of the curve. The second is a list of all intersection points on this curve. Note: The order of the intersection points is irrelevant.";
betasInput::usage="betasInput is a table whose rows are indexed by the \[Beta]-curves. Again, the first entry should be the index of the curve. The second is a list of all intersection points on this curve. Note: The order of the intersection points is irrelevant.";
cancellationSortListInput::usage="cancellationSortListInput is a table of intersection points with two columns, so each row corresponds to a pair of intersection points. This table has an effect on the order of the generators and is important for the initial cancellation after computing the invariant. Usually, we start with a Heegaard diagram which is not necessarily nice and then niceify it using finger moves, thereby creating lots of new intersection points and generators. In the initial cancellation step, the program attempts to cancel such generators, thereby reversing the effect of niceification. The order in which this is done is determined by the order of the generators, and this, in turn, is determined by cancellationSortListInput.
So the pairs of intersection points should be those that can be removed by a reversed finger move.  The order of the intersection points for each pair is the same as for regionsInput, using the bigon which connects these two points and which is removed by the reversed finger move. This bigon accounts for the identity component in the differential which the program will attempt to cancel.";
alphaArcs::usage="alphaArcs is a table whose four rows correspond to the four sites a, b, c and d of the tangle, as indicated by the entries of the first column. The second entry in each row is a list of all intersection points for the corresponding site. Note: The first column should not be changed.";
basepointRegions::usage="basepointRegions is a table with four columns. The entries of the first column are indices of regions containing the basepoint labelled by the corresponding entries of the second column, namely either p or q. (Note 1: Do not use any other variables; in particular, do not use 'p' or 'q' with subscripts such as '\!\(\*SubscriptBox[\(p\), \(1\)]\)' or '\!\(\*SubscriptBox[\(q\), \(4\)]\)'. Note 2: In the very special case that there are multiple basepoints in this region, take a suitable power of p or q.) 
The third column corresponds to the Alexander grading; entries are lists of length equal to the number of colours in the tangle, such that the \!\(\*SuperscriptBox[\(i\), \(th\)]\) entry of the list corresponds to the \!\(\*SuperscriptBox[\(i\), \(th\)]\) colour. A basepoint of an open (closed) strand leaving/entering the 3-manifold should be recorded as +1/-1 (+2/-2) for the corresponding colour. 
The entries of the fourth column should be -2 (-4) for each basepoint of an open (closed) strand it contains. This information is used for the computation of the \[Delta]-grading.";
multiplicity0Regions::usage="multiplicity0Regions is a table with four columns. The entries of the first column are indices of regions whose multiplicity in each domain is 0. The second entry is a list of oriented elementary \[Beta]-segments (ie pairs of intersection points) along the boundary of the domain. The orientation conventions are as in 'regionsInput'. (Note: Any \[Beta]-segment which lies in the interior of the domain should be recorded once in each direction.)
The third column corresponds to the Alexander grading; entries are lists of length equal to the number of colours in the tangle, such that the \!\(\*SuperscriptBox[\(i\), \(th\)]\) entry of the list corresponds to the \!\(\*SuperscriptBox[\(i\), \(th\)]\) colour. A basepoint of an open (closed) strand leaving/entering the 3-manifold should be recorded as +1/-1 (+2/-2) for the corresponding colour. 
The entries of the fourth column should be 4*(Euler measure of region) plus -2 (-4) for each basepoint of an open (closed) strand it contains. This information is used for the computation of the \[Delta]-grading.";


Step1Preparation:=Module[{},
alphas=alphasInput[[All,2]];
betas=betasInput[[All,2]];
NB=Length[betas];
NA=Length[alphas];
NR=Length[regionsInput];
NI=Max[Flatten[betasInput[[All,2]]]];
NC=Length[Join[basepointRegions,multiplicity0Regions][[1,3]]];
Bpre1=regionsInput.({
 {1, 0, 0, 0, 0},
 {0, 1, 0, 0, 0},
 {0, 0, 0, 1, 0},
 {0, 0, 1, 0, 0},
 {0, 0, 0, 0, 1}
});
Bindpre1=Table[{i,Count[Bpre1[[i]],\[Placeholder]]},{i,1,NR}];
Bpre2X=Bpre1[[All,2;;3]];
Bpre3X=DeleteCases[Bpre2X,v_/;v==\[Placeholder],2];
Bpre2Y=Bpre1[[All,4;;5]];
Bpre3Y=DeleteCases[Bpre2Y,v_/;v==\[Placeholder],2];
Bpre4=Flatten[Table[Join[Table[{i,Bpre3X[[i,ii]]}->1,{ii,1,Length[Bpre3X[[i]]]}],Table[{i,Bpre3Y[[i,ii]]}->-1,{ii,1,Length[Bpre3Y[[i]]]}]],{i,1,NR}]];
(* B: ith row=vertices of the ith region, ith column=regions adjacent to the ith intersection point *)
B=SparseArray[Bpre4,{NR,NI},0];
AbsB=Abs[B];
Bind=Bindpre1[[All,2]];
AlgebraRelations={p^pp_ q^qq_:>If[pp>0&&qq>0,0,p^pp q^qq],p q^qq_:>If[qq>0,0,p],p^pp_ q:>If[pp>0,0,q],p q->0};
(* Feedback *)
Print["CHECK THE FOLLOWING FEEDBACK CAREFULLY! "]
If[NA!=NB,Print["#\[Alpha]=",NA,", but #\[Beta]=",NB,"!"]];
Print["NR=#{regions}=",NR];
Print["NI=#{intersection points}=",NI];
If[Length[DeleteCases[Length/@Join[basepointRegions,multiplicity0Regions][[All,3]],NC]]!=0,Print["ERROR: Some Alexander grading inputs from 'basepointRegions' and 'multiplicity0Regions' have different lengths! The number of colours is probably ",NC,"." ],If[Length[DeleteCases[Total[Join[basepointRegions,multiplicity0Regions][[All,3]]],0]]!=0,Print["ERROR: The total sum of Alexander gradings over all basepoints is ",Total[Join[basepointRegions,multiplicity0Regions][[All,3]]],"; however, it should be {0,0,0}."]]];
(*Print[MatrixForm[Join[Transpose[Bpre1/.{\[Placeholder]->""}],{ConstantArray["--",NR]},Transpose[Bindpre1/.{0->""}]]]];
Print[MatrixForm[{Table[i,{i,1,NI}],Table[1,{i,1,NR}].B }]];
*)
Print[" 0 vertices = ",Flatten[Position[Table[1,{i,1,NR}].B,0]]];
Print["+1 vertices = ",Flatten[Position[Table[1,{i,1,NR}].B,1]]];
Print["-1 vertices = ",Flatten[Position[Table[1,{i,1,NR}].B,-1]]];
Print["+2 vertices = ",Flatten[Position[Table[1,{i,1,NR}].B,2]]];
Print["-2 vertices = ",Flatten[Position[Table[1,{i,1,NR}].B,-2]]];
Print["bigon regions = ",Flatten[Position[Bind,2]]];
(* returns the index of the curve occupied by vertex v *)
WhichAlphaQ[v_]:=WhichAlphaQ[v]=If[v==0,0,Position[alphas,v][[1,1]]];
WhichBetaQ[v_]:=WhichBetaQ[v]=If[v==0,0,Position[betas,v][[1,1]]];
(* feedback *)
If[DuplicateFreeQ[Flatten[cancellationSortListInput]]==False,Print["ERROR: multiple cancellation. Bad! Check your input 'cancellationSortListInput'."]];
Print["Intersection points in generators whose cancellation will be attempted last: ",DeleteCases[Range[1,NI],v_/;MemberQ[Flatten[cancellationSortListInput],v]]];
If[MemberQ[Table[DuplicateFreeQ[WhichAlphaQ/@cancellationSortListInput[[i]]],{i,1,Length[cancellationSortListInput]}],True],Print["ERROR: Cancelling pairs belong to DIFFERENT \[Alpha]s. Bad!"]];
If[MemberQ[Table[DuplicateFreeQ[WhichBetaQ/@cancellationSortListInput[[i]]],{i,1,Length[cancellationSortListInput]}],True],Print["ERROR: Cancelling pairs belong to DIFFERENT \[Beta]s. Bad!"]];
If[Sort[Flatten[alphas]]!=Range[1,NI],Print["ERROR: Some intersection points lie on multiple \[Alpha]-curves and/or none. BAD!"]];
If[Sort[Flatten[betas]]!=Range[1,NI],Print["ERROR: Some intersection points lie on multiple \[Beta]-curves and/or none. BAD!"]];
(* Prepare generation of generators *)
AtMostOneOnEachAlpha[v_]:=DuplicateFreeQ[v,WhichAlphaQ[#1]==WhichAlphaQ[#2]&];
AtMostOneOnEachBeta[v_]:=DuplicateFreeQ[v,WhichBetaQ[#1]==WhichBetaQ[#2]&];
NumberOfAlphaCurvesCorrect[v_]:=Length[Cases[v,vv_/;MemberQ[Flatten[alphas],vv]]]==Length[alphas];
NumberOfBetaCurvesCorrect[v_]:=Length[Cases[v,vv_/;MemberQ[Flatten[betas],vv]]]==Length[betas];
];


Step2Generators:=Module[{},
(* memory efficient generation of generators *)
Gpre0={#}&/@betas[[1]]; 
Monitor[ibeta=2;
For[ibeta=2,ibeta<=Length[betas],ibeta++,
Gpre0=Flatten[Parallelize[Outer[(Function[{c},If[Function[{d},DuplicateFreeQ[d]]@DeleteCases[WhichAlphaQ/@c,0],{c},{}]]@Append[#1,#2])&,
Gpre0,betas[[ibeta]],1,1]],2];
],"Looking at \[Beta]-curve "<>ToString[ibeta]<>"/"<>ToString[NB]<>". Current length of Gpre0: "<>ToString[Length[Gpre0]]<>"."];
generatorsUnordd=Select[Gpre0,NumberOfAlphaCurvesCorrect];
(* Ordering the generators *)
CSortListX=Join[Table[{___,cancellationSortListInput[[i,1]],___}->i,{i,1,Length[cancellationSortListInput]}],{Normal[ConstantArray[__,NB]]->Length[cancellationSortListInput]+1}];
CSortListY=Join[Table[{___,cancellationSortListInput[[i,1]],___}->i,{i,1,Length[cancellationSortListInput]}],{Normal[ConstantArray[__,NB]]->Length[cancellationSortListInput]+1}];
MysortX[v_]:=v/.CSortListX;
MysortY[v_]:=v/.CSortListY;
generatorsX=SortBy[generatorsUnordd,MysortX];
generatorsY=SortBy[generatorsUnordd,MysortY];
generatorsYnew=generatorsX/.Table[{a___,cancellationSortListInput[[i,1]],b___}->{a,cancellationSortListInput[[i,2]],b},{i,1,Length[cancellationSortListInput]}];
generators=DeleteDuplicates[Flatten[Transpose[{generatorsYnew,generatorsX}],1]];
(* Translate human readable generators into vectors of 0s and 1s *)
GenToVector[v_]:=Normal[SparseArray[v->ConstantArray[1,Length[betas]],NI,0]];
VectorToGen[v_]:=Function[{c},If[#==={},#[[1]],0]&@Intersection[Flatten[Position[v,1]],betas[[c]]]]/@Length[betas];
(* Feedback Ordering *)
Print["Total number of generators = ",Length[generators],". The first ",If[Length[generators]<5,Length[generators],"5"]," generators are = ",TableForm[{MatrixForm/@generators[[1;;Min[5,Length[generators]]]]}]];
CancelledIPs=Flatten[cancellationSortListInput];
SurvivingGeneratorsAfterFirstCancellation=DeleteCases[Range[Length[generators]],v_/;IntersectingQ[generators[[v]],CancelledIPs]];
(* List of idempotents for generators *)
alphaArcsRepRules=Flatten[Function[{s},(#->s[[1]])&/@s[[2]]]/@alphaArcs];
IdemForGenQ[v_]:=SelectFirst[v/.alphaArcsRepRules,StringQ];
(* Checking if all generators belong to an allowed idempotent *)
Print["After the initial cancellation (de-niceification), we expect to have ",Length[SurvivingGeneratorsAfterFirstCancellation]," generators left:\n",TableForm[Transpose[Join[{{"site","#{generators}"}},Tally[Function[{gen},IdemForGenQ[generators[[gen]]]]/@SurvivingGeneratorsAfterFirstCancellation]]],TableAlignments->Right]];
];


Step3Domains:=Module[{},
(* BEGIN Domains *)
(* Strategy:
Find all domains containing a single region r at a time and then ignore this region r in the following iterations. Start with bigon regions and then the rest. In both cases, we generate all possible (1xn)-rectangles R containing region r, connected via alpha-edges. In the beta-direction, we consider the maximal such rectangle Bmax. Then for each R, we form a matrix build out of R and Bmax that imitates a grid-structure, with horizontal alpha-direction. (For bigon regions, we "double" R to make it symmetric with r in the centre.) Then we fill up the empty (0) entries of this matrix with adjacent regions (if they exist), otherwise ith -1's. Then we delete all rows containing -1's and take all possible intervals of rows containing r. *)
(* Find AlphaEdges 1) square, 2) Bigon, 3) Boundary Region *)
FindAlphaEdges[region_]:=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"{", 
RowBox[{
RowBox[{"regionsInput", "[", 
RowBox[{"[", 
RowBox[{"region", ",", 
RowBox[{"{", 
RowBox[{"2", ",", "3"}], "}"}]}], "]"}], "]"}], ",", 
RowBox[{"regionsInput", "[", 
RowBox[{"[", 
RowBox[{"region", ",", 
RowBox[{"{", 
RowBox[{"4", ",", "5"}], "}"}]}], "]"}], "]"}]}], "}"}], 
RowBox[{
RowBox[{"MemberQ", "[", 
RowBox[{
RowBox[{"regionsInput", "[", 
RowBox[{"[", "region", "]"}], "]"}], ",", "\[Placeholder]"}], "]"}], "==", "False"}]},
{
RowBox[{"{", 
RowBox[{"regionsInput", "[", 
RowBox[{"[", 
RowBox[{"region", ",", 
RowBox[{"{", 
RowBox[{"2", ",", "3"}], "}"}]}], "]"}], "]"}], "}"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\);
(* Find BetaEdges 1) square, 2) Bigon and Boundary Region *)
FindBetaEdges[region_]:=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"{", 
RowBox[{
RowBox[{"regionsInput", "[", 
RowBox[{"[", 
RowBox[{"region", ",", 
RowBox[{"{", 
RowBox[{"3", ",", "4"}], "}"}]}], "]"}], "]"}], ",", 
RowBox[{"regionsInput", "[", 
RowBox[{"[", 
RowBox[{"region", ",", 
RowBox[{"{", 
RowBox[{"5", ",", "2"}], "}"}]}], "]"}], "]"}]}], "}"}], 
RowBox[{
RowBox[{"MemberQ", "[", 
RowBox[{
RowBox[{"regionsInput", "[", 
RowBox[{"[", "region", "]"}], "]"}], ",", "\[Placeholder]"}], "]"}], "==", "False"}]},
{
RowBox[{"{", 
RowBox[{"regionsInput", "[", 
RowBox[{"[", 
RowBox[{"region", ",", 
RowBox[{"{", 
RowBox[{"3", ",", "2"}], "}"}]}], "]"}], "]"}], "}"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\);
(* Generate List of AlphaEdges *)
AlphaEdges=Sort@DeleteDuplicates[Sort/@Flatten[FindAlphaEdges/@Range[1,NR],1]];
(* Generate List of BetaEdges *)
BetaEdges=Sort@DeleteDuplicates[Sort/@Flatten[FindBetaEdges/@Range[1,NR],1]];
(* Lists of Alpha/Beta-edges for each region, ordered by regions *)
AlphaEdgesOfRegions=Map[Position[AlphaEdges,Sort[#]][[1,1]]&,FindAlphaEdges/@Range[1,NR],{2}];
BetaEdgesOfRegions=Map[Position[BetaEdges,Sort[#]][[1,1]]&,FindBetaEdges/@Range[1,NR],{2}];
(* Test if two regins share an edge *)
AlphaAdjacentRegionsQ[region1_,region2_]:=
If[region1==region2,0,If[DuplicateFreeQ[Flatten[AlphaEdgesOfRegions[[{region1,region2}]]]],0,1]];
BetaAdjacentRegionsQ[region1_,region2_]:=
If[region1==region2,0,If[DuplicateFreeQ[Flatten[BetaEdgesOfRegions[[{region1,region2}]]]],0,1]];
(* Create Matrix showing which regions have common alpha/beta-edges; 1 means edge, 0 means no edge *)
AlphaAdjacentRegionsMatrix=Table[Table[AlphaAdjacentRegionsQ[i,ii],{ii,1,NR}],{i,1,NR}];
BetaAdjacentRegionsMatrix=Table[Table[BetaAdjacentRegionsQ[i,ii],{ii,1,NR}],{i,1,NR}];
AlphaAdjacentRegionsMatrix//MatrixForm;
BetaAdjacentRegionsMatrix//MatrixForm;
FindAlphaAdjacentRegions[region_,butnotoneofthese_]:=Complement[If[#=={},{},Flatten[#]]&@Position[AlphaAdjacentRegionsMatrix[[region]],1],butnotoneofthese];
FindBetaAdjacentRegions[region_,butnotoneofthese_]:=Complement[If[#=={},{},Flatten[#]]&@Position[BetaAdjacentRegionsMatrix[[region]],1],butnotoneofthese];
FindNextAlphaAdjacentRegions[region_,butnotthisregion_,butnotoneofthese_]:=If[{}==#,{},#]&@Complement[FindAlphaAdjacentRegions[region,butnotoneofthese],{butnotthisregion}];
FindNextBetaAdjacentRegions[region_,butnotthisregion_,butnotoneofthese_]:=If[{}==#,{},#]&@Complement[FindBetaAdjacentRegions[region,butnotoneofthese],{butnotthisregion}];
(* find all (1xn)-rectangles that involve the input region; we expand in alpha-edge direction *)
(* The region r is inserted at the second position, so for bigons, r is always at the last position of MaxRectangle1xAlpha. *)
MaxRectangle1xAlpha[region_,butnotoneofthese_]:=Module[{r=region,l=FindAlphaAdjacentRegions[region,butnotoneofthese],counter=0},
If[l=={},{r},
l=Insert[l,r,2];
counter=Length[l];
While[Length[l]==counter,
l=Join[FindNextAlphaAdjacentRegions[l[[1]],l[[2]],butnotoneofthese],l];
counter=counter+1];
counter=Length[l];
While[Length[l]==counter,
l=Join[l,FindNextAlphaAdjacentRegions[l[[-1]],l[[-2]],butnotoneofthese]];
counter=counter+1];
l
]];
MaxRectangle1xBeta[region_,butnotoneofthese_]:=Module[{r=region,l=FindBetaAdjacentRegions[region,butnotoneofthese],counter=0},
If[l=={},{r},
l=Insert[l,r,2];
counter=Length[l];
While[Length[l]==counter,
l=Join[FindNextBetaAdjacentRegions[l[[1]],l[[2]],butnotoneofthese],l];
counter=counter+1];
counter=Length[l];
While[Length[l]==counter,
l=Join[l,FindNextBetaAdjacentRegions[l[[-1]],l[[-2]],butnotoneofthese]];
counter=counter+1];
l
]];
(* Every entry in here (=rectangle) becomes a row in its gridmatrix for rectangles *)
Rectangles1xAlpha[region_,butnotoneofthese_]:=SequenceCases[#,{___,region,___},Overlaps->All]&@MaxRectangle1xAlpha[region,butnotoneofthese];
(* Every entry in here (=rectangle) becomes a column in its gridmatrix for rectangles and bigons *)
Rectangles1xBeta[region_,butnotoneofthese_]:=SequenceCases[#,{___,region,___},Overlaps->All]&@MaxRectangle1xBeta[region,butnotoneofthese];
(* Every entry in here (=rectangle) becomes the last row in its gridmatrix for bigons; we make it symmetric, so we need to delete duplicate regions at the end. *)
BigonsAlphaxRxAlpha[region_,butnotoneofthese_]:=Join[Drop[#,-1],Reverse[#]]&/@SequenceCases[MaxRectangle1xAlpha[region,butnotoneofthese],{___,region},Overlaps->All];

(* Preparation for FullGridMatrix *)
(*vector with 1s at positions in v of length iii*)
ToVector[v_,iii_]:=ConstantArray[0,iii]+Sum[Normal[SparseArray[{#[[i]]->1},iii,0]],{i,1,Length[#]}]&@DeleteCases[v,0];
(* Find a common vertex of three regions *)
CommonVertex[r1_,r2_,r3_]:=Position[Normal[ToVector[{r1,r2,r3},NR].AbsB],3][[1,1]];
(* Each time we expand a bigon in beta-direction, there are two common vertices, and we must not choose the same one on either side *)
SecondCommonVertex[r1_,r2_,r3_]:=Last[Position[Normal[ToVector[{r1,r2,r3},NR].AbsB],3]][[1]];
(* alpha direction is horizontal;
(\[NoBreak]r1	?
r2	r3

\[NoBreak])
*)
(* Find a fourth region adjacent to the common vertex of three regions (if it exists) *)
Find4thRegion[r1_,r2_,r3_,butnotoneofthese_]:=If[MemberQ[{r1,r2,r3},-1],-1,
If[#=={},-1,If[AlphaAdjacentRegionsMatrix[[#[[1]],r1]]==1&&BetaAdjacentRegionsMatrix[[#[[1]],r3]]==1&&MemberQ[butnotoneofthese,#[[1]]]==False,#[[1]],-1]]&@
Flatten[Position[AbsB[[All,CommonVertex[r1,r2,r3]]]-ToVector[{r1,r2,r3},NR],1]]];
(* Each time we expand a bigon in beta-direction, there are two common vertices, and we must not choose the same one on either side *)
Find4thRegionBigonAlt[r1_,r2_,r3_,butnotoneofthese_]:=If[MemberQ[{r1,r2,r3},-1],-1,
If[#=={},-1,If[AlphaAdjacentRegionsMatrix[[#[[1]],r1]]==1&&BetaAdjacentRegionsMatrix[[#[[1]],r3]]==1&&MemberQ[butnotoneofthese,#[[1]]]==False,#[[1]],-1]]&@
Flatten[Position[AbsB[[All,SecondCommonVertex[r1,r2,r3]]]-ToVector[{r1,r2,r3},NR],1]]];
(* computes fullgridmatrix *)
(* rectangle takes form of a matrix alpha direction is horizontal=rows=1st level *)
FindAllBetaBigonExtensions[rectangle_,region_,butnotoneofthese_]:=Module[
{maxbeta=MaxRectangle1xBeta[region,butnotoneofthese],
crow,
ccol,
nrows,
ncols,
gridmatrix,
i,
ii,
maxgridmatrix,
output
},
crow=Position[maxbeta,region][[1,1]];
ccol=Position[rectangle[[1]],region][[1,1]];
nrows=Length[maxbeta];
ncols=Dimensions[rectangle][[2]];
gridmatrix=MapAt[Function[c,c/2],
PadRight[PadLeft[rectangle,{crow,ncols}],{nrows,ncols}]+PadRight[PadLeft[Transpose[{maxbeta}],{nrows,ccol}],{nrows,ncols}],
{crow,ccol}];
(* We want to fill up this matrix *)
(* upper left quadrant *)
For[i=crow-1,i>=1, i--,
For[ii=ccol-1,ii>=1, ii--,
(* alpha direction is horizontal;
(\[NoBreak]?	r1
r3	r2

\[NoBreak])
*)
gridmatrix[[i,ii]]=Find4thRegion[
gridmatrix[[i,ii+1]],
gridmatrix[[i+1,ii+1]],
gridmatrix[[i+1,ii]],
butnotoneofthese];
];
];
(* upper right quadrant *)
For[i=crow-1,i>=1, i--,
For[ii=ccol+1,ii<=ncols, ii++,
(* alpha direction is horizontal;
(\[NoBreak]r1	?
r2	r3

\[NoBreak])
*)
gridmatrix[[i,ii]]=Find4thRegionBigonAlt[
gridmatrix[[i,ii-1]],
gridmatrix[[i+1,ii-1]],
gridmatrix[[i+1,ii]],
butnotoneofthese];
];
];
(* gridmatrix is filled up; Now cut off all -1's *)
maxgridmatrix=DeleteCases[gridmatrix,v_/;MemberQ[v,-1]];
output=DeleteDuplicates/@(Flatten/@(Part[maxgridmatrix,#]&/@SequenceCases[Range[1,Length[maxgridmatrix]],{___,Position[maxgridmatrix,region][[1,1]],___},Overlaps->All]));
output
];
FindAllBetaRectangleExtensions[rectangle_,region_,butnotoneofthese_]:=Module[
{maxbeta=MaxRectangle1xBeta[region,butnotoneofthese],
crow,
ccol,
nrows,
ncols,
gridmatrix,
i,
ii,
maxgridmatrix,
output
},
crow=Position[maxbeta,region][[1,1]];
ccol=Position[rectangle[[1]],region][[1,1]];
nrows=Length[maxbeta];
ncols=Dimensions[rectangle][[2]];
gridmatrix=MapAt[Function[c,c/2],
PadRight[PadLeft[rectangle,{crow,ncols}],{nrows,ncols}]+PadRight[PadLeft[Transpose[{maxbeta}],{nrows,ccol}],{nrows,ncols}],
{crow,ccol}];
(* We want to fill up this matrix *)
(* lower right quadrant *)
For[i=crow+1,i<=nrows, i++,
For[ii=ccol+1,ii<=ncols, ii++,
(* alpha direction is horizontal;
(\[NoBreak]r2	r3
r1	?

\[NoBreak])
*)
gridmatrix[[i,ii]]=Find4thRegion[
gridmatrix[[i,ii-1]],
gridmatrix[[i-1,ii-1]],
gridmatrix[[i-1,ii]],
butnotoneofthese];
];
];
(* lower left quadrant *)
For[i=crow+1,i<=nrows, i++,
For[ii=ccol-1,ii>=1, ii--,
(* alpha direction is horizontal;
(\[NoBreak]r3	r2
?	r1

\[NoBreak])
*)
gridmatrix[[i,ii]]=Find4thRegion[
gridmatrix[[i,ii+1]],
gridmatrix[[i-1,ii+1]],
gridmatrix[[i-1,ii]],
butnotoneofthese];
];
];
(* upper left quadrant *)
For[i=crow-1,i>=1, i--,
For[ii=ccol-1,ii>=1, ii--,
(* alpha direction is horizontal;
(\[NoBreak]?	r1
r3	r2

\[NoBreak])
*)
gridmatrix[[i,ii]]=Find4thRegion[
gridmatrix[[i,ii+1]],
gridmatrix[[i+1,ii+1]],
gridmatrix[[i+1,ii]],
butnotoneofthese];
];
];
(* upper right quadrant *)
For[i=crow-1,i>=1, i--,
For[ii=ccol+1,ii<=ncols, ii++,
(* alpha direction is horizontal;
(\[NoBreak]r1	?
r2	r3

\[NoBreak])
*)
gridmatrix[[i,ii]]=Find4thRegion[
gridmatrix[[i,ii-1]],
gridmatrix[[i+1,ii-1]],
gridmatrix[[i+1,ii]],
butnotoneofthese];
];
];
(* gridmatrix is filled up; Now cut off all -1's *)
maxgridmatrix=DeleteCases[gridmatrix,v_/;MemberQ[v,-1]];
output=Flatten/@(Part[maxgridmatrix,#]&/@SequenceCases[Range[1,Length[maxgridmatrix]],{___,Position[maxgridmatrix,region][[1,1]],___},Overlaps->All]);
output
];
FindAllDomainsUsingThisBigonRegion[region_,butnotoneofthese_]:=FindAllBetaBigonExtensions[{#},region,butnotoneofthese]&/@BigonsAlphaxRxAlpha[region,butnotoneofthese];
FindAllDomainsUsingThisSquareRegion[region_,butnotoneofthese_]:=FindAllBetaRectangleExtensions[{#},region,butnotoneofthese]&/@Rectangles1xAlpha[region,butnotoneofthese];
RegionsSquares=(DeleteCases[#,v_/;MemberQ[v,\[Placeholder]]]&@regionsInput)[[All,1]];
RegionsAllButBigons=Sort[RegionsSquares];
RegionsBigons=Sort[Complement[Range[1,NR],RegionsAllButBigons]];
AllDomains=Module[
{
i,
region,
butnotoneofthese={},
domains={}
},
Monitor[
For[i=1,i<=Length[RegionsBigons],i++,
Pause[0.1];
region=RegionsBigons[[i]];
domains=Join[domains,FindAllDomainsUsingThisBigonRegion[region,butnotoneofthese]];
butnotoneofthese=Append[butnotoneofthese,region];
];
,
{{"Iteration counter for bigons (total="<>ToString[Length[RegionsBigons]]<>")" },{i}}//MatrixForm
];
Monitor[
For[i=1,i<=Length[RegionsAllButBigons],i++,
Pause[0.1];
region=RegionsAllButBigons[[i]];
domains=Join[domains,FindAllDomainsUsingThisSquareRegion[region,butnotoneofthese]];
butnotoneofthese=Append[butnotoneofthese,region];
];
,
{{"Iteration counter for squares (total="<>ToString[Length[RegionsAllButBigons]]<>")" },{i}}//MatrixForm
];
Flatten[domains,1]
];
Print["There are ", Length[AllDomains]," rectangles, bigons or boundary rectangles. Here is a random selection of up to 10 of these:",MatrixForm[Transpose[{#,AllDomains[[#]]}&/@RandomSample[Range[Length[AllDomains]],UpTo[10]]]]];
];


Step4Gradings:=Module[{},
(* Given two generators x and y, find a path on \[Beta]-curves and turn it into a path of elementary \[Beta]-segments *)
PathsOnBetas[x_,y_]:=Transpose[{x,y}];
BetaSegmentBasis=DeleteDuplicates[Sort/@Join[BetaEdges,Flatten[multiplicity0Regions[[All,2]],1]]];
BetaSegmentBasisRepRules=Join[MapIndexed[#1->Normal[SparseArray[(#2[[1]]->1),Length[BetaSegmentBasis],0]]&,BetaSegmentBasis],MapIndexed[Reverse[#1]->Normal[SparseArray[(#2[[1]]->-1),Length[BetaSegmentBasis],0]]&,BetaSegmentBasis]];
BetaSegmentGeneration[list_,startPointOnBeta_]:=If[#==0,Print["Error in BetaSegmentGeneration! There is no \[Beta]-segment with starting point "<>ToString[startPointOnBeta]<>" in the list "<>ToString[list]<>"!"];Abort[],#]&@Complement[FirstCase[list,v_/;MemberQ[v,startPointOnBeta],{0,startPointOnBeta}],{startPointOnBeta}][[1]];
ElementaryBetaSegmentsForSingleBeta[xi_,yi_,inputListOfAllowedBetaSegments_:BetaSegmentBasis]:=Module[
{
segmentList={},
allowedBetaSegments=inputListOfAllowedBetaSegments,
oldpoint=xi,
newpoint,
oldLength=Length[BetaSegmentBasis]+1,(*This is for sanity checks only*)
newLength=Length[BetaSegmentBasis](*This is for sanity checks only*)
},
While[oldpoint!=yi,
oldLength=newLength;
newpoint=BetaSegmentGeneration[allowedBetaSegments,oldpoint];
segmentList=Append[segmentList,{oldpoint,newpoint}];
allowedBetaSegments=DeleteCases[allowedBetaSegments,Sort[{oldpoint,newpoint}]];
newLength=Length[allowedBetaSegments];
If[oldLength==newLength,Print["ERROR in \[Beta]-segment generation!"];Abort[]];
oldpoint=newpoint;
];
segmentList
];
ElementaryBetaSegmentsOriented[x_,y_]:=Flatten[Apply[ElementaryBetaSegmentsForSingleBeta,PathsOnBetas[x,y],1],1];
BetaSegmentVector[x_,y_]:=Total[ElementaryBetaSegmentsOriented[x,y]/.BetaSegmentBasisRepRules];

BetaSegmentsFromRegions=FindBetaEdges/@Range[1,NR];
BetaSegmentsFromAllRegions=Join[BetaSegmentsFromRegions,multiplicity0Regions[[All,2]]];

OneHalfOfBetaCurves[betacurve_]:=ElementaryBetaSegmentsForSingleBeta[betacurve[[1]],betacurve[[2]]];
BothHalvesOfBetaCurves[betacurve_]:=Join[#,ElementaryBetaSegmentsForSingleBeta[betacurve[[2]],betacurve[[1]],Complement[BetaSegmentBasis,{Sort[#[[-1]]]}]]]&@OneHalfOfBetaCurves[betacurve];
BetaSegmentsFromBetaCurves=BothHalvesOfBetaCurves/@betas;

BetaSegmentsFromRegionsAndBetaCurves=Join[BetaSegmentsFromAllRegions,BetaSegmentsFromBetaCurves];
DomainsMatrix=Transpose[Total[#/.BetaSegmentBasisRepRules]&/@BetaSegmentsFromRegionsAndBetaCurves];
FindAConnectingDomain[x_,y_]:=Drop[LinearSolve[DomainsMatrix,BetaSegmentVector[x,y]],-NB];
AlexanderGradingEvaluation=Function[{alex},Normal[SparseArray[#[[1]]->-#[[3,alex]]&/@Join[basepointRegions,multiplicity0Regions],Length[BetaSegmentsFromAllRegions],0]]]/@Range[NC];
EulerNumber4Evaluation=Normal[Join [SparseArray[#->2&/@RegionsBigons,NR,0]+SparseArray[#[[1]]->#[[4]]&/@basepointRegions,NR,0],SparseArray[#[[1]]-NR->#[[4]]&/@multiplicity0Regions,Length[multiplicity0Regions],0]]];
IncreaseAlexGradingFromXtoY[x_,y_]:=FindAConnectingDomain[x,y].AlexanderGradingEvaluation[[#]]&/@Range[NC];
IncreaseDeltaGradingFromXtoY[x_,y_]:=(#.EulerNumber4Evaluation+Multiplicities4AtCorners[#,x]+Multiplicities4AtCorners[#,y])/4&@FindAConnectingDomain[x,y];
IntersectionPointsOfAllRegionsWithMultiplicities=Join[DeleteCases[#,\[Placeholder]]&/@regionsInput[[All,2;;5]],Flatten/@multiplicity0Regions[[All,2]]];
Multiplicities4AtCorners[domain_,gen_]:=domain.(Function[{region},Total[Count[IntersectionPointsOfAllRegionsWithMultiplicities[[region]],#]&/@gen]]/@Range[Length[IntersectionPointsOfAllRegionsWithMultiplicities]]);

(* grading checks *)
GradingsCheck=0;
If[Length[DeleteCases[Total[Total[#/.BetaSegmentBasisRepRules]&/@BetaSegmentsFromBetaCurves],v_/;Abs[v]===1]]!=0,GradingsCheck=1;Print["ERROR: There are some \[Beta]-segments that lie on no or multiple \[Beta]-curves. Please check your input!"]];
If[Length[DeleteCases[Total[Total[#/.BetaSegmentBasisRepRules]&/@BetaSegmentsFromAllRegions],0]]!=0,GradingsCheck=1;Print["ERROR: Each \[Beta]-segments should be the boundary of exactly two regions (including the multiplicity 0 regions). However, this does not seem to be the case. Please check your input!"]];
If[GradingsCheck===0,Print["Grading calculations completed successfully."]];
ClearAll[GradingsCheck];
];


Step5Differentials:=Module[{},
(* Now each domain has an index and we only refer to the domains by their indices *)
(* List of Euler numbers of all domains *)
TimeProcessStarted=Now;
PrintTemporary["Process started at ",TimeProcessStarted];
EulerNumber4=Parallelize[If[Intersection[RegionsBigons,#]=={},0,2]&/@AllDomains];
(* multiplicities at generator intersection points *)
NxOrYCorners4[domainindex_,generatorindex_]:=ToVector[AllDomains[[domainindex]],NR].AbsB.ToVector[generators[[generatorindex]],NI];
(* Add all three components above together *)
Index[domainindex_,xindex_,yindex_]:=NxOrYCorners4[domainindex,xindex]+NxOrYCorners4[domainindex,yindex]+EulerNumber4[[domainindex]];
(* Compute starting and ending intersection points of all domains *)
PrintTemporary["Computed indices for domains."];xpreForAllDomains=Parallelize[Flatten[Position[ToVector[AllDomains[[#]],NR].B,1]]&/@Range[1,Length[AllDomains]]];
PrintTemporary["Computed starting intersection points of domains."];ypreForAllDomains=Parallelize[Flatten[Position[ToVector[AllDomains[[#]],NR].B,-1]]&/@Range[1,Length[AllDomains]]];
(* Find all starting generators of domains; this can take quite a while *)
xForAllDomainsF[c_]:={c[[1]],#}&/@Flatten[Position[generators,_List?(SubsetQ[#,c[[2]]]&),1]];
PrintTemporary["Computed ending intersection points of domains."];PrintTemporary["There are "<>ToString[Length[xpreForAllDomains]]<>" domains that I need to look at. Sorting domains by starting generators..."];xForAllDomains=ParallelMap[xForAllDomainsF,Transpose[{Range[Length[xpreForAllDomains]],xpreForAllDomains}]];
(* rearrange xForAllDomains, so that it is now a list with list[[xindex]]=list of domains with starting generator xindex *)
DomainsForX=ToExpression/@SparseArray[#[[1,2]]->ToString[#[[All,1]]]&/@GatherBy[Flatten[xForAllDomains,1],Last],{Length[generators]},"{}"];
(* Given domain and starting generator, find end generator *)
yFromDomainAndX[domainindex_,xindex_]:=If[#=={},0,#[[1,1]]]&@Position[generators,SortBy[Join[Complement[generators[[xindex]],xpreForAllDomains[[domainindex]]],ypreForAllDomains[[domainindex]]],WhichBetaQ]];
(* Note: there is at most one domain connecting two generators (nice diagrams are totally admissible) 
We build a matrix from DomainsForX, by essentially replacing the list of domains for each xindex by a vector with vector[[yindex]]=domain connecting xindex and yindex with the correct index.
So the columns in StructureMapsDomains corrspond to x's, because we transpose.
*)

(* Compute Structure Maps as a Sparse Array *)
PrintTemporary["Calculation of the structure map. There are "<>ToString[Length[DomainsForX]]<>" generators."];
StructureMapsDomainsSparseArrayRules=Flatten[Parallelize@MapIndexed[
Apply[
Function[
{domainindex,yindex},
{yindex,#2[[1]]}-> If[Index[domainindex,#2[[1]],yindex]==4,domainindex,0]
],
Select[
Function[{domainindex},{domainindex,yFromDomainAndX[domainindex,#2[[1]]]}]/@#1,Function[{pair},pair[[2]]!=0]
],
1
]&,
DomainsForX]];
(* Convert entries to strings as there might be multiple domains connecting the same generators and sparse arrays apparently cannot have lists as entries (why?) *)
StructureMapsDomainsSparseArrayRulesAsStrings=(#[[1,1]]->ToString[#[[All,2]]])&/@GatherBy[DeleteCases[StructureMapsDomainsSparseArrayRules,v_/;v[[2]]==0],#[[1]]&];
StructureMapsDomainsSparse=SparseArray[StructureMapsDomainsSparseArrayRulesAsStrings,{Length[generators],Length[generators]},0];

AlgebraRepRules=(#[[1]]->#[[2]])&/@basepointRegions;
StructureMapsAux0Sparse[DomainIndex_]:=
\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{"0", 
RowBox[{"DomainIndex", "===", "0"}]},
{
RowBox[{
RowBox[{"Apply", "[", 
RowBox[{"Times", ",", 
RowBox[{"DeleteCases", "[", 
RowBox[{
RowBox[{
RowBox[{"AllDomains", "[", 
RowBox[{"[", "DomainIndex", "]"}], "]"}], "/.", "AlgebraRepRules"}], ",", "_Integer"}], "]"}]}], "]"}], "/.", "AlgebraRelations"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\);
StructureMapsAux1Sparse[DomainIndex_]:=If[DomainIndex===0,0,Total[StructureMapsAux0Sparse/@ToExpression[DomainIndex]]];
PrintTemporary["Calculation of StructureMapsSparse."];
differentials=SparseArray[(#[[1]]->StructureMapsAux1Sparse[#[[2]]])&/@ArrayRules[StructureMapsDomainsSparse],{Length[generators],Length[generators]},0];
GenIndexFromNewIndex[sublist_,index_,target_:generators]:=Position[target,sublist[[index]]][[1,1]];
GenIndexFromNewIndex::usage="GenIndexFromNewIndex[sublist_,index_] finds the index of a generator in 'generators', given an index of a generator in a sublist of generatorsit. An optional parameter specifies the target index list, default is 'generators'.";
Print["This process took ",ToString[DateDifference[TimeProcessStarted,Now,"Minute"]],"."];
(* backup *)
DumpSave[BackupFilePath<>"_BeforeCancellation.mx","Global`"];
Print[" << backup saved at: " ,BackupFilePath<>"_BeforeCancellation.mx >>"];
];


Step6Cancellation:=Module[{},
(* cancellation function *)
Cancellation::usage="Cancellation[StructureMaps,generators] computes the complex obtained from StructureMaps by doing certain cancellations. 'genset' is the set of generators underlying 'StructureMaps'. 
The way cancellations are carried out can be affected by an optional third parameter, which takes one of the following values:
1) 0; this is the default and means that in each iteration, only a cancellation from second generator to the first will be carried out (if possible). 
2) 1, or in fact any other integer; In this case, any identity morphism will be cancelled (if possible).
3) list of generator pairs {endgen,startgen}. Those cancellations will be performed if possible. Cancellation will stop at the first instance the conditions for cancellation are not satisfied. The indices here are those corresponding to 'genset'";
Cancellation[StructureMaps_,genset_,genstocancelInput_:0]:=Module[{
MMit=StructureMaps,(* MMit[[y,x]], MMit[[All,i]]= column i *)
generatorsit=genset,
genstocancel=genstocancelInput,
diff2=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"{", 
RowBox[{"{", 
RowBox[{"1", ",", "2"}], "}"}], "}"}], 
RowBox[{"genstocancelInput", "===", "0"}]},
{
RowBox[{
RowBox[{"Cases", "[", 
RowBox[{
RowBox[{"ArrayRules", "[", "StructureMaps", "]"}], ",", 
RowBox[{"v_", "/;", 
RowBox[{"OddQ", "[", 
RowBox[{"v", "[", 
RowBox[{"[", "2", "]"}], "]"}], "]"}]}]}], "]"}], "[", 
RowBox[{"[", 
RowBox[{"All", ",", "1"}], "]"}], "]"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False], 
RowBox[{"IntegerQ", "[", "genstocancelInput", "]"}]},
{
RowBox[{"If", "[", 
RowBox[{
RowBox[{"genstocancelInput", "===", 
RowBox[{"{", "}"}]}], ",", 
RowBox[{"{", "}"}], ",", 
RowBox[{"{", 
RowBox[{"genstocancelInput", "[", 
RowBox[{"[", "1", "]"}], "]"}], "}"}]}], "]"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\),(* diff2: positions of honest differentials in MMtit*)
it=0,(* iterator counting the number of cancellations *)
coorit=1,(* iterator testing all positions *)
coorcond=0,(* flag. 1: generator pair at current coor can be cancelled; 0: we need to look further, so coorit=coorit+1 *)
coorexit=0,(* flag. 0: there are still untested generator pairs; 1: none of the generator pairs can be cancelled *)
cooritmax=0,(* auxiliary variable for flag coorexit *)
vb={},
vc={},
coor={1,2},
RemainingGenRange=Range[3,Length[StructureMaps]],
Output={{},{},{}},
LOGcancelledgenerators={}(* list of all cancelled generatorpairs {{enditerindex,startiterindex},{endgensetindex,startgensetindex}}; iterindex means the index of the generator in the iteration step in which it is cancelled. gensetindex menas its index in 'genset'. *)
},
TimeProcessStarted=Now;
PrintTemporary["Process started at ",TimeProcessStarted];
If[Length[StructureMaps]!=Length[genset],Print["USER ERROR: Generator set cannot belong to the structure maps!"],
If[If[IntegerQ[genstocancelInput],False,(DuplicateFreeQ[Flatten[genstocancelInput]]&&SubsetQ[Range[1,Length[genset]],Flatten[genstocancelInput]])==False],Print["USER ERROR: Check you generator pairs you want cancelled!"],
cooritmax=Length[diff2];
(* test for generator pairs that can be cancelled *)
While[coorit<=cooritmax&&coorcond===0,
coor=diff2[[coorit]];
RemainingGenRange=Complement[Range[1,Length[MMit]],coor];
vc=MMit[[RemainingGenRange,coor[[2]]]]; (* image of x *)
vb=MMit[[coor[[1]],RemainingGenRange]];  (* "preimage" of y *)
If[OddQ[MMit[[coor[[1]],coor[[2]]]]],coorcond=1,coorcond=0];
coorit=coorit+1
];
If[coorcond===0,coorexit=1;Print["No Cancellation possible."],
(* cancellation iteration *)
Monitor[
While[If[genstocancelInput===0,
diff2=!={}&&coorexit===0&&Length[generatorsit]>Length[SurvivingGeneratorsAfterFirstCancellation],
diff2=!={}&&coorexit===0],
(* In case of a prescribed list of cancellation pairs, removing the next pair to be cancelled and shifting the indices *)
If[IntegerQ[genstocancel]===False,genstocancel=Map[GenIndexFromNewIndex[generatorsit,#,generatorsit[[RemainingGenRange]]]&,Drop[genstocancel,1],{2}]];
(* record which generators are cancelled in this iteration *)
LOGcancelledgenerators=Append[LOGcancelledgenerators,{coor,{GenIndexFromNewIndex[generatorsit,coor[[1]],genset],GenIndexFromNewIndex[generatorsit,coor[[2]],genset]}}];
(* Adding contribution from cancelled pair to remaining morphisms *)
MMit= Map[PolynomialMod[#,2]/.AlgebraRelations&,MMit[[RemainingGenRange,RemainingGenRange]]+Outer[Times,vc,vb,1,1],{2}];
(* cancelling generators *)
generatorsit=generatorsit[[RemainingGenRange]];
(* find new generator pairs *)
diff2=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"{", 
RowBox[{"{", 
RowBox[{"1", ",", "2"}], "}"}], "}"}], 
RowBox[{"genstocancelInput", "===", "0"}]},
{
RowBox[{
RowBox[{"Cases", "[", 
RowBox[{
RowBox[{"ArrayRules", "[", "MMit", "]"}], ",", 
RowBox[{"v_", "/;", 
RowBox[{
RowBox[{"v", "[", 
RowBox[{"[", "2", "]"}], "]"}], "===", "1"}]}]}], "]"}], "[", 
RowBox[{"[", 
RowBox[{"All", ",", "1"}], "]"}], "]"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False], 
RowBox[{"IntegerQ", "[", "genstocancelInput", "]"}]},
{
RowBox[{"If", "[", 
RowBox[{
RowBox[{"genstocancel", "===", 
RowBox[{"{", "}"}]}], ",", 
RowBox[{"{", "}"}], ",", 
RowBox[{"{", 
RowBox[{"genstocancel", "[", 
RowBox[{"[", "1", "]"}], "]"}], "}"}]}], "]"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\);(* Reset the generator pair iterator *)
coorit=1;
(* Reset flag *)
coorcond=0;
(* Reset auxiliary variable for flag coorexit *)
cooritmax=Length[diff2];
(* test for generator pairs that can be cancelled *)
While[coorit<=cooritmax&&coorcond===0,
coor=diff2[[coorit]];
RemainingGenRange=Complement[Range[1,Length[MMit]],coor];
vc=MMit[[RemainingGenRange,coor[[2]]]]; (* image of x *)
vb=MMit[[coor[[1]],RemainingGenRange]];  (* "preimage" of y *)
If[OddQ[MMit[[coor[[1]],coor[[2]]]]],coorcond=1,coorcond=0];
coorit=coorit+1;
];
If[coorcond===0,coorexit=1];
it=it+1;]
,"Iteration: "<>ToString[it+1]<>"\nNumber of remaining generators: "<>ToString[Length[generatorsit]]
];
];
Output=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"{", 
RowBox[{
RowBox[{
RowBox[{"PolynomialMod", "[", 
RowBox[{
RowBox[{"Normal", "[", "MMit", "]"}], ",", "2"}], "]"}], "/.", "AlgebraRelations"}], ",", "generatorsit"}], "}"}], 
RowBox[{"genstocancel", "===", "0"}]},
{
RowBox[{"{", 
RowBox[{
RowBox[{
RowBox[{"PolynomialMod", "[", 
RowBox[{
RowBox[{"Normal", "[", "MMit", "]"}], ",", "2"}], "]"}], "/.", "AlgebraRelations"}], ",", "generatorsit", ",", "LOGcancelledgenerators"}], "}"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\);
(*More Feedback*)
Print["This calculation finished after "<>ToString[it]<>" iteration"<>If[it==1,"","s"]<>" and took ",ToString[DateDifference[TimeProcessStarted,Now,"Minute"]],"."];
Print["There are ",Length[generatorsit]," generators left.",If[genstocancelInput=!=0&&Length[LOGcancelledgenerators]>0," The cancelled generators were: \n",""],If[genstocancelInput=!=0&&Length[LOGcancelledgenerators]>0,Transpose[{"("<>ToString[#[[1,2]]]<>")",ToString[#[[2,2]]],"\[DownArrow]",ToString[#[[2,1]]],"("<>ToString[#[[1,1]]]<>")"}&/@LOGcancelledgenerators]//MatrixForm,""]];
]
];
Output
];

(* Find "identity" labels; this is only used in nonsparse cancellation below*)
IdentityQ[v_]:=(v===1);

(* obsolete cancellation function; we do everything sparse now *)
CancellationNonSparse::usage="Cancellation[StructureMaps,generators,genset] computes the complex obtained from StructureMaps by doing certain cancellations. 'generators' is the set of generators underlying 'StructureMaps'. 
The way cancellations are carried out can be affected by an optional third parameter, which takes one of the following values:
1) 1, or in fact any other integer; In this case, any identity morphism will be cancelled (if possible).
2) list of generator pairs {endgen,startgen}. Those cancellations will be performed if possible. Cancellation will stop at the first instance the conditions for cancellation are not satisfied. The indices here are those corresponding to 'generators'";
CancellationNonSparse[StructureMaps_,genset_,genstocancelInput_:1]:=CancellationNonSparse0[StructureMaps,genset,genstocancelInput];
CancellationNonSparse0[StructureMaps_,genset_,genstocancelInput_]:=Module[{
MMit=StructureMaps,(* MMit[[y,x]], MMit[[All,i]]= column i *)
generatorsit=genset,
genstocancel=genstocancelInput,
diff2=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"Position", "[", 
RowBox[{"StructureMaps", ",", 
RowBox[{"_", "?", "IdentityQ"}], ",", 
RowBox[{"{", "2", "}"}]}], "]"}], 
RowBox[{"IntegerQ", "[", "genstocancelInput", "]"}]},
{
RowBox[{"If", "[", 
RowBox[{
RowBox[{"genstocancelInput", "===", 
RowBox[{"{", "}"}]}], ",", 
RowBox[{"{", "}"}], ",", 
RowBox[{"{", 
RowBox[{"genstocancelInput", "[", 
RowBox[{"[", "1", "]"}], "]"}], "}"}]}], "]"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\),(* diff2: positions of honest differentials in MMtit*)
it=0,(* iterator counting the number of cancellations *)
coorit=1,(* iterator testing all positions *)
coorcond=0,(* flag. 1: generator pair at current coor can be cancelled; 0: we need to look further, so coorit=coorit+1 *)
coorexit=0,(* flag. 0: there are still untested generator pairs; 1: none of the generator pairs can be cancelled *)
cooritmax=0,(* auxiliary variable for flag coorexit *)
vb={},
vc={},
coor={1,2},
RemainingGenRange=Range[3,Length[StructureMaps]],
Output={{},{},{}},
LOGcancelledgenerators={}(* list of all cancelled generatorpairs {{enditerindex,startiterindex},{endgensetindex,startgensetindex}}; iterindex means the index of the generator in the iteration step in which it is cancelled. gensetindex menas its index in 'genset'. *)
},
TimeProcessStarted=Now;
PrintTemporary["Process started at ",TimeProcessStarted];
If[Length[StructureMaps]!=Length[genset],Print["USER ERROR: Generator set cannot belong to the structure maps!"],
If[If[IntegerQ[genstocancelInput],False,(DuplicateFreeQ[Flatten[genstocancelInput]]&&SubsetQ[Range[1,Length[genset]],Flatten[genstocancelInput]])==False],Print["USER ERROR: Check you generator pairs you want cancelled!"],
cooritmax=Length[diff2];
(* test for generator pairs that can be cancelled *)
While[coorit<=cooritmax&&coorcond==0,
coor=diff2[[coorit]];
RemainingGenRange=Complement[Range[1,Length[MMit]],coor];
vc=MMit[[RemainingGenRange,coor[[2]]]]; (* image of x *)
vb=MMit[[coor[[1]],RemainingGenRange]];  (* "preimage" of y *)
If[IdentityQ[MMit[[coor[[1]],coor[[2]]]]],coorcond=1,coorcond=0];
coorit=coorit+1;
];
If[coorcond==0,coorexit=1;Print["No Cancellation possible."],
(* cancellation iteration *)
Monitor[
While[diff2=!={}&&coorexit==0,
(* In case of a prescribed list of cancellation pairs, removing the next pair to be cancelled and shifting the indices *)
If[IntegerQ[genstocancel]==False,genstocancel=Map[GenIndexFromNewIndex[generatorsit,#,generatorsit[[RemainingGenRange]]]&,Drop[genstocancel,1],{2}]];
(* record which generators are cancelled in this iteration *)
LOGcancelledgenerators=Append[LOGcancelledgenerators,{coor,{GenIndexFromNewIndex[generatorsit,coor[[1]],genset],GenIndexFromNewIndex[generatorsit,coor[[2]],genset]}}];
(* Adding contribution from cancelled pair to remaining morphisms *)
MMit=PolynomialMod[MMit[[RemainingGenRange,RemainingGenRange]]+Outer[Times,vc,vb,1,1],2];
(* cancelling generators *)
generatorsit=generatorsit[[RemainingGenRange]];
(* find new generator pairs *)
diff2=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"Position", "[", 
RowBox[{"MMit", ",", 
RowBox[{"_", "?", "IdentityQ"}], ",", 
RowBox[{"{", "2", "}"}]}], "]"}], 
RowBox[{"IntegerQ", "[", "genstocancelInput", "]"}]},
{
RowBox[{"If", "[", 
RowBox[{
RowBox[{"genstocancel", "==", 
RowBox[{"{", "}"}]}], ",", 
RowBox[{"{", "}"}], ",", 
RowBox[{"{", 
RowBox[{"genstocancel", "[", 
RowBox[{"[", "1", "]"}], "]"}], "}"}]}], "]"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\);
(* Reset the generator pair iterator *)
coorit=1;
(* Reset flag *)
coorcond=0;
(* Reset auxiliary variable for flag coorexit *)
cooritmax=Length[diff2];
(* test for generator pairs that can be cancelled *)
While[coorit<=cooritmax&&coorcond==0,
coor=diff2[[coorit]];
RemainingGenRange=Complement[Range[1,Length[MMit]],coor];
vc=MMit[[RemainingGenRange,coor[[2]]]]; (* image of x *)
vb=MMit[[coor[[1]],RemainingGenRange]];  (* "preimage" of y *)
If[IdentityQ[MMit[[coor[[1]],coor[[2]]]]]&&MMit[[coor[[1]],coor[[1]]]]==MMit[[coor[[2]],coor[[2]]]],coorcond=1,coorcond=0];
coorit=coorit+1;
];
If[coorcond==0,coorexit=1];
it=it+1;]
,"Iteration: "<>ToString[it+1]<>"\nNumber of remaining generators: "<>ToString[Length[generatorsit]]
];
];
Output=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"{", 
RowBox[{"MMit", ",", "generatorsit"}], "}"}], 
RowBox[{"genstocancel", "===", "0"}]},
{
RowBox[{"{", 
RowBox[{"MMit", ",", "generatorsit", ",", "LOGcancelledgenerators"}], "}"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\);
(*More Feedback*)
Print["This calculation finished after "<>ToString[it]<>" iteration"<>If[it==1,"","s"]<>" and took ",ToString[DateDifference[TimeProcessStarted,Now,"Minute"]],"."];
Print["There are ",Length[generatorsit]," generators left.",If[genstocancelInput=!=0&&Length[LOGcancelledgenerators]>0," The cancelled generators were: \n",""],If[genstocancelInput=!=0&&Length[LOGcancelledgenerators]>0,Transpose[{"("<>ToString[#[[1,2]]]<>")",ToString[#[[2,2]]],"\[DownArrow]",ToString[#[[2,1]]],"("<>ToString[#[[1,1]]]<>")"}&/@LOGcancelledgenerators]//MatrixForm,""]];
];
];
Output
];
];


Step7PostProcessing:=Module[{},
OutputPreparation;
HomotopyPreparation;
];


OutputPreparation:=Module[{},
GenTableWithIdems[gens_]:=MatrixForm[Sort[{IdemForGenQ[gens[[#[[1]]]]],#}&/@GatherBy[Range[Length[gens]],IdemForGenQ[gens[[#]]]&]]];
GenTableWithIdems::usage="GenTableWithIdems[gens_] displays a list of generators gens, ordered by idempotents.";

(* generator gradings *)
AlexanderGradingsRelative[generatorset_]:=Join[{ConstantArray[0,NC]},IncreaseAlexGradingFromXtoY[generatorset[[1]],#]&/@Drop[generatorset,1]];
DeltaGradingsRelative[generatorset_]:=Join[{0},IncreaseDeltaGradingFromXtoY[generatorset[[1]],#]&/@Drop[generatorset,1]];
AlexanderGradingsAbsolute[generatorset_]:=Module[{list=AlexanderGradingsRelative[generatorset],shift},shift=Mean/@Transpose[list];#-shift&/@list];
DeltaAndAlexGradings[generatorset_]:=Join[Split[DeltaGradingsRelative[generatorset],False],AlexanderGradingsAbsolute[generatorset],2];
AllGradingsAndIdems[generatorset_]:=Join[Split[IdemForGenQ/@generatorset,False],DeltaAndAlexGradings[generatorset],2];
AllGradingsIdemsAndIndices[generatorset_]:=MapIndexed[Join[#2,#1]&,AllGradingsAndIdems[generatorset]];
(* display functions for gradings *)
GradingsOutputForm[variable_,grading_]:=If[IntegerQ[grading],variable^HoldForm[grading],variable^Style[HoldForm[grading],Tiny],1];
AlexgradingsOutputForm[grading_,startAlex_:1]:=Times@@MapIndexed[Function[{alex,index},GradingsOutputForm[Subscript[t, index[[1]]+startAlex-1],alex]],grading[[startAlex;;]]];
DeltagradingOutputForm[grading_]:=GradingsOutputForm[\[Delta],grading];
DeltaAndAlexgradingOutputForm[grading_,startAlex_:1]:=DeltagradingOutputForm[grading[[1]]]*AlexgradingsOutputForm[grading[[2;;]],startAlex];
CollapseAlexGradings::usage="CollapseAlexGradings reduces the Alexander grading to a one-variate grading; the input grading should be of the full form (index,site,delta,alexgradings...); the output is (index,site,delta,alexgradings...). There is an optional parameter which can be used to reverse orientations of some strands; the parameter should be a list of \[PlusMinus]1s, one for each colour, where -1 means orientation reversal.";
CollapseAlexGradings[grading_,switch_:0]:=Module[{switchvector},
switchvector=If[switch===0,ConstantArray[1,Length[grading]-3],switch];
Join[grading[[1;;3]],{grading[[2]]/.{"a"->1,"b"->1,"c"->-1,"d"->-1}},{switchvector.grading[[4;;]]}]
];

(* Labelled graph output *)
PQArrowStyle[v_]:=If[Exponent[v,q]>0,If[Exponent[v,p]>0,{Thick,Black},{Dashed,Black}],Black];
WhiteBackground[v_]:=Framed[Style[v],{Background->White,FrameStyle->White,FrameMargins->0}];
VertexLabelGeneration[VertexLabelSwitch_,generators_,npos_,grading_]:=
\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{"None", 
RowBox[{"VertexLabelSwitch", "===", "0"}]},
{
RowBox[{"MapIndexed", "[", 
RowBox[{
RowBox[{
RowBox[{"(", 
RowBox[{
RowBox[{"#2", "[", 
RowBox[{"[", "1", "]"}], "]"}], "->", 
RowBox[{"Placed", "[", 
RowBox[{
RowBox[{"ToString", "[", "#1", "]"}], ",", "Center"}], "]"}]}], ")"}], "&"}], ",", "npos"}], "]"}], 
RowBox[{"VertexLabelSwitch", "===", "1"}]},
{
RowBox[{"MapIndexed", "[", 
RowBox[{
RowBox[{
RowBox[{"(", 
RowBox[{
RowBox[{"#2", "[", 
RowBox[{"[", "1", "]"}], "]"}], "->", 
RowBox[{"Placed", "[", 
RowBox[{
RowBox[{
RowBox[{"ToString", "[", "#1", "]"}], "<>", "\"\<\\n\>\"", "<>", 
RowBox[{"ToString", "[", 
RowBox[{"generators", "[", 
RowBox[{"[", "#1", "]"}], "]"}], "]"}]}], ",", "Center"}], "]"}]}], ")"}], "&"}], ",", "npos"}], "]"}], 
RowBox[{"VertexLabelSwitch", "===", "2"}]},
{
RowBox[{"MapIndexed", "[", 
RowBox[{
RowBox[{
RowBox[{"(", 
RowBox[{
RowBox[{"#2", "[", 
RowBox[{"[", "1", "]"}], "]"}], "->", 
RowBox[{"Placed", "[", 
RowBox[{
RowBox[{"WhiteBackground", "[", 
RowBox[{"DeltaAndAlexgradingOutputForm", "[", "#1", "]"}], "]"}], ",", "Above"}], "]"}]}], ")"}], "&"}], ",", 
RowBox[{"grading", "[", 
RowBox[{"[", "npos", "]"}], "]"}]}], "]"}], 
RowBox[{"VertexLabelSwitch", "===", "\"\<A\[Delta]\>\""}]},
{
RowBox[{"MapIndexed", "[", 
RowBox[{
RowBox[{
RowBox[{"(", 
RowBox[{
RowBox[{"#2", "[", 
RowBox[{"[", "1", "]"}], "]"}], "->", 
RowBox[{"Placed", "[", 
RowBox[{
RowBox[{"AlexgradingsOutputForm", "[", "#1", "]"}], ",", "Above"}], "]"}]}], ")"}], "&"}], ",", 
RowBox[{"grading", "[", 
RowBox[{"[", "npos", "]"}], "]"}]}], "]"}], 
RowBox[{"VertexLabelSwitch", "===", "\"\<A\>\""}]},
{
RowBox[{"MapIndexed", "[", 
RowBox[{
RowBox[{
RowBox[{"(", 
RowBox[{
RowBox[{"#2", "[", 
RowBox[{"[", "1", "]"}], "]"}], "->", 
RowBox[{"Placed", "[", 
RowBox[{
RowBox[{"GradingsOutputForm", "[", 
RowBox[{"\[Delta]", ",", "#1"}], "]"}], ",", "Center"}], "]"}]}], ")"}], "&"}], ",", 
RowBox[{"grading", "[", 
RowBox[{"[", "npos", "]"}], "]"}]}], "]"}], 
RowBox[{"VertexLabelSwitch", "===", "\"\<\[Delta]\>\""}]}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\);
ShowGraph0[StructureMap_,generators_,VertexLabelSwitch_,EdgeLabelSwitch_,pos_,CoordList_,precomputedgradings_:0]:=Module[{npos=pos,StructureMaps,gens,grading},
If[IntegerQ[pos],npos=Range[Length[generators]]];If[precomputedgradings===0,grading=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"DeltaAndAlexGradings", "[", "generators", "]"}], 
RowBox[{"VertexLabelSwitch", "===", "\"\<A\[Delta]\>\""}]},
{
RowBox[{"DeltaGradingsRelative", "[", "generators", "]"}], 
RowBox[{"VertexLabelSwitch", "===", "\"\<\[Delta]\>\""}]},
{
RowBox[{"AlexanderGradingsAbsolute", "[", "generators", "]"}], 
RowBox[{"VertexLabelSwitch", "===", "\"\<A\>\""}]},
{"0", "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\),grading=precomputedgradings];
StructureMaps=StructureMap[[npos,npos]];
gens=generators[[npos]];AdjacencyGraph[Map[If[#=!=0,1,0]&,Transpose[StructureMaps],{2}],{
DirectedEdges->If[EdgeLabelSwitch===0,False,True],
EdgeStyle->Apply[((#2->#1)->PQArrowStyle[StructureMaps[[#1,#2]]])&,Position[Map[If[#=!=0,1,0]&,StructureMaps,{2}],v_/;v==1,{2}],{1}],
GraphLayout->"SpringElectricalEmbedding",VertexCoordinates->CoordList,
GraphHighlight->(#[[2]]->#[[1]]&)/@Position[StructureMaps,_?IdentityQ,{2}],
EdgeLabels->If[EdgeLabelSwitch===0,None,Apply[((#2->#1)->WhiteBackground[StructureMaps[[#1,#2]]] )&,Position[Map[If[#=!=0,1,0]&,StructureMaps,{2}],v_/;v==1,{2}],{1}]],
VertexSize->0.3,
ImageSize->Small,
VertexStyle->((#1->IdemForGenQ[gens[[#1]]]/.{"a"->Directive[Red,EdgeForm[None]],"b"->Directive[Blue,EdgeForm[None]],"c"->Directive[Green,EdgeForm[None]],"d"->Directive[Yellow,EdgeForm[None]]})&/@Range[Length[npos]]),
VertexLabels->VertexLabelGeneration[VertexLabelSwitch,generators,npos,grading]
}]];
ShowGraph::usage="ShowGraph[maps_,gens_,VertexLabelSwitch_:1,EdgeLabelSwitch_:1,pos_:0,CoordList_:Automatic] draws a graphical representation of 'maps'. 'gens' is the underlying set of generators with differentials 'maps'. 
1) The optional parameter 'VertexLabelSwitch' can be set to 0 to suppress any labelling of vertices, 1 (default) to show the generator index or 2 to give full details on generators.
2) The optional parameter 'EdgeLabelSwitch' can be set to 0 to suppress any labelling and orientation of edges or 1 (default) to show both. Note that the edges are dashed iff they correspond to differentials along powers of q; this agrees with the conventions in [Zib17].
3) The optional parameter 'pos' is an integer by default, in which case all generators are shown; alternatively, 'pos' can be a list of indices of generators in 'gens', in which case only the full subgraph spanned by these generators is shown. 
4) Finally, the optional parameter 'CoordList' can be set to a list of coordinates for all vertices of the displayed graph. If no such coordinate list is specified, 'SpringElectricalEmbedding' is chosen as the preferred style.";
ShowGraph[maps_,gens_,VertexLabelSwitch_:1,EdgeLabelSwitch_:1,pos_:0,CoordList_:Automatic,precomputedgradings_:0]:=
If[Length[maps]!=Length[gens],Print["USER ERROR: Generator set cannot belong to the structure maps!"],ShowGraph0[maps,gens,VertexLabelSwitch,EdgeLabelSwitch,pos,CoordList,precomputedgradings]];

(* DotGrid output *)
LDot[indexSiteAndGrading_,alexstart_:3]:=Module[{alexStart,graphicswidth},
alexStart=Min[alexstart,Length[indexSiteAndGrading]-2](* alexstart cannot be larger than the number of colours, but we should allow it to be NC+1, so no alexgradings are displayed *);
graphicswidth=32+22(Length[indexSiteAndGrading]-2-alexStart)(* 32 for \[Delta] plus 22 for each displayed Alexgrading *);
Graphics[{indexSiteAndGrading[[2]]/.{"a"->Red,"b"->Blue,"c"->Green,"d"->Yellow},Disk[{0,0},22],Black,Inset[indexSiteAndGrading[[1]],{0,0},Background->indexSiteAndGrading[[2]]/.{"a"->Red,"b"->Blue,"c"->Green,"d"->Yellow}],Black,Text[DeltaAndAlexgradingOutputForm[indexSiteAndGrading[[3;;]],alexStart],{0,50}],Transparent,Disk[{0,10},{graphicswidth,10}]},ImageSize->graphicswidth]
];
LDots[indexSiteAndGradinglist_,alexStart_:3,multiplicity_:0]:=If[ListQ[indexSiteAndGradinglist],If[multiplicity===1,Times@@(LDot[#,alexStart]&/@(Prepend[#[[1]],#[[2]]]&/@Normal[CountsBy[indexSiteAndGradinglist,#[[2;;]]&]])),Times@@(LDot[#,alexStart]&/@indexSiteAndGradinglist)],indexSiteAndGradinglist];
DotGrid::usage="DotGrid[gens_,subset_:0,alexstart_:3] displays the generators and their gradings; the first two Alexander gradings (usually those for the two open strands) are shown graphically in terms of their position in a grid: \!\(\*SubscriptBox[\(t\), \(1\)]\) increases from top to bottom in steps of 1/2, \!\(\*SubscriptBox[\(t\), \(2\)]\) increases from left to right in steps of 1/2. The generators are shown as dots whose colour corresponds to the four sites of the tangle. The index of the generator is shown in the dot. A label above the generator shows the \[Delta]-grading along with any other Alexander gradings. DotGrid takes three optional parameters: 
1) The first can be used to display only a subset of generators, by specifying a list of corresponding generator indices. 
2) The second parameter can be used to vary the number of Alexander gradings. Usual values are 
  a) 0 (show no Alexander gradings), 
  b) 1 (show all Alexander gradings), 
  c) 3 (default: show all Alexander gradings except the first two), 
  d) -1 (collapse all Alexander gradings),
  e) a list of \[PlusMinus]1s as in 'CollapseAlexGradings' to reverse some orientations before collapsing.
3) The third parameter can be used to show generators in the same gradings as distinct dots labelled by their indices (0: default), or as single dots with multiplicities without any indices (1).";
DotGrid[gens_,subset_:0,alexstart_:3,multiplicity_:0,precomputedgradings_:0]:=Module[
{
t1min,
t1max,
t2min,
t2max,
GridRules,
GridTable,
subgens=If[IntegerQ[subset],Range[Length[gens]],subset],
gradings,
alexStart
},
gradings=If[precomputedgradings===0,If[alexstart===-1,CollapseAlexGradings/@AllGradingsIdemsAndIndices[gens],If[Head[alexstart]===List,CollapseAlexGradings[#,alexstart]&/@AllGradingsIdemsAndIndices[gens],AllGradingsIdemsAndIndices[gens]]],precomputedgradings];
alexStart=If[MemberQ[{-1,0},alexstart]||Head[alexstart]===List,Length[gradings[[1]]],alexstart];
t1min=Min[gradings[[All,4]]];
t1max=Max[gradings[[All,4]]];
t2min=If[Length[#[[1]]]>=5,Min[#[[All,5]]],0]&@gradings;
t2max=If[Length[#[[1]]]>=5,Max[#[[All,5]]],0]&@gradings;
GridRules=\!\(\*
TagBox[GridBox[{
{"\[Piecewise]", GridBox[{
{
RowBox[{"Join", "[", 
RowBox[{
RowBox[{"GroupBy", "[", 
RowBox[{
RowBox[{"gradings", "[", 
RowBox[{"[", "subgens", "]"}], "]"}], ",", 
RowBox[{
RowBox[{"If", "[", 
RowBox[{
RowBox[{
RowBox[{"Length", "[", "#", "]"}], ">=", "5"}], ",", 
RowBox[{"ToString", "[", 
RowBox[{"{", 
RowBox[{
RowBox[{"2", 
RowBox[{"#", "[", 
RowBox[{"[", "4", "]"}], "]"}]}], ",", 
RowBox[{"2", 
RowBox[{"#", "[", 
RowBox[{"[", "5", "]"}], "]"}]}]}], "}"}], "]"}], ",", 
RowBox[{"ToString", "[", 
RowBox[{"{", 
RowBox[{
RowBox[{"#", "[", 
RowBox[{"[", "4", "]"}], "]"}], ",", "0"}], "}"}], "]"}]}], "]"}], "&"}]}], "]"}], ",", 
RowBox[{"Association", "[", 
RowBox[{
RowBox[{"\"\<{\>\"", "<>", 
RowBox[{"ToString", "[", "0", "]"}], "<>", "\"\<, \>\"", "<>", 
RowBox[{"ToString", "[", 
RowBox[{
RowBox[{"2", "t2max"}], "+", "1"}], "]"}], "<>", "\"\<}\>\""}], "->", "\"\<\[Rule]t\>\""}], " ", "]"}]}], "]"}], 
RowBox[{
RowBox[{"alexstart", "===", 
RowBox[{"-", "1"}]}], "||", 
RowBox[{
RowBox[{"Head", "[", "alexstart", "]"}], "===", "List"}]}]},
{
RowBox[{"Join", "[", 
RowBox[{
RowBox[{"GroupBy", "[", 
RowBox[{
RowBox[{"gradings", "[", 
RowBox[{"[", "subgens", "]"}], "]"}], ",", 
RowBox[{
RowBox[{"If", "[", 
RowBox[{
RowBox[{
RowBox[{"Length", "[", "#", "]"}], ">=", "5"}], ",", 
RowBox[{"ToString", "[", 
RowBox[{"{", 
RowBox[{
RowBox[{"2", 
RowBox[{"#", "[", 
RowBox[{"[", "4", "]"}], "]"}]}], ",", 
RowBox[{"2", 
RowBox[{"#", "[", 
RowBox[{"[", "5", "]"}], "]"}]}]}], "}"}], "]"}], ",", 
RowBox[{"ToString", "[", 
RowBox[{"{", 
RowBox[{
RowBox[{"#", "[", 
RowBox[{"[", "4", "]"}], "]"}], ",", "0"}], "}"}], "]"}]}], "]"}], "&"}]}], "]"}], ",", 
RowBox[{"Association", "[", 
RowBox[{
RowBox[{"\"\<{\>\"", "<>", 
RowBox[{"ToString", "[", "0", "]"}], "<>", "\"\<, \>\"", "<>", 
RowBox[{"ToString", "[", 
RowBox[{
RowBox[{"2", "t2max"}], "+", "1"}], "]"}], "<>", "\"\<}\>\""}], "->", "\"\<\[Rule]\\!\\(\\*SubscriptBox[\\(t\\), \\(2\\)]\\)\>\""}], " ", "]"}], ",", 
RowBox[{"Association", "[", 
RowBox[{
RowBox[{"\"\<{\>\"", "<>", 
RowBox[{"ToString", "[", 
RowBox[{
RowBox[{"2", "t1max"}], "+", "1"}], "]"}], "<>", "\"\<, \>\"", "<>", 
RowBox[{"ToString", "[", "0", "]"}], "<>", "\"\<}\>\""}], "->", "\"\<\\!\\(\\*OverscriptBox[SubscriptBox[\\(t\\), \\(1\\)], \\(\[DownArrow]\\)]\\)\>\""}], " ", "]"}]}], "]"}], "True"}
},
AllowedDimensions->{2, Automatic},
Editable->True,
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.84]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
Selectable->True]}
},
GridBoxAlignment->{"Columns" -> {{Left}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxItemSize->{"Columns" -> {{Automatic}}, "ColumnsIndexed" -> {}, "Rows" -> {{1.}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.35]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}],
"Piecewise",
DeleteWithContents->True,
Editable->False,
SelectWithContents->True,
Selectable->False]\);

(*Note: Alexander gradings could be half-integer due to symmetrisation, but the grid table should be whole integers. *)
GridTable=Table[Table[Lookup[GridRules,ToString[{i,ii}]," "],{ii,2t2min,2t2max+1}],{i,2t1min,If[alexstart===-1||Head[alexstart]===List,2t1max,2t1max+1]}];
Grid[Map[LDots[#,alexStart,multiplicity]&,GridTable,{2}],{Frame->All,FrameStyle->Directive[Thickness[0.1],AbsoluteDashing[{100,0.01}],Gray],Background->{{2t2max+1->LightGray},{-2t1min+1->LightGray},{-2t1min+1,2t2max+1}->Gray }}]];

(* Combined final output *)
SplitByComponents[maps_,subset_:0]:=DeleteCases[If[IntegerQ[subset],#,If[IntersectingQ[#,subset]&&IntersectingQ[Complement[Range[Length[maps]],subset],#],Print["Warning! SplitByComponents is splitting connected components!"]];Intersection[#,subset]]&/@ConnectedComponents[AdjacencyGraph[Map[If[#=!=0,1,0]&,maps,{2}],DirectedEdges->False]],{}];
ShowResult::usage="ShowResult[maps_,gens_,switch_:'all'] displays the generators arranged as in 'DotGrid' for each supported Alexander grading corresponding to the colours of closed components along with the complex, sorted into connected components. The complex can be suppressed by setting the third optional parameter to 'gens'.";
ShowResult[maps_,gens_,switch_:"all"]:=Module[{SplitByRemainingAlexGradings,AllGradingsIdemsAndIndices=AllGradingsIdemsAndIndices[gens],SplitByRemainingAlexGradingsAux},
If[MemberQ[{"all","gens"},switch]===False,Print["The optional parameter of 'ShowResult' should be equal to the string 'all' (default) or 'gens'."]Abort[]];
SplitByRemainingAlexGradingsAux[generatorindex_]:=If[Length[#]>5,#[[6;;]],0]&@AllGradingsIdemsAndIndices[[generatorindex]];SplitByRemainingAlexGradings=SortBy[Normal[GroupBy[Range[Length[gens]],SplitByRemainingAlexGradingsAux]],#[[1]]&];
Print[TableForm[{{
If[#[[1]]===0,"",AlexgradingsOutputForm[Join[{0,0},#[[1]]],3]],
DotGrid[gens,#[[2]],0,0,AllGradingsIdemsAndIndices],
If[switch==="all",Times@@(Function[component,ShowGraph[maps,gens,1,0,component,Automatic,AllGradingsIdemsAndIndices]]/@SplitByComponents[maps,#[[2]]]),""]
}}]]&/@SplitByRemainingAlexGradings;
];


];


HomotopyPreparation:=Module[{},
(* Check d^2-relations *)
DSquared[maps_]:=PolynomialMod[(maps.maps),2]/.AlgebraRelations;
DSquared0Q[maps_]:=Length[DeleteCases[Flatten[DSquared[maps]],0]]===0;
DSquared0Q::usage="DSquared0Q[maps_] verifies if the differential 'maps' satisfies the (\!\(\*SuperscriptBox[\(d\), \(2\)]\)=0)-relation.";
(* Definition of Matrix after applying a homotopy.
input is a label and endgenindex and startgenindex *)
(* Matrix of contribution of precompositions of structure map with homotopy *)
PreComposeMatrix[MatrixInput_,homotopy_,start_,end_]:=ArrayPad[Transpose[{Function[{c},homotopy*c]/@MatrixInput[[All,end]]}],{{0},{start-1,Length[MatrixInput]-start}}];
(* Matrix of contribution of postcompositions of structure map with homotopy *)
PostComposeMatrix[MatrixInput_,homotopy_,start_,end_]:=ArrayPad[{Function[{c},homotopy*c]/@MatrixInput[[start,All]]},{{end-1,Length[MatrixInput]-end},{0}}];
(* Matrix of contribution of pre- and postcompositions of structure map with homotopy *)
PreAndPostComposeMatrix[MatrixInput_,homotopy_,start_,end_]:=PostComposeMatrix[MatrixInput,homotopy,start,end]+PreComposeMatrix[MatrixInput,homotopy,start,end];
(* Homotopy without security checks *)
Homotopy[StructureMaps_,homotopy_,start_,end_]:=PolynomialMod[StructureMaps+PreAndPostComposeMatrix[StructureMaps,homotopy,start,end],2]/.AlgebraRelations;
Homotopy::usage="Homotopy[StructureMaps,homotopy,start,end] computes the new StuctureMaps obtained by applying a homotopy to StructureMaps going from generator with index 'start' to generator with index 'end'.";
(*Careful Homotopy; before we apply the homotopy, we first check it the conditions are satisfied, ie start=!=end (could relax to homotopy^2=0) and homotopy*differential*homotopy=0 *)
CarefulHomotopy[StructureMaps_,homotopy_,start_,end_]:=If[start==end, StructureMaps,If[(homotopy*StructureMaps[[start,end]]*homotopy/.AlgebraRelations)===0,Homotopy[StructureMaps,homotopy,start,end],StructureMaps]];
(* homotope away all arrows not labelled by 'variable'; this only works if the differential between startgen and endgen is shortest among all arrows ending ans starting at startgen and endgen *)
SeparateDifferential[differentials_,pos_,variable_]:=Module[
{differentialsit=differentials,
length,
othergens,
homotopyLabels,
startgen=pos[[2]],
endgen=pos[[1]]
},
length=Exponent[differentialsit[[endgen,startgen]],variable];
If[length<1,Print["ERROR: CleanUpGen cannot clean up this position, there is no power of ",variable," at this position!"];Abort[]];
othergens=DeleteCases[Flatten[Position[differentialsit[[All,startgen]],_?(Exponent[#,variable]>0&),1]],endgen];
homotopyLabels=variable^(Exponent[differentialsit[[#,startgen]],variable]-length)&/@othergens;
differentialsit=Fold[CarefulHomotopy[#1,#2[[1]],endgen,#2[[2]]]&][differentialsit,Transpose[{homotopyLabels,othergens}]];
othergens=DeleteCases[Flatten[Position[differentialsit[[endgen,All]],_?(Exponent[#,variable]>0&),1]],startgen];
homotopyLabels=variable^(Exponent[differentialsit[[endgen,#]],variable]-length)&/@othergens;
differentialsit=Fold[CarefulHomotopy[#1,#2[[1]],#2[[2]],startgen]&][differentialsit,Transpose[{homotopyLabels,othergens}]];
differentialsit
];
SeparateAllDifferentials[differentials_,variable_]:=Module[
{differentialsit=differentials,
cleanedPosn={},
remainingPosn,
remainingMinimalPosn,
currentpos
},
While[True,
remainingPosn=Complement[Position[differentialsit,_?(Exponent[#,variable]>0&),{2},Heads->False],cleanedPosn];
remainingMinimalPosn=MinimalBy[remainingPosn,Function[int,If[int<=0,\[Infinity],int]]@Exponent[differentialsit[[#[[1]],#[[2]]]],variable]&];
currentpos=If[Length[#]==0,0,RandomChoice[#]]&@remainingMinimalPosn ;
cleanedPosn=Append[cleanedPosn,currentpos];
If[currentpos==0,Break[]];(* otherwise continue *)
differentialsit=SeparateDifferential[differentialsit,currentpos,variable];
];
differentialsit
];
SeparateAllDifferentials::usage="SeparateAllDifferentials[differentials_,variable_] simplifies the complex defined by 'differentials' with respect to the variable 'variable' by a sequence of homotopies. The output is again a complex in which every vertex is 1-valent with respect to the variable 'variable'.";
CheckIfLoopType[differential_]:=Length[DeleteCases[Total[Transpose[#]+#]&@(differential/.{p->1,q->0}),1]]+Length[DeleteCases[Total[Transpose[#]+#]&@(differential/.{p->0,q->1}),1]]===0;
CheckIfLoopType::usage="CheckIfLoopType[differential_] verifies if the peculiar module defined by 'differential' is loop-type in the sense that every vertex is 2-valent";
SimplifyPQM[differentials_,MaxIterations_:200]:=Module[
{
differentialsit=differentials,
iter
},
Monitor[
For[iter=0,iter<MaxIterations,iter++,
differentialsit=SeparateAllDifferentials[differentialsit,{p,q}[[Mod[iter,2,1]]]];
If[CheckIfLoopType[differentialsit],iter=iter+1;Break[]];
];,"Iteration: "<>ToString[iter]];
Print["Finished calculation after ",iter," iterations. ",If[CheckIfLoopType[differentialsit],"The peculiar module is loop-type.","The peculiar module is not in loop-type form."]];
differentialsit
];
SimplifyPQM::usage="SimplifyPQM[maps_,MaxIterations_:200] performs a sequence of homotopies by alternatingly simplifying the complex with respect to the variables p and q, using the function 'SeparateAllDifferentials'. The iteration terminates either if the complex becomes loop-type (see: 'CheckIfLoopType'), or after 'MaxIterations' iterations. Since a pseudo-random function is invoked by 'SeparateAllDifferentials', the number of iterations to put a complex in loop-type position might vary, as well as the output, if the complex is not in loop-type position.";









(* obsolete code for homotopies - everything which follows can be deleted *)
xfactor=10;
xfactor::usage="Set 'xfactor' equal to a real number between 1 and \[Infinity]. This value determines the complexity of the structure maps; 1 means all morphisms count the same; if it is higher, long sequences of algebra elements contribute less towards the complexity of the structure maps.";
(* PosToBeCleaned is a list of all positions in StructureMaps that we want to clean up, ie homotope to 0 *)
MyLength[v_]:=Exponent[v,p]+Exponent[v,q];
PosToBeCleaned[GenIndexPartitioning_]:=
Flatten[Tuples[{GenIndexPartitioning[[#[[1]]]],GenIndexPartitioning[[#[[2]]]]}]&/@Complement[Tuples[{Range[Length[GenIndexPartitioning]],Range[Length[GenIndexPartitioning]]}],{#,#}&/@Range[Length[GenIndexPartitioning]]],1];
Complexity0[StructureMaps_,PosToBeCleaned0_]:=Module[{
PosToBeCleaned=If[
IntegerQ[PosToBeCleaned0],
Tuples[{Range[Length[StructureMaps]],Range[Length[StructureMaps]]}],
PosToBeCleaned0
]
},
Plus@@(0.1^MyLength[#]&/@DeleteCases[Apply[StructureMaps[[##]]&,PosToBeCleaned,1],0])
];
Complexity[StructureMaps_,PosToBeCleaned_:0]:=Complexity0[StructureMaps,PosToBeCleaned];

(* Definition of Matrix after applying a homotopy.
input is a label and endgenindex and startgenindex *)
(* The condition we check here is slightly stronger than necessary, but quicker. *)
(* start\[NotEqual]end ensures that h^2 vanishes. Also, hD(h) and D(h)h need to vanish. Together with start\[NotEqual]end, StructureMaps[[start,end]]===0 is both necessary and sufficient. *)
CheckIfHomotopyIsAllowed[StructureMaps_,homotopy_,start_,end_]:=If[start!=end&&StructureMaps[[start,end]]===0,{homotopy,start,end},0];

(* Homotopy without security checks *)
OldHomotopy0[StructureMaps_,homotopy_,start_,end_]:=PolynomialMod[StructureMaps+PreAndPostComposeMatrix[StructureMaps,homotopy,start,end],2]/.AlgebraRelations;

(* SplitAlg gives a list of splittings, ie an entry is a pair of algebra elements whose arrow composition is alg *)
SplitAlg[poly_]:=If[poly===0,{},If[#[[1]]===0,Table[{q^i,q^(#[[2]]-i)},{i,0,#[[2]]}],Table[{p^i,p^(#[[1]]-i)},{i,0,#[[1]]}]]&@{Exponent[poly,p],Exponent[poly,q]}];
(* Homotopy with security checks; 
0. Check if genset  has same length as StructureMaps
1. Check if conditions for homotopy are satisfied
2. we do not want to use homotopies with wrong idempotents *)
OldHomotopy[StructureMaps_,genset_,homotopy_,start_,end_]:=
If[Length[StructureMaps]!=Length[genset],Print["USER ERROR: Generator set cannot belong to the structure maps!"],
If[IntegerQ[CheckIfHomotopyIsAllowed[StructureMaps,homotopy,start,end]],
Print["USER ERROR: the conditions for adding a homotopy are not satisfied."],
OldHomotopy0[StructureMaps,homotopy,start,end],Print["USER ERROR: You are trying to use a homotopy with the wrong idempotents. Try again."]]];
OldHomotopy::usage="Homotopy[StructureMaps,genset,homotopy,start,end] computes the new StuctureMaps obtained by applying a homotopy (=algebra element) to StructureMaps going from generator with index 'start' to generator with index 'end' in the underlying set of generators specified by 'genset'.";
(* Need to find homotopies such that a given label at position pos in MatrixInput is killed from precomposition with this homotopy. pos is a list of the form {endcoord,startcoor,position of algebra element in labelling of this arrow}.
Output is a list of pairs of the form {endgenindex of homotopy,index of splitting to be used for this homotopy} *)
AllHomotopiesForPreComp0[MatrixInput_,pos_]:=Flatten[Apply[Tuples[{{#1},{pos[[2]]},Position[MatrixInput[[pos[[1]]]],#2,{1}][[All,1]]}]&,SplitAlg[Part[MatrixInput,##]&@@pos],{1}],1];
AllHomotopiesForPreComp[MatrixInput_,pos_]:=CheckIfHomotopyIsAllowedList[MatrixInput,AllHomotopiesForPreComp0[MatrixInput,pos]];
(* same for postcompositions.
Output is a list of pairs of the form {algebra element, startgenindex of homotopy,endgenindex of homotopy} *)
CheckIfHomotopyIsAllowedList[MatrixInput_,list_]:=DeleteCases[Apply[CheckIfHomotopyIsAllowed[MatrixInput,##]&,list,1],0];
AllHomotopiesForPostComp0[MatrixInput_,pos_]:=Flatten[Apply[Tuples[{{#2},Position[MatrixInput[[All,pos[[2]]]],#1,{1}][[All,1]],{pos[[1]]}}]&,SplitAlg[Part[MatrixInput,##]&@@pos],{1}],1];
AllHomotopiesForPostComp[MatrixInput_,pos_]:=
CheckIfHomotopyIsAllowedList[MatrixInput,AllHomotopiesForPostComp0[MatrixInput,pos]];
AllHomotopies[MatrixInput_,pos_]:=Join[
AllHomotopiesForPreComp[MatrixInput,pos],
AllHomotopiesForPostComp[MatrixInput,pos]];
AllHomotopies::usage="AllHomotopies[MatrixInput_,pos_] computes a list of all homotopies that can remove an arrow label specified by 'pos' in the Structure Maps 'MatrixInput'. A homotopy is a list {algebra element, startgenindex of homotopy, endgenindex of homotopy}.";

(* Could speed this up by parallelising, but if we need to check lots of them, ParallelTry should be faster *)
AllComplexities0[StructureMaps_,pos_,PosToBeCleaned_]:=
Apply[Complexity[Homotopy0[StructureMaps,##],PosToBeCleaned]&,
AllHomotopies[StructureMaps,pos]
,{1}];
AllComplexities[StructureMaps_,pos_,PosToBeCleaned_:0]:=AllComplexities0[StructureMaps,pos,PosToBeCleaned];
(* Could speed this up by parallelising, but if we need to check lots of them, ParallelTry should be faster *)
AllComplexities::usage="[StructureMaps_,pos_,PosToBeCleaned_] is a list of the complexities for the possible homotopies killing an alegbra element at position 'pos' in 'Structuremaps', in teh order of 'AllHomotopies'. As for the fucntion 'Complexity', PosToBeCleaned is an optional argument whose default is 0.";
ComplexityAlmostDecreasingQ[StructureMaps_,pos_,CurrentComplexity_,PosToBeCleaned_,almostvar_]:=
Min[AllComplexities[StructureMaps,pos,PosToBeCleaned]]<(1+almostvar/100)*CurrentComplexity;
ComplexityDecreasingQ[StructureMaps_,pos_,CurrentComplexity_,PosToBeCleaned_:0,almostvar_:0]:=ComplexityAlmostDecreasingQ[StructureMaps,pos,CurrentComplexity,PosToBeCleaned,almostvar];
ComplexityDecreasingQ::usage="ComplexityDecreasing[StructureMaps_,pos_,CurrentComplexity_,PosToBeCleaned_] determines if there is a homotopy which removes the algebra element at position 'pos' in 'StructureMaps' and decreases the complexity of 'StructureMaps'. PosToBeCleaned is an optional argument as in the function 'Complexity'";

OldSimplifyPQM::usage="SimplifyPQM[StructureMaps_,gensets_,PosToBeCleaned_,MaxIterations_] tries to find a complex homotopic to the input complex which is the direct sum of some subcomplexes whose underlying sets of generators are give by 'PosToBeCleaned', a list of positions to be cleaned, usually generated by PosToBeCleaned. Output is of the form {NewStructureMaps,LOG=Record of added homotopies}";
OldSimplifyPQM[StructureMaps_,gensets_,PosnToBeCleaned_,MaxIterations_]:=Module[{
Output={{},{}},
NGens=Length[gensets],
CurrentComplexity=Complexity[StructureMaps,PosnToBeCleaned],
StructureMapsit=StructureMaps,
iter=0,
pos,(* this is the position we want to clean up in an iteration *)
homotopyStartEnd={},
PosToBeCleaned=Complement[Tuples[{Range[Length[gensets]],Range[Length[gensets]]}],Position[StructureMaps,0]],
start=1,
end=1,
LOG={},
NRandomPicks=0,
cycliccounter=0,
timeused=0,
almostvar=1,
NRandomInd=0,
maxTally=0
},
(* First check if the input is sensible *)
Print[Now];
Monitor[
If[
Length[StructureMaps]!=NGens,Print["USER ERROR: Something is wrong about the generatorsets!"],
(* Calculate list of positions {endgen,startgen,position in label} *)
(* Main iteration *)
While[iter<MaxIterations,
NRandomInd=0;
(* Pick an element in PosOfArrowsToBeRemoved, ie a position of an algebra element that we want to homotope away. We first search for one where there exists a homotopy which decreases the complexity of 'StructureMapsit'. *)
CurrentComplexity=Complexity[StructureMapsit,PosnToBeCleaned];
(*pos=SelectFirst[PosToBeCleaned,Length[AllHomotopies[StructureMapsit,#]]>0&,0];*)
pos=SelectFirst[PosToBeCleaned,ComplexityDecreasingQ[StructureMapsit,#,CurrentComplexity,PosnToBeCleaned]&,0];
(* If we still have not found a homotopy, we look for one elsewhere that decreases overall complexity *)
If[pos===0,
pos=SelectFirst[PosToBeCleaned,ComplexityDecreasingQ[StructureMapsit,#,CurrentComplexity]&,0];
];
(* If we still have not found a homotopy and we have not repeated the same homotopies too many times, we look for that almost decreases complexity in PosToBeCleaned *)
almostvar=1;
While[pos===0&&almostvar<100&&maxTally<6,
pos=SelectFirst[PosToBeCleaned,ComplexityAlmostDecreasingQ[StructureMapsit,#,CurrentComplexity,PosnToBeCleaned,almostvar]&,0];
almostvar=almostvar+1;
NRandomInd=NRandomInd+1;
];
If[NRandomInd=!=0,NRandomPicks=NRandomPicks+1];
(* If we do not find one that decreases complexity, we 
1) abort
2)pick a random algebra element to be removed; but make sure that it is actually removable ie that there exists a homotopy.  *)
If[pos===0,
(*1*)
Print["Aborted after iteration "<>ToString[iter]];
iter=MaxIterations;
pos=0
(*2*)
(*
PosOfArrowsToBeRemoved=Select[PosOfArrowsToBeRemoved,Length[AllHomotopies[StructureMapsit,#]]>0&];
If[Length[PosOfArrowsToBeRemoved]\[Equal]0,
pos=0;
(* we exit while-loop *)
iter=MaxIterations,
pos=RandomChoice[PosOfArrowsToBeRemoved];
NRandomPicks=NRandomPicks+1
]*)
];
If[
(* If we could not choose any arrow to homotope away (ie p=0; this should rarely happen), then leave out this loop and we exit while-loop. *)
pos=!=0,
cycliccounter=cycliccounter+Position[PosToBeCleaned,pos][[1,1]];
(* Select the homotopy with lowest complexity. *)
homotopyStartEnd=AllHomotopies[StructureMapsit,pos][[Position[#,Min[#]][[1,1]]]]&@AllComplexities[StructureMapsit,pos,PosToBeCleaned];
(* Add the homotopy *)
StructureMapsit=Homotopy0[StructureMapsit,##]&@@homotopyStartEnd;
(* Record what we have just done *)
LOG=Append[LOG,homotopyStartEnd];
(* Compute the new list of arrows which go between different generator sets *)
PosToBeCleaned=RotateLeft[PosToBeCleaned=Complement[Tuples[{Range[Length[gensets]],Range[Length[gensets]]}],Position[StructureMapsit,0]],cycliccounter];
(* Compute maximum number of identical homotopies *)
maxTally=Max[Tally[LOG][[All,2]]];
(* Check if we need to repeat. *)
If[Length[PosToBeCleaned]==0,
iter=MaxIterations;
Print["Success! All Cleaned Up. Could I have some ice cream?"],
(* otherwise increment iter *)
iter=iter+1
];
]
]
],{{"Iteration "<>ToString[iter+1]},{"---------------"},{"Remaining Positions"},{"Complexity"},{N[Complexity[StructureMapsit,PosToBeCleaned]]},{"Number of random picks"},{NRandomPicks}}//MatrixForm
];
Print["I increased complexity ",NRandomPicks," times." ];
Print[Now];
Output={StructureMapsit,LOG}
];

];


PQMFormats:=Module[{},
SitesToAlgebraP[sitepair_]:=Power[p,({
 {\[Placeholder], 1, 2, 3},
 {3, \[Placeholder], 1, 2},
 {2, 3, \[Placeholder], 1},
 {1, 2, 3, \[Placeholder]}
})[[#[[2]],#[[1]]]]]&@(sitepair/.{"a"->1,"b"->2,"c"->3,"d"->4});
SitesToAlgebraQ[sitepair_]:=Power[q,({
 {\[Placeholder], 3, 2, 1},
 {1, \[Placeholder], 3, 2},
 {2, 1, \[Placeholder], 3},
 {3, 2, 1, \[Placeholder]}
})[[#[[2]],#[[1]]]]]&@(sitepair/.{"a"->1,"b"->2,"c"->3,"d"->4});
LoopToPQM[loop_]:=Module[
{output,
generators=MapIndexed[Join[#2,#1]&,loop],
differentials,
rulesForP,
rulesForQ
},
If[OddQ[Length[loop]],Print["Error: The input has an odd number of generators; this cannot be a loop!",Abort[]]];
rulesForP=Join[MapIndexed[{2#2[[1]],2#2[[1]]-1}->SitesToAlgebraP[#1[[All,1]]]&,Partition[loop ,2]],MapIndexed[{2#2[[1]]-1,2#2[[1]]}->SitesToAlgebraP[Reverse[#1[[All,1]]]]&,Partition[loop ,2]]];
rulesForQ=Join[MapIndexed[{Mod[2#2[[1]]+1,Length[loop],1],2#2[[1]]}->SitesToAlgebraQ[#1[[All,1]]]&,Partition[RotateLeft[loop,1] ,2]],MapIndexed[{2#2[[1]],Mod[2#2[[1]]+1,Length[loop],1]}->SitesToAlgebraQ[Reverse[#1[[All,1]]]]&,Partition[RotateLeft[loop,1] ,2]]];
differentials=Normal[SparseArray[rulesForP,{Length[loop],Length[loop]},0]+SparseArray[rulesForQ,{Length[loop],Length[loop]},0]];
output={differentials,generators}
];
(* PQM to loops *)
FindNext[list_,current_]:=FirstCase[list,_?(#[[1]]===current[[2]]&),0];
FindLoops[list_]:=Module[
{current,
currentlist=list,
loop,
loops={}
},
While[Length[currentlist]>0,
current=currentlist[[1]];
currentlist=Drop[currentlist,2];
loop={current};
While[True,
current=FindNext[currentlist,current];
If[IntegerQ[current],Break[]];
currentlist=DeleteCases[currentlist,current|Reverse[current]];
loop=Append[loop,current];
];
loops=Append[loops,loop];
];
loops
];
PQMToLoops[differential_,generators_]:=Module[
{output,
pairs=Join[Position[differential/.{p->1,q->0},1],Position[differential/.{p->0,q->1},1]]
},
If[CheckIfLoopType[differential]===False,Print["Error: The input is not loop-type!";Abort[]]];
output=Drop[generators[[#]]&/@FindLoops[pairs][[All,All,1]],None,None,1]
];
(* loop to stringloop and back again *)
LoopToStringLoop[loop_]:=StringJoin[".",Riffle[loop[[All,1]],".",3],"."];
StringLoopToLoop[stringloop_]:={#,0,0}&/@StringPartition[StringReplace[stringloop,"."->""],1];
StringLoopToPQMRaw[stringloop_]:=LoopToPQM[StringLoopToLoop[stringloop]];
StringLoopToPQM[stringloop_]:=(#[[1]]+ToExpression[DiagonalMatrix[#[[2,All,2]]]])&@StringLoopToPQMRaw[stringloop];
ShowGraphFromStringLoops[stringloops__]:=TableForm[Transpose[Function[{stringloop},{ShowGraph[#1,#2,0,0,0]&@@LoopToPQM[StringLoopToLoop[stringloop]]}]/@{stringloops}]];



];
