Sphere Formula - Quantum Calculus

The Harvard Science center is still closed most of the time due to electricity upgrades. I recorded therefore a short: It is about a paper [PDF] I’m writing. It does not contain much new, but is an important shift in perspective and language. Having taken topology more seriously it makes sense to formulate things also directly within simplicial complexes and not use the slightly less general graph frame work. This is important when having to verify that something is a topological invariant. The sphere formula tells that in a finite abstract simplicial complex $0 = \sum_x w(x) w(S(x))$ where $w(x)=(-1)^{{\rm dim}(x)}$ and $w(A) = \sum_{x \in A} w(x)$ and where $U(x)$ is the smallest open set containing the point $x$ and $S(x)$ is the boundary of $U(x)$ . The sphere formula follows from $w(G) = \sum_x w(x) w(U(x))$ . The topology on G is non-Hausdorff as simplices which are contained in each other can not be separated. This theorem immediately implies that spaces for which the unit spheres have constant non-zero Euler characteristic must have zero Euler characteristic themselves. Examples are odd dimensional manifolds. Below is the Mathematica code, I have included for that paper. It is self-contained and allows to experiment with arbitrary simplicial complexes:

Cl[A_]:=If[A=={},{},Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]];
Fvector[G_]:=If[Length[G]==0,{},Delete[BinCounts[Map[Length,G]],1]];
Ffunction[G_,t_]:=Module[{f=Fvector[G],n},Clear[t]; n=Length[f];
  If[Length[G]==0,1,1+Sum[f[[k]]*t^k,{k,n}]]];
Whitney[s_]:=If[Length[EdgeList[s]]==0,Map[{#}&,VertexList[s]],
  Map[Sort,Sort[Cl[FindClique[s,Infinity,All]]]]];
U[G_,x_]:=Module[{u={}},
  Do[If[SubsetQ[G[[k]],x],u=Append[u,G[[k]]]],{k,Length[G]}];u];
Stars[G_]:=Table[U[G,G[[k]]],{k,Length[G]}];
Spheres[G_]:=Table[u=U[G,G[[k]]];Complement[Cl[u],u],{k,Length[G]}]
w[x_]:=-(-1)^Length[x]; Chi[A_]:=Total[Map[w,A]];
g[G_]:=Module[{V=Stars[G],n=Length[G]},Table[w[G[[k]]]*w[G[[l]]]*
  Chi[Intersection[V[[k]],V[[l]]]],{k,n},{l,n}]];
sg[G_]:=Module[{V=Spheres[G],n=Length[G]},Table[w[G[[k]]]*w[G[[l]]]*
  Chi[Intersection[V[[k]],V[[l]]]],{k,n},{l,n}]];
Curvature[G_,t_]:=Module[{h=Ffunction[G,y]},Integrate[h,{y,0,t}]];
Curvatures[G_,t_]:=Module[{S=Spheres[G]},Table[If[Length[G[[k]]]==1,
  Curvature[S[[k]],t],0],{k,Length[S]}]];
Levitt[G_] := -Curvatures[G, t] /. t -> (-1);
Zykov[A_,B_]:=Module[{q=Max[Flatten[A]],Q,G=A},
  Q=Table[B[[k]]+q,{k,Length[B]}];
  Do[G=Append[G,Union[A[[a]],Q[[b]]]],{a,Length[A]},{b,Length[Q]}];
  G=Union[G,Q]; If[A=={},G=B]; If[B=={},G=A]; G];
DehnSommervilleQ[G_]:=Module[{f},Clear[t];f=Ffunction[G,t];
   Simplify[f] === Simplify[(f /. t->-1-t)]];

s=RandomGraph[{20,100}]; G=Whitney[s]; K=Levitt[G]; Q=sg[G];
Print["f-vector  ",Fvector[G]];
Print["Gauss-Bonnet ", Total[K]==Chi[G]];
H=Whitney[CycleGraph[4]]; sphere3=Zykov[H,H]; sphere5=Zykov[sphere3,H];
Print["3- sphere is flat ",Union[Levitt[sphere3]]=={0}];
Print["5- sphere is flat  ",Union[Levitt[sphere5]]=={0}];
Print["Green-Star matrix is unimodular. Det=  ",Det[g[G]]];
Print["nullity of sphere Green matrix:  ",Length[NullSpace[Q]]];
Print["sphere formula  ",Sum[w[G[[k]]]*Q[[k,k]],{k,Length[G]}]==0];
Print["3-sphere is Dehn-Sommerville ",DehnSommervilleQ[sphere3]];
Print["5-sphere is Dehn-Sommerville ",DehnSommervilleQ[sphere5]];
Print["disk is not D-S ",Not[DehnSommervilleQ[Whitney[StarGraph[5]]]]];

Author: oliverknill