- To Unit 1: compute simplex generating function using the Gauss-Bonnet theorem (134 bytes):
f[s_,x_]:=Module[{v=VertexList[s]},n=Length[v];1+Integrate[Sum[w=v[[k]];
f[VertexDelete[NeighborhoodGraph[s,w],w],t],{k,n}],{t,0,x}]];
f[RandomGraph[{100,1000}],x]
(this had been submitted to the WTC2023 1-liner competition).
- To Unit 2: compute the simplex generating function using Poincare Hopf. We compare
then with the traditional way by finding and super counting all cliques.
S[G_,v_]:=VertexDelete[NeighborhoodGraph[G,v],v]; L=Length;VL=VertexList;
S[G_,g_,v_]:=Subgraph[H=S[G,v];W=VL[H];H,Select[W,((# /. g)<(v /. g))&]]
R[G_]:=Table[VL[G][[k]]->Random[],{k,L[VL[G]]}]; Clear[f,t];
f[G_,g_,t_]:=Expand[1+t*Sum[v=VL[G][[k]];f[S[G,g,v],g,t],{k,L[VL[G]]}]];
i[G_,g_,v_]:=f[S[G,g,v],g,t] /. t->-1;
i[G_,g_]:=Table[i[G,g,VL[G][[k]]],{k,L[VL[G]]}];
Generate[A_]:=Delete[Union[Sort[Flatten[Map[Subsets,Map[Sort,A]],1]]],1];
Whitney[s_] :=Generate[FindClique[s,Infinity,All]];
EulerChi[A_]:=Sum[-(-1)^L[A[[k]]],{k,L[A]}];
F[G_]:=Delete[BinCounts[Map[L,Whitney[G]]],1];
Chi[G_]:=Module[{q=F[G]},Sum[q[[k]]*(-1)^(k-1),{k,L[q]}]];
G=RandomGraph[{300,2000}]; g=R[G]; {Total[i[G,g]],Chi[G]}
- To Unit 5: compute the cohomology.
5 lines of cohomology. Here we check Euler-Poincare for random complexes:
L=Length; F[G_]:=Module[{l=Map[L,G]},Table[Sum[If[l[[j]]==k,1,0],{j,L[l]}],{k,Max[l]}]];
s[x_]:=Signature[x];s[x_,y_]:=If[SubsetQ[x,y]&&(L[x]==L[y]+1),s[Prepend[y,Complement[x,y][[1]]]]*s[x],0];
Dirac[G_]:=Module[{f=F[G],b,d,n=L[G]},b=Prepend[Table[Sum[f[[l]],{l,k}],{k,L[f]}],0];
d=Table[s[G[[i]],G[[j]]],{i,n},{j,n}]; {d+Transpose[d],b}];
Hodge[G_]:=Module[{Q,b,H},{Q,b}=Dirac[G];H=Q.Q;Table[Table[H[[b[[k]]+i,b[[k]]+j]],{i,b[[k+1]]-b[[k]]},
{j,b[[k+1]]-b[[k]]}],{k,L[b]-1}]]; nu[A_]:=If[A=={},0,L[NullSpace[A]]]; Betti[G_]:=Map[nu,Hodge[G]];
Generate[A_]:=Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]; Cl=Generate;
R[n_,m_,d_]:=Cl[Select[Union[Table[Sort[Union[Table[RandomChoice[Range[n]],d]]],m]],L[#]==d &]];
G=R[30,400,3]; b=Betti[G]; {Sum[-(-1)^k b[[k]],{k,L[b]}], Sum[-(-1)^L[G[[k]]],{k,L[G]}]}
- To Unit 7: compute connection matrix and its inverse, the Green function
Generate[A_]:=If[A=={},A,Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]];
Whitney[s_]:=Generate[FindClique[s,Infinity,All]]; L=Length;
Connection[G_]:=Table[If[L[Intersection[G[[i]],G[[j]]]]>0,1,0],{i,L[G]},{j,L[G]}];
G=Generate[Whitney[RandomGraph[{20,60}]]]; L=Connection[G]; g=Inverse[L]; Det[L]
- To Unit 8: verify the Sphere formula for random simplicial complexes:
L=Length;RC[n_]:=RandomChoice[Range[n]];w[x_]:=-(-1)^L[x];Chi[A_]:=Total[Map[w,A]];
Generate[A_]:=Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]; Cl=Generate;
R[n_,m_,d_]:=Cl[Select[Union[Table[Sort[Union[Table[RC[n],d]]],m]],L[#]==d &]];
U[G_,x_]:=Module[{u={}},Do[If[SubsetQ[G[[k]],x],u=Append[u,G[[k]]]],{k,L[G]}];u];
Spheres[G_]:=Table[u=U[G,G[[k]]];Complement[Cl[u],u],{k,L[G]}];
G=R[20,200,3]; S=Spheres[G]; s=Map[Chi,S]; Print[s]; Sum[w[G[[k]]]*s[[k]],{k,L[G]}]
- To Unit 9: to generate manifolds. See
this exhibit
featuring some lines from 2024:
Generate[A_]:=If[A=={},{},Sort[Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]]];
Whitney[s_]:=Generate[FindClique[s,Infinity,All]]; w[x_]:=-(-1)^k;
R[G_,k_]:=Module[{},R[x_]:=x->RandomChoice[Range[k]]; Map[R,Union[Flatten[G]]]];
F[G_]:=Delete[BinCounts[Map[Length,G]],1]; Euler[G_]:=F[G].Table[w[k],{k,Length[F[G]]}];
Surface[G_,g_]:=Select[G,SubsetQ[#/.g,Union[Flatten[G] /. g]] &];
S[s_,v_]:=VertexDelete[NeighborhoodGraph[s,v],v]; Sf[s_,v_]:=F[Whitney[S[s,v]]];
Curvature[s_,v_]:=Module[{f=Sf[s,v]},1+f.Table[(-1)^k/(k+1),{k,Length[f]}]];
Curvatures[s_]:=Module[{V=VertexList[s]},Table[Curvature[s,V[[k]]],{k,Length[V]}]];
J[G_,H_]:=Union[G,H+Max[G]+1,Map[Flatten,Map[Union,Flatten[Tuples[{G,H+Max[G]+1}],0]]]];
ToGraph[G_]:=UndirectedGraph[n=Length[G];Graph[Range[n],
Select[Flatten[Table[k->l,{k,n},{l,k+1,n}],1],(SubsetQ[G[[#[[2]]]],G[[#[[1]]]]])&]]];
Barycentric[s_]:=ToGraph[Whitney[s]];
G=J[Whitney[Barycentric[CompleteGraph[{2,2,2}]]],Whitney[CycleGraph[7]]]; (* J=Join *)
g=R[G,3]; H=Surface[G,g]; (* A codimension 2 manifold in the 4-sphere G=Oct * C_7 *)
Print["EulerChi= ",Euler[H]]; Print["Fvector: ",F[H]];s=ToGraph[H];GraphPlot3D[s]
Print["Gauss-Bonnet Check: "]; Print[Total[Curvatures[s]]==Euler[H]];
Print["Curvature Values: "]; Print[Union[Curvatures[s]]];
