Last Saturday, I talked in my office about a new result about curvature of finite simple graphs. It is what one would expect for curvature to happen: if one takes the Shannon product of two graphs, then the curvatures multiply (what else). The proof uses a similar product formula for Poincare-Hopf indices and then uses the fact that curvature is the expectation of such indices when averaging over a probability space of functions. The result is actually much more general. Any index expectation curvature tensor multiplies. This is of course also true in the continuum for index expectation curvatures like Gauss-Bonnet-Chern which is the most natural curvature there. By the way, there are many curvatures which have been considered in graph theory. Here is an illustration: We see the product of the utility graph with a star graph. In the top part, we have computed the curvature, in the bottom part, we see the Poincare-Hopf indices of a random function. Poincare-Hopf tells that the sum of the indices is the Euler characteristic. Gauss-Bonnet tells that the sum of the curvatures is the Euler characteristic. [Update: http://people.math.harvard.edu/~knill/graphgeometry/papers/productcurvature.pdf [PDF] ] Mathematica code is at the very end of this post.
(* Oliver Knill, July 10, 2021 *)
Generate[A_]:=Sort[Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]];
Whitney[G_]:=Generate[FindClique[G, Infinity, All]]; NH=NeighborhoodGraph;
Fvector[G_]:=If[Length[VertexList[G]]==0,{},Delete[BinCounts[Map[Length,Whitney[G]]],1]];
Ffunction[G_,t_]:=Module[{f=Fvector[G]},1+Sum[f[[k]] t^k,{k,Length[f]}]];
EulerChi[G_]:=Module[{f=Fvector[G]},Sum[f[[k]](-1)^(k+1),{k,Length[f]}]];
S[G_,x_]:=Module[{H=NH[G,x]},If[Length[VertexList[H]]<2,Graph[{}],VertexDelete[H,x]]];
Curvature[G_,v_]:=Module[{G1,vl1,n1,k,u},G1=S[G,v];vl1=VertexList[G1]; n1=Length[vl1];
u=Fvector[G1]; 1+Sum[u[[k]]*(-1)^k/(k+1),{k,Length[u]}]];
Curvatures[G_]:=Module[{vl=VertexList[G]},Table[Curvature[G,vl[[k]]],{k,Length[vl]}]];
RandFunction[G_]:=Table[Random[],{Length[VertexList[G]]}];
Indices[G_,g_]:=Module[{v=VertexList[G],w,H,T,u},
Table[ T=S[G,v[[k]]]; u=VertexList[T]; w={};
Do[If[g[[j]]<g[[k]] && MemberQ[u,v[[j]]],w=Append[w,v[[j]]]],{j,Length[v]}];
H=Subgraph[T,w]; 1-EulerChi[H],{k,Length[v]}]]
StrongProduct[G_,H_]:=Module[{v,e={},e1,e2,q,
vG=VertexList[G],vH=VertexList[H],eG=EdgeList[G],eH=EdgeList[H]},
eG=Table[Sort[{eG[[k,1]],eG[[k,2]]}],{k,Length[eG]}];
eH=Table[Sort[{eH[[k,1]],eH[[k,2]]}],{k,Length[eH]}];
v=Partition[Flatten[Table[{vG[[k]],vH[[l]]},{k,Length[vG]},{l,Length[vH]}]],2];
Do[If[v[[k,2]]==v[[l,2]]&&MemberQ[eG,Sort[{v[[k,1]],v[[l,1]]}]],
e=Append[e,v[[k]]->v[[l]]]],{k,Length[v]},{l,Length[v]}];
Do[If[v[[k,1]]==v[[l,1]]&&MemberQ[eH,Sort[{v[[k,2]],v[[l,2]]}]],
e=Append[e,v[[k]]->v[[l]]]],{k,Length[v]},{l,Length[v]}];
e1=Table[{eG[[k,1]],eH[[l,1]]}->{eG[[k,2]],eH[[l,2]]},{k,Length[eG]},{l,Length[eH]}];
e2=Table[{eG[[k,1]],eH[[l,2]]}->{eG[[k,2]],eH[[l,1]]},{k,Length[eG]},{l,Length[eH]}];
q=Flatten[Union[e,e1,e2]]; UndirectedGraph[Graph[v,q]]];
TensProduct[g_,h_]:=Flatten[Table[g[[k]] h[[l]],{k,Length[g]},{l,Length[h]}]];
G=RandomGraph[{8,12}]; g=RandFunction[G]; KG=Curvatures[G]; IG=Indices[G,g];
H=RandomGraph[{7,17}]; h=RandFunction[H]; KH=Curvatures[H]; IH=Indices[H,h];
GH=StrongProduct[G,H]; gh=TensProduct[g,h]; KK=Curvatures[GH];II=Indices[GH,gh];
{TensProduct[IG,IH]==II, TensProduct[KG,KH]==KK, Total[KK]==Total[II]==EulerChi[GH]}
