Summing over all Submanifolds

A write-up on the random manifold theorem is now available as a PDF. (July 28: and now the ArXiv) It contains the following code for the functional version of the theorem that allows to compute the average f-vector of a random manifold. It is again a bit intended as a Poem. It has been programmed “free solo” without in any possible way getting into contact with AI.

Generate[A_]:=If[A=={},{},Sort[Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]]];
Whitney[s_]:=Generate[FindClique[s,Infinity,All]]; L=Length; R:=Random[];   T=True; Clear[t]
U[G_,x_]:=Select[G,SubsetQ[#,x] &]; S[G_,x_]:=Complement[u=U[G,x]; Generate[u],u];
f[G_]:=1+Sum[t^L[G[[k]]],{k,L[G]}]; K[G_]:=Expand[Integrate[f[G],{t,0,T}]/T /. T->t];
Surface[G_,g_]:=Select[G,Union[# /. g]=={1,2} &];  j[G_,g_]:=f[Surface[G,g]];
P[x_]:=Module[{m=L[Position[x,1]],n=L[x]},1/(Binomial[n,m]*(n+1))];
J[G_]:=Module[{W=Union[Flatten[G]],A},A=Tuples[{1,2},L[W]];
                Sum[g=Table[W[[i]]->A[[m,i]],{i,L[W]}]; P[A[[m]]]*j[G,g],{m,L[A]}]];
H[G_]:=Expand[FullSimplify[1+(f[G]-J[G])/2]];
G = Whitney[RandomGraph[{10,30}]]; FullSimplify[H[G]==K[G]]

Lets take an example, where $G=K_{2,2,2,2}$ is the 3 dimensional cross polytop, the smallest 3-sphere that is a simplicial complex. It is also called the 16-cell. There are $2^8=256$ possible functions. The probability space of all submanifolds has now only 256 elements. The following few lines generate them all and display then as a 16 x 16 grid. But first some data: we have $f_G(t) = 16 t^4+32 t^3+24 t^2+8 t+1$ and the curvature function $K_G(t) = \int_0^t f_G(s) \; ds = 16 t^4+32 t^3+24 t^2+8 t+1$ which is the anti-derivative of the f-function. The polynomial J[G] add up all the f-functions of all the submanifolds. You can now run 1+(f[G]-J[G])/2==K[G] which has polynomials on both sides. After running Simplify on it, you get “True”. There are three type of manifolds here only: empty (in two cases, where the function is constant), then single 2-spheres and finally pairs of 2-spheres.

G=Whitney[CompleteGraph[{2,2,2,2}]]; W=Union[Flatten[G]]; A=Tuples[{1,2},L[W]];
AA=Table[ Table[W[[i]]->A[[m,i]],{i,L[W]}],{m,L[A]}];
ToGraph[G_]:=UndirectedGraph[n=L[G];Graph[Range[n],
 Select[Flatten[Table[k->l,{k,n},{l,k+1,n}],1],(SubsetQ[G[[#[[2]]]],G[[#[[1]]]]])&]]];
Chi[G_]:=1-f[G] /. (t->-1);        (* Euler Characteristic *)
SurfaceMap[g_]:=Surface[G,g];  AllSurfaces=Map[SurfaceMap,AA];
SS=Map[GraphPlot3D,Map[ToGraph,AllSurfaces]];        
GraphicsGrid[Partition[SS,16]]    (* Picture *)
1+(f[G]-J[G])/2==K[G]   (* Run Simplify on it to get True                       *)
-Map[Chi,AllSurfaces]   (* Euler characteristic, note that dimension is shifted *)

You can experiment. Replace the 16 cell with a 3-sphere with 10 vertices already G=Whitney[GraphJoin[CycleGraph[7],CycleGraph[5]]]; This gives already 2^12=4096 submanifolds. And in 140 cases already there are genus 2 surfaces. Here is a picture of a genus 2 surface. We see this surface to the right. The join of $C_7$ with $C_7$ is a 3 sphere that has already a genus 4 sub-manifolds among all the $2^{14}=16384$ surfaces. An interesting question, we can not answer yet is what is the average Betti vector $E[(b_0,b_1,b_2)]$ . We know the expectation of $b_0-b_1+b_2=2c-2g$ , where c is the number of connectivity components and $g$ is the genus. So, in this 3 dimensional case, we only need to know the average genus. An other concrete question is how how the maximal genus can grow for 3-spheres of the form $G=C_n \times C_m$ . We can not make too large experiments as the number of sub-manifolds is $2^{n+m}$ . For larger m,n we need to go Monte-Carlo.

Below are all the 256 submanifolds for the 16 cell.

Author: oliverknill