TensorSolver package

A subpackage for FusionAtlas v0.
2008, Scott Morrison

Introduction

---text goes here---

Implementation

Start of package

Specify package dependencies:

BeginPackage["FusionAtlas`TensorSolver`",{"FusionAtlas`","FusionAtlas`Bigraphs`","FusionAtlas`Debugging`","FusionAtlas`PackageData`","FusionAtlas`RemoteInterface`"}];

Usage messages

FindBifusionAlgebras::usage="";

FindFusionAlgebras;

TimeConstrainedFindFusionAlgebras;

TimeConstrainedFindBifusionAlgebras;

LazyFindFusionAlgebras;LazyFindBifusionAlgebras;

BifusionAlgebra::usage="";

FusionAlgebra;

FindBifusionAlgebras2;

System`$RecursionLimit=Max[5000,System`$RecursionLimit];

Internals

Begin["`Private`"];

verticesAtDepth[V_,g_GradedBigraph,depth_Integer]:=(V[depth,#]&/@Range[RankAtDepth[g,depth]]);

verticesAtDepth[V_,g_GradedGraph,depth_Integer]:=(V[depth,#]&/@Range[RankAtDepth[g,depth]]);

t[α_Integer X_,Z_]:=α t[X,Z]
t[X_, α_Integer Z_]:=α t[X,Z]
t[Z_Plus,X_]:=t[#,X]&/@Z
t[X_,Z_Plus]:=t[X,#]&/@Z

TensorRulesFromBigraphs[V_,g1_GradedBigraph, g2_GradedBigraph]:=
Module[{g,generator},
g[1]=g1;g[2]=g2;
generator[n0_]:=g[n0][[1,1]].verticesAtDepth[V[n0,##]&,g[n0],1];
Reap[
Do[
Sow[
t[V[n,depth,i],generator[Mod[n+depth+1,2]+1](*V[Mod[n+depth+1,2]+1,1,1]*)]->If[depth≤Length[g[n]]-1,g[n][[depth+1,All,i]].verticesAtDepth[V[n,##]&,g[n],depth+1],0]+If[depth>0,g[n][[depth,i]].verticesAtDepth[V[n,##]&,g[n],depth-1],0]
];
Sow[
t[V[n,depth,i],V[Mod[n+depth+1,2]+1,0,1]]->V[n,depth,i]
];
Sow[
t[V[n,0,1],V[n,depth,i]]->V[n,depth,i]
];
,{n,1,2}
,{depth,0,GraphDepth[g[n]]}
,{i,1,RankAtDepth[g[n],depth]}
]
][[2,1]]
]

TensorRulesFromGraph[V_,g_GradedGraph]:=
Module[{generator=g[[2,1,1]].verticesAtDepth[V,g,1]},
Reap[
Do[
Sow[
t[V[depth,i],generator]->If[depth<GraphDepth[g],g[[2,depth+1,All,i]].verticesAtDepth[V,g,depth+1],0]+
g[[1,depth+1,i]].verticesAtDepth[V,g,depth]+
If[depth>0,g[[2,depth,i]].verticesAtDepth[V,g,depth-1],0]
];
Sow[
t[V[depth,i],V[0,1]]->V[depth,i]
];
Sow[
t[V[0,1],V[depth,i]]->V[depth,i]
];
,{depth,0,GraphDepth[g]}
,{i,1,RankAtDepth[g,depth]}
]
][[2,1]]
]

leftModules[g1_,g2_][N]:=Join@@Table[verticesAtDepth[V[1,##]&,g1,depth],{depth,0,GraphDepth[g1]}];
leftModules[g1_,g2_][M]:=Join@@Table[verticesAtDepth[V[2,##]&,g2,depth],{depth,0,GraphDepth[g2]}];
rightModules[g1_,g2_][N]:=Join@@(Table[verticesAtDepth[V[1,##]&,g1,depth],{depth,0,GraphDepth[g1],2}]~Join~Table[verticesAtDepth[V[2,##]&,g2,depth],{depth,1,GraphDepth[g2],2}]);
rightModules[g1_,g2_][M]:=Join@@(Table[verticesAtDepth[V[1,##]&,g1,depth],{depth,1,GraphDepth[g1],2}]~Join~Table[verticesAtDepth[V[2,##]&,g2,depth],{depth,0,GraphDepth[g2],2}]);
leftLabel[V[n_,_,_]]:=Switch[n,1,N,2,M];
rightLabel[V[n_,d_,_]]:=Switch[Mod[n+d+1,2],0,N,1,M];
leftLabel[t[A_,_]]:=leftLabel[A]
rightLabel[t[_,B]]:=rightLabel[B]
leftLabel[A_+_]:=leftLabel[A]
rightLabel[A_+_]:=rightLabel[A]
leftLabel[n_?NumericQ A_]:=leftLabel[A]
rightLabel[n_?NumericQ A_]:=rightLabel[A]
bimodules[g1_GradedBigraph,g2_GradedBigraph][X_,Y_]:=Intersection[leftModules[g1,g2][X],rightModules[g1,g2][Y]];
allModules[g1_GradedBigraph,g2_GradedBigraph]:=leftModules[g1,g2][N]~Join~leftModules[g1,g2][M];

allModules[g_GradedGraph]:=Join@@Table[verticesAtDepth[V,g,depth],{depth,0,GraphDepth[g]}]

deleteIdentities[list_]:=DeleteCases[list,V[_,0,1]|V[0,1]]

associativityEquation[A_,B_,C_]:=t[t[A,B],C]==t[A,t[B,C]];
associativityEquations[g1_GradedBigraph,g2_GradedBigraph]:=Union[associativityEquation@@#&/@(Flatten[Flatten[Outer[List,deleteIdentities[rightModules[g1,g2][#[[1]]]],deleteIdentities[bimodules[g1,g2][#[[1]],#[[2]]]],deleteIdentities[leftModules[g1,g2][#[[2]]]]],2]&/@Flatten[Outer[List,{N,M},{N,M}],1],1])];

associativityEquations[g_GradedGraph]:=Union[associativityEquation@@#&/@Flatten[Outer[List,deleteIdentities[allModules[g]],deleteIdentities[allModules[g]],deleteIdentities[allModules[g]]],2]]

f[g_GradedBigraph,(1|2),-1]:=0
f[g_GradedBigraph,n:(1|2),0]:=V[n,0,1]

f[g_GradedBigraph,n:(1|2),k_Integer]/;k>0:=(f[g,n,k-1]/.V[n,d_,l_]:>If[d>0,(Transpose[g[[d]]].UnitVector[RankAtDepth[g,d],l]).Table[V[n,d-1,j],{j,1,RankAtDepth[g,d-1]}],0]+If[d<GraphDepth[g],(g[[d+1]].UnitVector[RankAtDepth[g,d],l]).Table[V[n,d+1,j],{j,1,RankAtDepth[g,d+1]}],0])-f[g,n,k-2]

TLEquation[g1_GradedBigraph,g2_GradedBigraph,n_Integer,k_Integer,l_Integer]:=
Module[{g},
g[1]=g1;g[2]=g2;
t[f[g[n],n,k],f[g[Mod[n+k+1,2]+1],Mod[n+k+1,2]+1,l]]==Sum[f[g[n],n,j],{j,Abs[k-l],k+l,2}]
]

TLEquations[g1_GradedBigraph,g2_GradedBigraph]:=With[{depth=Max[GraphDepth[g1],GraphDepth[g2]]},Union[Flatten[Table[TLEquation[g1,g2,n,k,l],{n,1,2},{k,0,depth},{l,0,depth}],2]]
]

dimensions[g1_GradedBigraph,g2_GradedBigraph][V[n:(1|2),depth_,k_]]:=ReducedDimensionsByDepth[Switch[n,1,g1,2,g2]][[depth+1,k]]

dimensions[g__][t[A_,B_]]:=dimensions[g][A]dimensions[g][B]
dimensions[g__][Z_Plus]:=dimensions[g]/@Z
dimensions[g__][α_Integer V_]:=α dimensions[g][V]

dimensions[g_GradedGraph][V[depth_,k_]]:=ReducedDimensionsByDepth[g][[depth+1,k]]

KnapsackSolutions[g1_GradedBigraph,g2_GradedBigraph][A:V[_,depth1_,_],B:V[_,depth2_,_]]:=KnapsackSolutions[g1,g2][A,B]=Module[{d,b,iterators,i,j,k,n,maxDepth=depth1+depth2},
d=dimensions[g1,g2][t[A,B]];
b=Cases[bimodules[g1,g2][leftLabel[A],rightLabel[B]],V[_,depth_/;depth≤maxDepth,_]];
iterators=Table[{i[k],0,If[MatchQ[b[[k]],V[_,0,1]],1,Expand[((N[d]-Sum[i[j]N[dimensions[g1,g2][b[[j]]]],{j,1,k-1}])/(N[dimensions[g1,g2][b[[k]]]]))+0.0001]]},{k,1,Length[b]-1}];
#.b&/@Cases[Flatten[{Table[Table[i[k],{k,1,Length[b]-1}]~Join~{((d-Sum[i[j]dimensions[g1,g2][b[[j]]],{j,1,Length[b]-1}])/(dimensions[g1,g2][b[[-1]]]))},Evaluate[Sequence@@iterators]]},Max[0,Length[b]-1]],(l_/;0.4999<Mod[N[Last[l]]+0.5,1.0]<0.5001):>Floor[l+0.0002]]
]

KnapsackSolutions[g_GradedGraph][A:V[depth1_,_],B:V[depth2_,_]]:=KnapsackSolutions[g][A,B]=Module[{d,b,iterators,i,j,k,n,maxDepth=depth1+depth2},
d=dimensions[g][t[A,B]];
b=Cases[allModules[g],V[depth_/;depth≤maxDepth,_]];
iterators=Table[{i[k],0,If[MatchQ[b[[k]],V[0,1]],1,Expand[((N[d]-Sum[i[j]N[dimensions[g][b[[j]]]],{j,1,k-1}])/(N[dimensions[g][b[[k]]]]))+0.0001]]},{k,1,Length[b]-1}];
#.b&/@Cases[Flatten[{Table[Table[i[k],{k,1,Length[b]-1}]~Join~{((d-Sum[i[j]dimensions[g][b[[j]]],{j,1,Length[b]-1}])/(dimensions[g][b[[-1]]]))},Evaluate[Sequence@@iterators]]},Max[0,Length[b]-1]],(l_/;0.4999<Mod[N[Last[l]]+0.5,1.0]<0.5001):>Floor[l+0.0002]]
]

(* obsolete *)
(*knapsackAlternatives[g1_,g2_]:=Sort[
Flatten[Outer[DebugEcho[{#1,#2,KnapsackSolutions[g1,g2][#1,#2]}]&,DeleteCases[rightModules[g1,g2][N],V[_,1,1]],DeleteCases[leftModules[g1,g2][N],V[1,1|2,1]]],1]
~Join~
Flatten[Outer[DebugEcho[{#1,#2,KnapsackSolutions[g1,g2][#1,#2]}]&,DeleteCases[rightModules[g1,g2][M],V[_,1,1]],DeleteCases[leftModules[g1,g2][M],V[2,1|2,1]]],1]
,Length[#1[[3]]]<Length[#2[[3]]]&]/.{X_,Y_,{Z___}}:>(t[X,Y]->#&/@{Z})*)

identityRules={t[V[_,0,1],X_]:>X,t[X_,V[_,0,1]]:>X,t[V[0,1],X_]:>X,t[X_,V[0,1]]:>X};

(*linearCombinationOfSimplesPattern=HoldPattern[(Plus[((_Integer:1) _V)...]|((_Integer:1)_V))];*)

inconsistentEquationPatterns=
(*(X_V==Y_V)|
(X_V+Y_V==Z_V)|
(X_V+Y_V==W_V+Z_V)|*)
HoldPattern[(Plus[((_Integer:1) _V)...]|((_Integer:1)_V))==(Plus[((_Integer:1) _V)...]|((_Integer:1)_V))]|
HoldPattern[((_Integer:1)_V)+_==(Plus[((_Integer:1) _V)...]|((_Integer:1)_V))];

equationConsistentQ[equation_]:=equationConsistentQ[equation]=!MatchQ[Expand[equation],inconsistentEquationPatterns]

Options[equationsConsistentQ]={"Verbose"->False};

equationsConsistentQ[equations_,options___]:=Module[{r=True,verbose},
verbose="Verbose"/.{options}/.Options[equationsConsistentQ];
Do[If[!(r=equationConsistentQ[equations[[i]]]),Break[]],{i,1,Length[equations]}];
If[r,If[verbose,DebugPrint["These equations look consistent, are they?"];DebugPrint[Cases[equations,eq_/;Count[eq,_t,∞]≤2]]],DebugPrint["Found some inconsistent equations.",Cases[equations,eq_/;!equationConsistentQ[eq],{1},1]/.{t->"t",V->"V"}]];
r
]

identifyMistakes[rules_,correctRules_]:=Cases[Complement[rules,correctRules],(x_->y_)/;MemberQ[First/@correctRules,x]]

tryAlternatives[g__][recursionData_,equations0_,currentRules0_,{unknownPair_,remainingUnknowns___}]:=
Module[{rule,equations,newEquations,newRules,currentRules,alternatives},
DebugPrint["Recursion progress ",recursionData];
(*First, try to derive some easy new rules.*)
equations=equations0;
currentRules=currentRules0;

(* Now look for more rules *)
While[Length[newRules=Cases[equations,(t[A_,B_]==X_/;FreeQ[{A,B,X},t]):>t[A,B]->Expand[X]]]>0,
DebugPrint["Found new rules."];
DebugPrint[newRules/.{t->"t",V->"V"}];
If[Length[Global`TensorSolverCorrectRules]>0,
mistakes=identifyMistakes[newRules,Global`TensorSolverCorrectRules/.{Global`t->t,Global`V->V}];
If[Length[mistakes]>0,
DebugPrint["Some of these new rules contradict the correct ones!"];
DebugPrint[mistakes/.{t->"t",V->"V"}];
];
];
currentRules=currentRules~Join~newRules;
equations=Sort[Union[DeleteCases[Simplify[equations//.currentRules],True]],Count[#1,_t,∞]<Count[#2,_t,∞]&];
(* back out if the equations aren't consistent *)
If[!equationsConsistentQ[equations],Return[{}]];
];

(* double check the equations are consistent! *)
If[!equationsConsistentQ[equations,"Verbose"->False],Return[{}]];

If[MemberQ[First/@currentRules,t@@unknownPair],
(*We've already got a rule for this tensor product.*)
tryAlternatives[g][recursionData~Join~{{1,1}},equations,currentRules,{remainingUnknowns}],
(* Otherwise, continue, recursing into the unknown. *)
(* Solve the knapsack problem for the first unknown tensor product *)
alternatives=((t@@unknownPair)->#)&/@KnapsackSolutions[g]@@unknownPair;
If[alternatives=={},Return[{}]];
DebugPrint["There are currently ",Length[currentRules], " rules, considering alternatives:"];
DebugPrint[alternatives/.{t->"t",V->"V"}];
Table[rule=alternatives[[i]];
If[Length[Global`TensorSolverCorrectRules]>0,
If[Length[identifyMistakes[{rule},Global`TensorSolverCorrectRules/.{Global`t->t,Global`V->V}]]>0,
DebugPrint["considering an alternative which contradicts the correct rules:"];
];
];
DebugPrint["considering alternative: ", rule/.{t->"t",V->"V"}];
tryAlternatives[g][recursionData~Join~{{i,Length[alternatives]}},Sort[Union[DeleteCases[Simplify[equations//.{rule}~Join~currentRules],True]],Count[#1,_t,∞]<Count[#2,_t,∞]&],{rule}~Join~currentRules,{remainingUnknowns}],
{i,1,Length[alternatives]}]
]
]

tryAlternatives[g__][recursionData_,equations_,currentRules_,{}]:=Module[{newEquations,result},
If[(newEquations=DeleteCases[Simplify[equations//.currentRules],True])=={},result=TensorSolution[currentRules],
If[equationsConsistentQ[newEquations],
(Print["No more unknown tensor products, but there are still equations: "];Print[equations];Print[currentRules];$Failed),
result={}
]
];
result
]

unknownTensorProducts[g1_GradedBigraph,g2_GradedBigraph]:=(*unknownTensorProducts[g1,g2]=*)SortBy[Flatten[Outer[List,DeleteCases[rightModules[g1,g2][N],V[_,0,1]],DeleteCases[leftModules[g1,g2][N],V[1,0|1,1]]],1]~Join~
Flatten[Outer[List,DeleteCases[rightModules[g1,g2][M],V[_,0,1]],DeleteCases[leftModules[g1,g2][M],V[2,0|1,1]]],1],{(*#[[1,1]],#[[2,1]],*)dimensions[g1,g2][t@@#]}&]

unknownTensorProducts[g_GradedGraph]:=SortBy[Flatten[Outer[List,DeleteCases[allModules[g],V[0,1]],DeleteCases[allModules[g],V[0|1,1]]],1],{(*#[[1,1]],#[[2,1]],*)dimensions[g1,g2][t@@#]}&]

(*FindFusionAlgebras[g_GradedGraph]/;(g[[1,1]]=={{0}}∧g[[2,1]]=={{1}}):=FindFusionAlgebras[g]=Module[{solutions,X,Y},
solutions=Flatten[tryAlternatives[g][{},associativityEquations[g],TensorRulesFromGraph[V,g]~Join~identityRules,unknownTensorProducts[g]]];
(FusionAlgebra[g,#]&/@(Function[{solution},Outer[Function[{X,Y},Function[{Z},Coefficient[t[X,Y]/.solution[[1]],Z]]/@allModules[g]],allModules[g],allModules[g]]]/@solutions))
]*)

FindBifusionAlgebras2[g1_GradedBigraph,g2_GradedBigraph]/;(g1[[1]]=={{1}}∧g2[[1]]=={{1}}):=(*FindBifusionAlgebras[g1,g2]=*)Module[{Y,ZZ,eq,deq,tleq,g,w},
g[1]=g1;g[2]=g2;
Y[V[na_,0,1],V[na_,db_,kb_],V[na_,dc_,kc_]]:=If[db==dc∧kb==kc,1,0];
Y[V[na_,da_,ka_],V[nb_,0,1],V[na_,dc_,kc_]]/;(Mod[na+nb+da,2]==0):=If[da==dc∧ka==kc,1,0];
Y[V[na_,da_,ka_],V[nb_,1,1],V[na_,dc_,kc_]]/;(Mod[na+nb+da,2]==0):=
Switch[dc-da,
1,g[na][[da+1,kc,ka]],
-1,g[na][[da,ka,kc]],
_,0
];
Y[V[na_,da_,ka_],V[nb_,db_,kb_],V[nc_,dc_,kc_]]/;na≠nc:=0;
Y[V[na_,da_,ka_],V[nb_,db_,kb_],V[nc_,dc_,kc_]]/;(Mod[na+nb+da,2]≠0):=0;
Y[V[na_,da_,ka_],V[nb_,db_,kb_],V[nc_,dc_,kc_]]/;(Mod[nb+db+nc+dc,2]≠0):=0;
ZZ=Outer[Y,allModules[g1,g2],allModules[g1,g2],allModules[g1,g2]];
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[With[{d=dimensions[g1,g2]/@allModules[g1,g2]},
Thread[Flatten[ZZ.Flatten[d]]≤Flatten[Outer[0.001+dimensions[g1,g2][#1]dimensions[g1,g2][#2]&,allModules[g1,g2],allModules[g1,g2]]]]
],True]];

w[v_V][u_V]:=If[v===u,1,0];
w[v_V][u_Plus]:=w[v]/@u;
w[v_V][α_?NumericQ u_]:=α w[v][u];
w[v_V][t[a_,b_]]:=Y[a,b,v];
tleq=Union[Flatten[TLEquations[g1,g2]/.(eq:(a_==b_):>Cases[eq,v_V:>w[v][a]==w[v][b],∞])]];

eq0=eq;
deq0=deq;
FindMoreRules[Y,eq~Join~tleq,deq,{}]/.Solution[rules_List]:>BifusionAlgebra[{g1,g2},ZZ/.rules]
]

FindFusionAlgebras[g_GradedGraph]/;(g[[1,1]]=={{0}}∧g[[2,1]]=={{1}}):=FindFusionAlgebras[g]=Module[{Z,fV,ZZ,eq,deq,deq2,d},
d=NumericDimensionsByDepth[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[0.001+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,∞];
FindMoreRules[Z,eq,deq~Join~deq2,{}]/.Solution[rules_List]:>FusionAlgebra[g,ZZ/.rules]
]

FindMoreRules[Z_,eq_,deq_,rules_]:=
Module[{zS=Cases[eq,_Z,∞,1],z,k=0,neweq,shorteq,sols,newdeq,newrules,more=True,results={},space=ToString[Length[rules]]<>": "},
If[Length[zS]==0,
Solution[rules],
z=zS[[1]];
While[more∧k≤If[MatchQ[z[[3]],1|V[1|2,0,1]],1,∞],
DebugPrint[space,"Considering ",z/.{V->"V",Y->"Y"},"->",k];
newrules={z->k};
newdeq=deq/.newrules;
If[And@@newdeq/._Z->0,
DebugPrint[space,"Dimensions look okay."];
neweq=DeleteCases[eq/.newrules,True];
shorteq=Cases[neweq,e_/;Count[e,_Z,∞]==1];
While[Length[shorteq]>0,
sols=Solve[shorteq,Union[Cases[shorteq,_Z,∞]]];
Switch[Length[sols],
0,(DebugPrint[space,"derived something false!"];neweq={False};shorteq={};),
1,(If[MemberQ[sols[[1]],_Z->c_/;c<0],
DebugPrint[space,"derived something false!"];neweq={False};shorteq={},
newrules=newrules~Join~sols[[1]];
neweq=DeleteCases[neweq/.newrules,True];
shorteq=Cases[neweq,e_/;Count[e,_Z,∞]==1];
];),
_,(DebugPrint["found multiple solutions, not trying to derive anything further..."];shorteq={};)
];
];
If[MemberQ[neweq,False],
DebugPrint[space,"Found inconsistency in associativity equations."];,
DebugPrint[space,"Associativity equations still look okay."];
results=Append[results,FindMoreRules[Z,neweq,newdeq,(rules/.(a_->b_):>(a->(b/.newrules)))~Join~newrules]];
];,
DebugPrint[space,"Breaks dimension inequalities."];
more=False;
];
++k;
];
Flatten[DeleteCases[results,{}]]
]
]

FindBifusionAlgebras[g1_GradedBigraph,g2_GradedBigraph]/;(g1[[1]]=={{1}}∧g2[[1]]=={{1}}):=FindBifusionAlgebras[g1,g2]=Module[{solutions,X,Y},
solutions=Flatten[tryAlternatives[g1,g2][{},associativityEquations[g1,g2]~Join~TLEquations[g1,g2],TensorRulesFromBigraphs[V,g1,g2]~Join~identityRules,unknownTensorProducts[g1,g2]]];
(BifusionAlgebra[{g1,g2},#]&/@(Function[{solution},(Function[{labels},labels->Outer[Function[{X,Y},Function[{Z},Coefficient[t[X,Y]/.solution[[1]],Z]]/@bimodules[g1,g2][labels[[1]],labels[[3]]]],bimodules[g1,g2][labels[[1]],labels[[2]]],bimodules[g1,g2][labels[[2]],labels[[3]]]]]/@Flatten[Outer[List,{N,M},{N,M},{N,M}],2])]/@solutions))/.{N->1,M->2}
]

LazyFindFusionAlgebras[g_GradedGraph]:=Module[{values,partners},
values=With[{gg=g},
MatchingValues[FindFusionAlgebras,HoldPattern[FindFusionAlgebras[gg]]]
];
If[Length[values]==0,$Failed,values[[1,2]]]
]

FindFusionAlgebrasTimeConstraint[g_GradedGraph]:=0

TimeConstrainedFindFusionAlgebras[g_GradedGraph,t_]:=
If[FindFusionAlgebrasTimeConstraint[g]≥t,
$Failed,
Module[{result},
result=TimeConstrained[FindFusionAlgebras[g],t];
If[result===$Aborted,
FindFusionAlgebrasTimeConstraint[g]=t;
$Failed,
FindFusionAlgebrasTimeConstraint[g]=0;
result
]
]
]

TimeConstrainedFindFusionAlgebras[graphs:{___GradedGraph},t_]:=
Module[{r=LazyFindFusionAlgebras[#]},
If[r===$Failed,
Print["Spending ",t," seconds looking for fusion algebras on ",#];
r=TimeConstrainedFindFusionAlgebras[#,t];
If[r===$Failed,
Print["... gave up."];,
Print["... found ", Length[r], " fusion algebras"];PackageBifusionAlgebras[];
];
];
r
]&/@Cases[graphs,g_/;(g[[1,1]]=={{0}}∧g[[2,1]]=={{1}})]

TimeConstrainedFindFusionAlgebras[graphs:{___GradedBigraph},t_]:=
Module[{r=LazyFindFusionAlgebras[EvenPart[#]]},
If[r===$Failed,
Print["Spending ",t," seconds looking for fusion algebras on the even part of ",DisplayBigraph[#]];
r=TimeConstrainedFindFusionAlgebras[EvenPart[#],t];
If[r===$Failed,
Print["... gave up."];,
Print["... found ", Length[r], " fusion algebras"];PackageBifusionAlgebras[];
];
];
r
]&/@Cases[graphs,g_/;With[{g0=EvenPart[g]},g0[[1,1]]=={{0}}∧g0[[2,1]]=={{1}}]]

TimeConstrainedFindFusionAlgebras[graphs_List]:=Module[{results={$Failed},t=1},
While[MemberQ[results,$Failed],
results=TimeConstrainedFindFusionAlgebras[graphs,t*=10]
];
]

LazyFindBifusionAlgebras[g1_GradedBigraph,g2_GradedBigraph]:=Module[{values,partners},
values=With[{gg1=g1,gg2=g2},
MatchingValues[FindBifusionAlgebras,HoldPattern[FindBifusionAlgebras[gg1,gg2]]]
];
If[Length[values]==0,$Failed,values[[1,2]]]
]

FindBifusionAlgebrasTimeConstraint[g1_GradedBigraph,g2_GradedBigraph]:=0

TimeConstrainedFindBifusionAlgebras[g1_GradedBigraph,g2_GradedBigraph,t_]:=
If[FindBifusionAlgebrasTimeConstraint[g1,g2]≥t,
$Failed,
Module[{result},
result=TimeConstrained[FindBifusionAlgebras[g1,g2],t];
If[result===$Aborted,
FindBifusionAlgebrasTimeConstraint[g1,g2]=t;
$Failed,
FindBifusionAlgebrasTimeConstraint[g1,g2]=0;
result
]
]
]

BifusionAlgebra[{g1_,g2_},data_][W1_,W2_]/;(Head[W1]==Head[W2]∧rightLabel[V@@W1]==leftLabel[V@@W2]):=
With[{V1=V@@W1,V2=V@@W2},
({leftLabel[V1],rightLabel[V1],rightLabel[V2]}/.data)[[Position[bimodules[g1,g2][leftLabel[V1],rightLabel[V1]],V1][[1,1]],Position[bimodules[g1,g2][leftLabel[V2],rightLabel[V2]],V2][[1,1]]]].bimodules[g1,g2][leftLabel[V1],rightLabel[V2]]/.V->Head[W1]
]

End

End[];

End of package

EndPackage[];