FusionAtlasPaths={"~/projects/fusionatlas/code/package/"};
$Path=$Path~Join~FusionAtlasPaths;
<<FusionAtlas`

{g[0],g[1]}={GradedBigraph[{{1}},{{1}},{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{0,1}},{{1,1},{1,0},{0,1}},{{0,0,1}},{{1}},{{1}},{{1}}],GradedBigraph[{{1}},{{1}},{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{1,0}},{{1,0},{1,0},{0,1},{0,1}},{{0,0,0,1}},{{1}},{{1}},{{1}}]};

DisplayBigraph[g[0]]

g=EvenPart[g[0]]

Clear[Z]

g=EvenPart[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{0,1}},{{1,1}}]];

d=ReducedDimensionsByDepth[g];
Z[1,a_,b_]:=If[a==b,1,0];
Z[a_,1,b_]:=If[a==b,1,0];
fV[g0_,k0_]:=Module[{k=k0,depth=0},
While[k>RankAtDepth[g0,depth],k-=RankAtDepth[g0,depth++]];
V[depth,k]
];
Z[a_,2,b_]:=Module[{Va,Vb},
Va=fV[g,a];
Vb=fV[g,b];
Switch[Vb[[1]]-Va[[1]],
1,g[[2,Va[[1]]+1,Vb[[2]],Va[[2]]]],
0,g[[1,Va[[1]]+1,Vb[[2]],Va[[2]]]],
-1,g[[2,Va[[1]],Va[[2]],Vb[[2]]]],
_,0]
];
ZZ=Table[Z[a,b,c],{a,1,GraphRank[g]},{b,1,GraphRank[g]},{c,1,GraphRank[g]}];
eq=DeleteCases[Union[#==0&/@Flatten[ZZ.ZZ-Transpose[Transpose[ZZ,{1,3,2}].Transpose[ZZ,{2,3,1}],{1,4,2,3}]]],True];

{g[0],g[1]}={BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1},{1}},{{1,0,0},{0,0,1}},{{1,0},{0,1}}],DualData[{1},{1},{3,2,1},{2,1}]],BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1},{1}},{{1,0,0},{0,0,1}},{{1,0},{0,1}}],DualData[{1},{1},{3,2,1},{2,1}]]};

DisplayBigraph[{g[0],g[1]}]

{g[0],g[1]}={Translate[HaagerupWithDuals,8],Translate[DualHaagerupWithDuals,8]};

Clear[Z,ZZ,Assoc,eq]

SimplifyingEquations=False;

Z[{L_,R_,d1_,k1_},{R_,R_,0,1},{L_,R_,d2_,k2_}]:=If[d1==d2∧k1==k2,1,0]
Z[{L_,L_,0,1},{L_,R_,d1_,k1_},{L_,R_,d2_,k2_}]:=If[d1==d2∧k1==k2,1,0]

Z[{L_,R_,d1_,k1_},{R_,R2_,1,1},{L_,R2_,d2_,k2_}]/;R==1-R2:=
Switch[d2-d1,
1,g[L][[1,d1+1,k2,k1]],
-1,g[L][[1,d1,k1,k2]],
_,0]

ZZ[L_,M_,R_]:=ZZ[L,M,R]=Flatten[Table[Z[{L,M,d1,k1},{M,R,d2,k2},{L,R,d3,k3}],{d1,Mod[M+L,2],GraphDepth[g[L]],2},{k1,1,RankAtDepth[g[L],d1]},{d2,Mod[M+R,2],GraphDepth[g[M]],2},{k2,1,RankAtDepth[g[M],d2]},{d3,Mod[L+R,2],GraphDepth[g[L]],2},{k3,1,RankAtDepth[g[L],d3]}],{{1,2},{3,4},{5,6}}]

ZZZ=Table[ZZ[A,B,C],{A,0,1},{B,0,1},{C,0,1}];

Assoc[A_,B_,C_,D_]:=
DeleteCases[Union[#==0&/@Flatten[ZZ[A,B,C].ZZ[A,C,D]-Transpose[ZZ[B,C,D].Transpose[ZZ[A,B,D],{2,1,3}],{2,3,1,4}]]],True]

dual[{A_,A_,d_/;EvenQ[d],k_}]:={A,A,d,g[A][[2,d/2+1,k]]}
dual[{A_,B_,d_/;OddQ[d],k_}]:={B,A,d,k}

Duality[L_,M_,R_]:=Flatten[Table[Z[{L,M,d1,k1},{M,R,d2,k2},{L,R,d3,k3}]-Z[dual[{L,R,d3,k3}],{L,M,d1,k1},dual[{M,R,d2,k2}]]==0,{d1,Mod[M+L,2],GraphDepth[g[L]],2},{k1,1,RankAtDepth[g[L],d1]},{d2,Mod[M+R,2],GraphDepth[g[M]],2},{k2,1,RankAtDepth[g[M],d2]},{d3,Mod[L+R,2],GraphDepth[g[L]],2},{k3,1,RankAtDepth[g[L],d3]}],{{1,2},{3,4},{5,6}}]

eq=Flatten[Table[Assoc[A,B,C,D],{A,0,1},{B,0,1},{C,0,1},{D,0,1}]]~Join~Flatten[Table[Duality[A,B,C],{A,0,1},{B,0,1},{C,0,1}]];

SolvablePatterns={{1,_Z==0,SolveSolvableEquations},{1,-_Z==0,SolveSolvableEquations},{1,_Integer+_Z==0,SolveSolvableEquations},{1,_Integer-_Z==0,SolveSolvableEquations},{2,a_Z+b_Z==0,AllVariablesAreZero},{2,-a_Z-b_Z==0,AllVariablesAreZero},{2,a_Z-b_Z==0,SolveSolvableEquations},{∞,e_/;(SimplifyingEquations=True;Length[CoefficientArrays[e[[1]],Union[Cases[e,_Z,∞]]]]==2),SolveSolvableEquations}};

Echo[x_]:=(Print[x];x)

SolveSolvableEquations[F_]:=
Module[{solutions},
solutions=Solve[F,Union[Cases[F,_Z,∞]]];
If[solutions===True,Return[{}]];
If[Length[solutions]==1,
DebugPrint["solved for ",Length[solutions[[1]]], " variables."];
solutions[[1]]/.(a_->b_):>(a=b)
]
]

AllVariablesAreZero[eq_]:=Cases[eq,_Z,∞]/.a_Z:>(a=0)

SolveSomeSolvableEquations[eq_]:=Module[{equationsWithKVariables,targetEquations,i,numberOfVariables,pattern,solveMethod},
equationsWithKVariables[k_]:=equationsWithKVariables[k]=Cases[eq,e_/;Length[Union[Cases[e,_Z,∞]]]≤k];
For[i=1,i≤Length[SolvablePatterns],++i,
DebugPrint["Trying pattern ",i];
{numberOfVariables,pattern,solveMethod}=SolvablePatterns[[i]];
targetEquations=Cases[equationsWithKVariables[numberOfVariables],pattern];
solveMethod[targetEquations];
If[Length[targetEquations]>0,
Break[]
];
];
Length[targetEquations]
]

SolveAllSolvableEquations[eq0_]:=
Module[{eq=eq0},
While[(!MemberQ[eq,False])∧SolveSomeSolvableEquations[eq]>0,
If[SimplifyingEquations,eq=Collect[eq,_Z,Together]];
eq=DeleteCases[Union[eq],True]
];
DeleteCases[Union[eq],True]
]

eq=SolveAllSolvableEquations[eq]

eq

ZZZ

Union[DeleteCases[eq,True]]

ineq=#≥0&/@Union[DeleteCases[Flatten[ZZZ],_Integer]];

Reduce[eq~Join~ineq,variables,Integers]

Reduce[#≥0&/@Union[DeleteCases[Flatten[ZZZ],_Integer]],Integers]

%[[1]]

Length[%]

variables=Union[Cases[eq,_Z,∞]]

Union[Solve[eq,variables]]

mm=Union[DeleteCases[Flatten[ZZ],_Integer]]

nn=LCM@@Denominator[Together[mm]]

Solve[{nn mm==0,Modulus==8},variables,Mode->Modular]

g=EvenPart[haagerupFamilyBigraph[7]]

Clear[Z]

d=ReducedDimensionsByDepth[g];
Z[1,a_,b_]:=If[a==b,1,0];
Z[a_,1,b_]:=If[a==b,1,0];
fV[g0_,k0_]:=Module[{k=k0,depth=0},
While[k>RankAtDepth[g0,depth],k-=RankAtDepth[g0,depth++]];
V[depth,k]
];
Z[a_,2,b_]:=Module[{Va,Vb},
Va=fV[g,a];
Vb=fV[g,b];
Switch[Vb[[1]]-Va[[1]],
1,g[[2,Va[[1]]+1,Vb[[2]],Va[[2]]]],
0,g[[1,Va[[1]]+1,Vb[[2]],Va[[2]]]],
-1,g[[2,Va[[1]],Va[[2]],Vb[[2]]]],
_,0]
];
ZZ=Table[Z[a,b,c],{a,1,GraphRank[g]},{b,1,GraphRank[g]},{c,1,GraphRank[g]}];
eq=DeleteCases[Union[#==0&/@Flatten[ZZ.ZZ-Transpose[Transpose[ZZ,{1,3,2}].Transpose[ZZ,{2,3,1}],{1,4,2,3}]]],True];
deq=Union[DeleteCases[
Thread[Flatten[ZZ.Flatten[d]]==Flatten[Table[d[[fV[g,i][[1]]+1,fV[g,i][[2]]]]d[[fV[g,j][[1]]+1,fV[g,j][[2]]]],{i,1,GraphRank[g]},{j,1,GraphRank[g]}]]]
,True]];
deq2=Cases[ZZ,(z:Z[_,_,c_]/;Flatten[d][[c]]==1):>z≤1,∞];

eq

Length[eq]

eq=SolveAllSolvableEquations[eq]

variables=Union[Cases[eq,_Z,∞]]

linearEquations=Cases[eq,e_/;Length[CoefficientArrays[e[[1]],variables]]==2]

Solve[linearEquations,variables][[1]]/.(a_->b_):>(a=b)

eq=DeleteCases[Union[Expand[eq]],True]

mm=Union[DeleteCases[Flatten[ZZ],_Integer]]

eq/.Z[6,8,8]->0

Z[6,8,8]=1;

eq=DeleteCases[Union[Expand[eq]],True]

eq/.Z[8,8,6]->1

g=EvenPart[haagerupFamilyBigraph[11]]

Clear[Z]

d=ReducedDimensionsByDepth[g];
Z[1,a_,b_]:=If[a==b,1,0];
Z[a_,1,b_]:=If[a==b,1,0];
fV[g0_,k0_]:=Module[{k=k0,depth=0},
While[k>RankAtDepth[g0,depth],k-=RankAtDepth[g0,depth++]];
V[depth,k]
];
Z[a_,2,b_]:=Module[{Va,Vb},
Va=fV[g,a];
Vb=fV[g,b];
Switch[Vb[[1]]-Va[[1]],
1,g[[2,Va[[1]]+1,Vb[[2]],Va[[2]]]],
0,g[[1,Va[[1]]+1,Vb[[2]],Va[[2]]]],
-1,g[[2,Va[[1]],Va[[2]],Vb[[2]]]],
_,0]
];
ZZ=Table[Z[a,b,c],{a,1,GraphRank[g]},{b,1,GraphRank[g]},{c,1,GraphRank[g]}];
eq=DeleteCases[Union[#==0&/@Flatten[ZZ.ZZ-Transpose[Transpose[ZZ,{1,3,2}].Transpose[ZZ,{2,3,1}],{1,4,2,3}]]],True];
deq=Union[DeleteCases[
Thread[Flatten[ZZ.Flatten[d]]==Flatten[Table[d[[fV[g,i][[1]]+1,fV[g,i][[2]]]]d[[fV[g,j][[1]]+1,fV[g,j][[2]]]],{i,1,GraphRank[g]},{j,1,GraphRank[g]}]]]
,True]];
deq2=Cases[ZZ,(z:Z[_,_,c_]/;Flatten[d][[c]]==1):>z≤1,∞];

Evaluate[Table[dim[i],{i,1,GraphRank[g]}]]=Flatten[DimensionsByDepth[g]]

Table[dim[i],{i,1,GraphRank[g]}]

eq

Length[eq]

eq=SolveAllSolvableEquations[eq]

Take[eq,20]

variables=Union[Cases[eq,_Z,∞]]

linearEquations=Cases[eq,e_/;Length[CoefficientArrays[e[[1]],variables]]==2]

Solve[linearEquations,variables][[1]]/.(a_->b_):>(a=b)

eq=DeleteCases[Union[Expand[eq]],True]

variables=Union[Cases[eq,_Z,∞]]

DeleteCases[Flatten[Table[RootReduce[dim[i]dim[j]-Sum[Z[k,i,j]dim[k],{k,1,10}]],{i,1,GraphRank[g]},{j,1,GraphRank[g]}]],0]

Collect[%,_Z,N]

Count[#,_Z,∞]&/@%

eq=SolveAllSolvableEquations[eq]

eq=Collect[eq,_Z,Together];
eq=DeleteCases[Union[Expand[eq]],True];

eq

mm=Union[DeleteCases[Flatten[ZZ],_Integer]]

variables=Union[Cases[mm,_Z,∞]]

nn=LCM@@Denominator[Together[mm]]

Solve[{nn mm==0,Modulus==nn},variables,Mode->Modular]