(* Oliver Knill, January 18, 2021. This is included also in https://arxiv.org/abs/2101.06873 *) (* A basis of the cohomology group of a simplicial complex G *) ClearAll["Global`*"]; Generate[A_]:=Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]; M=12; check[x_]:=Module[{t=True,m=Length[x]}, Do[t=And[t,Less[1,Abs[x[[k]]-x[[l]]],M-1]],{k,m},{l,k+1,m}];t]; R=Generate[{Range[M]}]; G={}; Do[x=R[[k]];If[check[x],G=Append[G,x]],{k,Length[R]}] n=Length[G]; Dim=Map[Length,G]-1;f=Delete[BinCounts[Dim],1]; Omega[x_]:=-(-1)^Length[x]; EulerChi=Total[Map[Omega,G]]; Orient[a_,b_]:=Module[{z,c,k=Length[a],l=Length[b]}, If[SubsetQ[a,b] && (k==l+1),z=Complement[a,b][[1]]; c=Prepend[b,z]; Signature[a]*Signature[c],0]]; d=Table[Orient[G[[i]],G[[j]]],{i,n},{j,n}];Dirac=d+Transpose[d]; H=Dirac.Dirac; f=Prepend[f,0]; m=Length[f]-1; U=Table[v=f[[k+1]];Table[u=Sum[f[[l]],{l,k}];H[[u+i,u+j]],{i,v},{j,v}],{k,m}]; Cohomology = Map[NullSpace,U]; Betti=Map[Length,Cohomology] EVPlot=ListPlot[Sort[Eigenvalues[1.0*H]]/M] FormPlot=GraphicsGrid[Table[{ListPlot[Sort[Eigenvalues[1.0*U[[k]]]]/M, Joined->True,PlotRange ->{0,1}]},{k,Length[U]}]] (* A basis of the Wu cohomology groups of simplicial complex G *) ClearAll["Global`*"]; Generate[A_]:=Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]; M=7; check[x_]:=Module[{t=True,m=Length[x]}, Do[t=And[t,Less[1,Abs[x[[k]]-x[[l]]],M-1]],{k,m},{l,k+1,m}];t]; R=Generate[{Range[M]}]; G={}; Do[x=R[[k]];If[check[x],G=Append[G,x]],{k,Length[R]}] Coho2[G_,H_]:=Module[{U={},n=L[G],m=L[H]},L=Length; c[x_]:=Total[Map[L,x]]; Do[If[Greater[L[Intersection[G[[i]],H[[j]]]],0], U=Append[U,{G[[i]],H[[j]]}]],{i,n},{j,m}]; U=Sort[U,Less[c[#1],c[#2]] &];u=L[U];l=Map[c,U];w=Union[l]; b=Prepend[Table[Max[Flatten[Position[l,w[[k]]]]],{k,L[w]}],0]; der1[{x_,y_}]:=Table[{Sort[Delete[x,k]],y},{k,L[x]}]; der2[{x_,y_}]:=Table[{x,Sort[Delete[y,k]]},{k,L[y]}]; d1=Table[0,{u},{u}]; d2=Table[0,{u},{u}]; Do[v=der1[U[[m]]]; If[Greater[L[v],0], Do[r=Position[U,v[[k]]]; If[r!={},d1[[m,r[[1,1]]]]=(-1)^k],{k,L[v]}]],{m,u}]; Do[v=der2[U[[m]]]; If[Greater[L[v],0], Do[r=Position[U,v[[k]]]; If[r!={},d2[[m,r[[1,1]]]]=(-1)^(L[U[[m,1]]]+k)],{k,L[v]}]], {m,u}]; d=d1+d2; Dirac=d+Transpose[d];Hodge=Dirac.Dirac; Map[NullSpace,Table[Table[Hodge[[b[[k]]+i,b[[k]]+j]], {i,b[[k+1]]-b[[k]]},{j,b[[k+1]]-b[[k]]}],{k,L[b]-1}]]]; Betti2[G_,H_]:=Map[L,Coho2[G,H]];Coho2[G_]:=Coho2[G,G]; Betti2[G,G] (* Curvature of the dual linear graphs *) ClearAll["Global`*"]; S[G_,x_]:=Module[{A={},n=Length[G]},SQ=SubsetQ; Do[y=G[[k]]; If[(SQ[x,y]||SQ[y,x])&&Not[x==y],A=Append[A,y]],{k,n}];A]; UnitSpheres[G_]:=Module[{A={}},Do[If[Length[G[[k]]]==1, A=Append[A,S[G,G[[k]]]]],{k,Length[G]}];A]; F[G_]:=If[G=={},{},Delete[BinCounts[Map[Length,G]],1]]; f[G_,t_]:=Module[{u=F[G]},1+u.Table[t^k,{k,Length[u]}]]; EulerChi[G_]:=1-f[G,-1]; Curvature[A_,t_]:=Integrate[f[A,u],{u,0,t}]; Curvatures[G_,t_]:=Module[{S=UnitSpheres[G]}, Table[Curvature[S[[k]],u] /. u->t,{k,Length[S]}]] Generate[A_]:=Sort[Delete[Union[Sort[Flatten[Map[Subsets,A],1]]],1]]; ComputeCurvatures[M_]:=Module[{}, check[x_]:=Module[{t=True,m=Length[x]}, Do[t=And[t,Less[1,Abs[x[[k]]-x[[l]]]]],{k,m},{l,k+1,m}];t]; R=Generate[{Range[M]}]; G={}; L=Length; Po=Position; Do[x=R[[k]];If[check[x],G=Append[G,x]],{k,Length[R]}]; Curvatures[G,-1]]; Table[U=-ComputeCurvatures[k];{k,InputForm[U],Total[U]},{k,4,10}] Print[f[G,t]==1+Total[Curvatures[G,t]]]; Print[EulerChi[G]== -Total[Curvatures[G,-1]]]; (* Formulas for the curvatures of complements of linear graphs *) ClearAll["Global`*"]; g[n_]:=Expand[((1+u)^n-(1-u)^n)/(2^n*u)]; K[n_,k_]:=Integrate[g[k]*g[n-k+1]*u/2,{u,Sqrt[-3],1}] Curvatures[n_]:=Table[K[n,k],{k,n}]; Curvatures[7] ListPlot[100*Curvatures[100]] (* Computation of the Lefschetz numbers by finding all fixed points of the list of the automomorphism group A=rotations, B=reflections *) ClearAll["Global`*"]; WhitneyDualCycle[M_]:=Module[{f,add,f1=Table[{k},{k,M}]},If[M<=3,f=f1]; add[x_]:=If[Min[x]==1,Append[x,M-1],Append[x,M]]; If[M>3,f=Union[Flatten[{WhitneyDualCycle[M-1], Map[add,WhitneyDualCycle[M-2]]},1]]]; Union[f,f1]] Do[ L=Length; S=Signature; Po=Position; Ap=Append; W=WhitneyDualCycle[M]; A=Table[RotateRight[Range[M],k],{k,M}]; B=Map[Reverse,A]; T[x_,p_]:=Table[p[[x[[j]]]],{j,L[x]}];FixQ[x_,p_]:=Sort[T[x,p]]==x; Fix[p_]:=Module[{r={}},Do[If[FixQ[W[[k]],p],r=Ap[r,W[[k]]]],{k,L[W]}];r]; Q[p_]:=Total[f=Fix[p];Table[-(-1)^L[f[[k]]]*S[T[f[[k]],p]],{k,L[f]}]]; U=Map[Q,A]; V=Map[Q,B]; Print[{M,U,V,Total[U+V]/(2L[A])}],{M,4,20}] (* The universal curvature limit *) ClearAll["Global`*"]; R[a_,b_]:=Module[{},F={1,1};M=600+a; Do[n=Length[F];F=Append[F,Expand[F[[n]]+t*F[[n-1]]]],{M}]; f[n_]:=F[[n+2]]; A=Table[Expand[f[k-2]*f[M-k-1]],{k,M}]; Q[g_]:=M*Integrate[g,{t,-1,0}]; S[x_]:=Table[x[[6k+b]],{k,Floor[(Length[x]-b)/6]}]; U=Map[Q,A];V=S[U]; If[b==0,Print["EulerX=",Total[U]/M]]; ListPlot[V,Frame->True,PlotRange->{-1.5,3.5}]]; GraphicsGrid[Table[Table[R[a,b],{b,0,2}],{a,-2,3}]] ClearAll["Global`*"]; R[a_]:=Module[{},F={1,1};M=600+a; Do[n=Length[F];F=Append[F,Expand[F[[n]]+t*F[[n-1]]]],{M}]; f[n_]:=F[[n+2]]; A=Table[Expand[f[k-2]*f[M-k-1]],{k,M}]; Q[g_]:=M*Integrate[g,{t,-1,0}]; U=Map[Q,A]; ListPlot[Sort[U],Frame->True,PlotRange->{-1.5,3.5}]]; GraphicsGrid[Partition[Table[R[a],{a,-2,3}],3]] (* Trees and Forests *) ClearAll["Global`*"]; FirstNonZero[t_]:=-(-1)^ArrayRules[Chop[t]][[1,1,1]]*ArrayRules[t][[1,2]]; PDet[A_]:=FirstNonZero[CoefficientList[CharacteristicPolynomial[A,x],x]]; Fredholm[A_]:=A+IdentityMatrix[Length[A]]; TreeForestRatio[s_]:=Module[{K=KirchhoffMatrix[s]},Det[Fredholm[K]]/PDet[K]]; lambda[k_,n_]:=Sum[2 Sin[Pi*m*k/n]^2,{m,2,n-2}]; TreeForestRatioCycleDual[n_]:=Product[(1+lambda[k,n]^(-1)),{k,1,n-1}]; N[TreeForestRatio[GraphComplement[CycleGraph[100]]]] N[TreeForestRatioCycleDual[100]]