Higman-Sims Graph

Author

Eric W. Weisstein
March 28, 2022

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Higman-SimsGraph.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/Higman-SimsGraph.html.

©2022 Wolfram Research, Inc. except for portions noted otherwise

Embeddings

All

Annotate[#,{EdgeStyle->GrayLevel[.7],VertexStyle->Red}]&/@GraphData["HigmanSimsGraph","Graph","All"]

3D

GraphPlot3D[#/.List->Rule&/@Flatten[{hs1,hs2,hs3},1]]

Wikipedia

http://en.wikipedia.org/wiki/Higman-Sims_graph

xml=Import["http://upload.wikimedia.org/wikipedia/commons/e/ef/Higman_Sims_Graph.svg","XML"]

layers0=Cases[xml,XMLElement["g",{"id"->id_,_},l_List]:>{id,Length[l]},∞]

Total[layers=Most[layers0][[All,2]]]

Length[v=Cases[g,XMLElement["circle",l_List,_]:>ToExpression[{"cx","cy"}/.l],∞]]

Length[e0=Cases[g,XMLElement["line",l_List,_]:>ToExpression[{{"x1","y1"},{"x2","y2"}}/.l],∞]]

e=e0/.Thread[v->Range[Length[v]]]

pcs=Span@@@({#[[1]]+1,#[[2]]}&/@Partition[Prepend[Accumulate[layers],0],2,1])

Reverse[Graphics[Line[e0[[#]]]]&/@pcs]

Needs["Graphics`Colors`"]//Quiet

color={Red,Orange,Yellow,GreenPale,Green,GreenDark,Blue,SlateBlueDark,Purple,Black};

i=1;
GraphicsGrid[plots=Partition[GraphPlot[#,Method->None,"EdgeColor"->color[[i++]]]&/@(gs=Reverse[Graph[List/@#,List/@v]&/@(e0[[#]]&/@pcs/.Thread[v->Range[Length[v]]])])/.AbsolutePointSize[_]:>AbsolutePointSize[.2],4,4,{1,1},{}],ImageSize->400,Spacings -> -40]

Show[plots]

RecognizeGraph/@gs

RemoveIsolatedVertices[g_]:=DeleteVertices[g,Flatten[Position[Degrees[g],0]]]

RecognizeGraph/@RemoveIsolatedVertices/@gs

ConnectedComponentGraphs[g_]:=InduceSubgraph[g,#]&/@ConnectedComponents[g]

(RecognizeGraph/@ConnectedComponentGraphs[RemoveIsolatedVertices[#]])&/@gs

RecognizeGraph[GraphSum@@gs]

hs=Graph[List/@e,List/@v]

GraphPlot[hs,Method->None,ImageSize->300]

RecognizeGraph[hs]

ToCommonEdges[hs,Graph["HigmanSimsGraph"]]/700

Relationships to other graphs

https://cp4space.hatsya.com/2013/09/12/leech-lattice/

Removing a vertex of the Higman-Sims graph together with its 22 neighbours gives the M22 graph.

RecognizeGraph[VertexDelete[GraphData["HigmanSimsGraph"],Join[{1},AdjacencyList[GraphData["HigmanSimsGraph"],1]]]]

Construction

Witt Design Eric

(http://www.win.tue.nl/~aeb/drg/graphs/Higman-Sims.html)
Extension of Gewirtz Graph and 77 Graph -- comes from Witt Design

Consider as vertices the 77 vectors ($v \in V$), 22 points ($p \in P$), and new symbol $\Omega$. Set edges such that $\Omega$ is adjacent to all $p$, $p \& v$ are adjacent if $p \in v$, and $v_j \& v_k$ are adjacent if they share no terms.  The resulting 100 vertex graph is the \href{Higman-Sims graph}.

Length[vecs=Rest/@Select[WittDesign,Length[#]==7&&MemberQ[#,1]&]-1]

hs1=Union[Sort/@Position[Outer[List,vecs,vecs,1],_?(Intersection@@#==={}&),2]];
hs2=Most/@Cases[Flatten[Table[{n,m+77,MemberQ[vecs[[n]],m]},{n,77},{m,22}],1],{_,_,True}];
hs3={#,100}&/@Range[78,99];

Length/@{hs1,hs2,hs3}

FromUnorderedPairs[Join[hs1,hs2,hs3]]

FastIsomorphicQ[%,Graph["HigmanSimsGraph"]]

Witt Design Ed

jj = Drop[#,1]&/@Take[Sort[WittDesign],77]-1;
hs1 =Drop[Union[Flatten[Table[If[Intersection[jj[[m]],jj[[n]]]=={},{n,m},{}],{n,76},{m,n+1,77}],1]],1];
hs2 = Drop[Union[Flatten[Table[If[Intersection[jj[[n]],{m-77}]!={},{n,m},{}],{n,77},{m,78,99}],1]],1];
hs3 =Table[{m,100},{m,78,99}];

Length/@{hs1,hs2,hs3}

Take[#,2]&/@{hs1,hs2,hs3}

HigmanSimsGraph = FromUnorderedPairs[Flatten[{hs1,hs2,hs3},1]]

FastIsomorphicQ[%,Graph["HigmanSimsGraph"]]

distanceregular.org

g=DistanceRegularGraph["http://www.distanceregular.org/graphdata/higmansims.am"]

RecognizeGraph[g]

VertexCount[g]

GraphDiameter[g]//Timing

RegularParameters[g]//Timing

DistanceRegularGraphQ[g]//Timing

IntersectionArray[g]//Timing

IntegerSpectrum[g]//SpectrumForm

GroupOrder[GraphAutomorphismGroup[g]]

HamiltonianGraphQ[g]

From M22 graph

https://en.wikipedia.org/wiki/Higman%E2%80%93Sims_graph#From_M22_graph

Take the M22 graph, a strongly regular graph srg(77,16,0,4) and augment it with 22 new vertices corresponding to the points of S(3,6,22), each block being connected to its points, and one additional vertex C connected to the 22 points.

From Hoffman-Singleton graph

https://en.wikipedia.org/wiki/Higman%E2%80%93Sims_graph#From_Hoffman–Singleton_graph

There are 100 independent sets of size 15 in the Hoffman–Singleton graph. Create a new graph with 100 corresponding vertices, and connect vertices whose corresponding independent sets have exactly 0 or 8 elements in common. The resulting Higman–Sims graph can be partitioned into two copies of the Hoffman–Singleton graph in 352 ways.

Length[v=FindIndependentVertexSet[GraphData["HoffmanSingletonGraph"],{15},All]]//Timing

Length[e=Select[Subsets[v,{2}],MatchQ[Length[Intersection@@#],0|8]&]]

RecognizeGraph[g=Graph[v,UndirectedEdge@@@e]]

From a cube

https://en.wikipedia.org/wiki/Higman%E2%80%93Sims_graph#From_a_cube

(2, (Sqrt[6]), (Sqrt[6])) Leech lattice construction

https://cp4space.hatsya.com/2013/09/12/leech-lattice/

https://en.wikipedia.org/wiki/Higman%E2%80%93Sims_graph#Inside_the_Leech_lattice

LatticeData["Leech","Basis"]

Norm/@%

Take three lattice points that form the vertices of a triangle with side lengths of {2, √6, √6}. There are 100 lattice points of minimal distance 2 from all three of these three vertices. Consider these 100 points, and join two points with an edge if the distance is √6. The result is the Higman-Sims graph on 100 vertices

Sort[{2,(Sqrt[6]),(Sqrt[6])}]

Length[v=LatticeData["Leech","Basis"]//Normal]

tri=SelectFirst[Subsets[v,{3}],Sort[SquaredEuclideanDistance@@@Subsets[#,{2}]]=={4,6,6}&]

MemberQ[v,#]&/@tri

Micheal list (after offsetting first triangle vertex to origin)

Michel Trott
Mar. 27, 2022

basis=LatticeData["Leech","Basis"]//Normal;

triangle=SelectFirst[Subsets[basis,{3}],Sort[EuclideanDistance@@@Subsets[#,{2}]]=={2,Sqrt[6],Sqrt[6]}&]

coefficients=;

distances[p_]:=EuclideanDistance[#,p]&/@triangle

allPoints=Total[basis #]&/@coefficients;

Union[distances/@allPoints//FullSimplify]

Table[Together[FullSimplify@EuclideanDistance[allPoints[[i1]],allPoints[[i2]]]],{i1,Length[allPoints]},{i2,Length[allPoints]}]//Flatten//Tally

g=Graph[Cases[Flatten[Table[{Together[EuclideanDistance[allPoints[[i1]],allPoints[[i2]]]],i1\[UndirectedEdge]i2},{i1,Length[allPoints]},{i2,i1-1}],1],{Sqrt[6],_}][[All,2]]]

ToEntity[g]

Adding vectors

Clear[v,tri,step]

Length[v=2(Sqrt[2])LatticeData["Leech","Basis"]//Normal]

v

(((2(Sqrt[2])))^2)

tri=SelectFirst[Subsets[v,{3}],Sort[SquaredEuclideanDistance@@@Subsets[#,{2}]]==8{4,6,6}&]

Length[vs=Join[-v,v]]

cond[x_]:=AllTrue[tri,SquaredEuclideanDistance[#,x]==8 4&]

Length[step=Union[Flatten[Table[tri[[i]]+vs[[j]],{i,3},{j,48}],1]]]

Length[pts=Union@Simplify@Select[step,cond]]//Timing

Table[SquaredEuclideanDistance[pt,triv],{pt,pts},{triv,tri}]

Length[step=Union[step,Flatten[Table[step[[i]]+vs[[j]],{i,Length[step]},{j,48}],1]]]//Timing

Length[pts=Select[step,cond]]//Timing

Table[SquaredEuclideanDistance[pt,triv],{pt,pts},{triv,tri}]

Length[step=Union[step,Flatten[Table[step[[i]]+vs[[j]],{i,Length[step]},{j,48}],1]]]//Timing

MaxMemoryUsed[]/10^9. GB

Length[pts=Select[step,cond]]//Timing

pts

Table[SquaredEuclideanDistance[pt,triv],{pt,pts},{triv,tri}]

Length[step=Union[step,Flatten[Table[step[[i]]+vs[[j]],{i,Length[step]},{j,48}],1]]]//Timing

MaxMemoryUsed[]/10^9. GB

Length[pts=Select[step,cond]]//Timing

Length[step=Union[step,Flatten[Table[step[[i]]+vs[[j]],{i,Length[step]},{j,48}],1]]]//Timing

MaxMemoryUsed[]/10^9. GB

Length[pts=Select[step,cond]]//Timing

MaxMemoryUsed[]/10^9. GB

ByteCount[step]/10^9. GB

Length[step=Union[step,Flatten[Table[step[[i]]+vs[[j]],{i,Length[step]},{j,48}],1]]]//Timing

ByteCount[step]/10^9. GB

MaxMemoryUsed[]/10^9. GB

Length[pts=Select[step,cond]]//Timing

MaxMemoryUsed[]/10^9. GB

Length[step=Union[step,Flatten[Table[step[[i]]+vs[[j]],{i,Length[step]},{j,48}],1]]]//Timing

Select next points without storing them

Do[
If[!MemberQ[pts,pt=step[[i]]+vs[[j]]]&&cond[pt],
AppendTo[pts,pt];
Print["Points: ",Length[pts]]],
{i,Length[step]},
{j,48}];//Timing

pts

pts={{0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0},{2,2,2,0,0,0,0,2,0,0,0,2,0,0,0,2,-2,0,0,0,-2,0,0,0},{2,2,2,2,0,0,0,0,2,-2,-2,2,0,0,0,0,0,0,0,0,0,0,0,0},{2,2,2,2,0,0,0,0,2,2,2,2,0,0,0,0,0,0,0,0,0,0,0,0},{2,2,2,2,2,-2,-2,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0},{2,2,2,2,2,2,2,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0},{3,1,1,1,1,-1,-1,-1,1,-1,1,1,1,-1,1,1,1,-1,1,1,1,-1,1,1},{3,1,1,1,1,-1,-1,-1,1,1,-1,1,1,1,-1,1,1,1,-1,1,1,1,-1,1},{4,0,0,0,0,0,0,0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0},{4,0,0,0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0},{4,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0},{4,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0},{4,2,2,0,0,-2,2,0,2,0,0,2,2,0,0,2,0,0,0,0,0,0,0,0},{4,2,2,0,0,2,-2,0,2,0,0,2,2,0,0,2,0,0,0,0,0,0,0,0},{4,2,2,0,2,0,0,2,0,-2,2,0,2,0,0,2,0,0,0,0,0,0,0,0},{4,2,2,0,2,0,0,2,0,2,-2,0,2,0,0,2,0,0,0,0,0,0,0,0},{4,2,2,2,2,0,0,0,2,0,0,0,2,0,0,0,-2,0,0,0,2,0,0,0},{5,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1},{2,2,2,0,0,0,0,2,0,0,0,2,0,0,0,2,2,0,0,0,2,0,0,0},{5,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,-1,-1,-1,-1,-1,-1,-1,-1}};

Length[pts]

Table[SquaredEuclideanDistance[pt,triv],{pt,pts},{triv,tri}]//Flatten//Union

Eric compiled [doesn't seem to return any]

Using a compile function from Michael Trott, Mar 2022.  Does not seem to return any results after running for a day or so...

Length[v=2 Sqrt[2] LatticeData["Leech","Basis"]//Normal]

tri=SelectFirst[Subsets[v,{3}],Sort[SquaredEuclideanDistance@@@Subsets[#,{2}]]==8 {4,6,6}&]

cf=With[{basis=v,tri=tri},Compile[{},Module[{B=basis,T=tri,A,P,counter=0},
Do[counter++;
If[counter/1000000-Round[counter/1000000]==0,counter2=counter];
A={a01,a02,a03,a04,a05,a06,a07,a08,a09,a10,a11,a12,a13,a14,a15,a16,a17,a18,a19,a20,a21,a22,a23,a24};
P=Total[A*B];
If[(P-T[[1]]).(P-T[[1]])==32&&(P-T[[2]]).(P-T[[2]])==32&&(P-T[[3]]).(P-T[[3]])==32,Print[A]],
{a24,-1,1},{a23,-1,1},{a22,-1,1},{a21,-1,1},{a20,-1,1},{a19,-1,1},{a18,-1,1},{a17,-1,1},{a16,-1,1},{a15,-1,1},{a14,-1,1},{a13,-1,1},{a12,-1,1},{a11,-1,1},{a10,-1,1},{a09,-1,1},{a08,-1,1},{a07,-1,1},{a06,-1,1},{a05,-1,1},{a04,-1,1},{a03,-1,1},{a02,-1,1},{a01,-1,1}]]]]

3^24

Monitor[cf[],counter2]

Equations

Length[v=2(Sqrt[2])LatticeData["Leech","Basis"]//Normal]

v

tri=SelectFirst[Subsets[v,{3}],Sort[SquaredEuclideanDistance@@@Subsets[#,{2}]]==8{4,6,6}&]

Array[a,3]Array[b,3]

Total[Array[a,3]Array[b,3]]

Array[a,3].Array[b,3]

eqn=FullSimplify[32==SquaredEuclideanDistance[Array[a,24].v,#]&/@tri/.Abs->Identity]

solns=LinearSolve[Transpose[v],#]&/@pts

eqn[[All,1]]/.(Thread[Array[a,24]->#]//Expand)&/@solns

Thread[-2<Array[a,2]<2]

soln=FindInstance[Join[eqn,Thread[-2<Array[a,24]<2]],Array[a,24],Integers,2]

soln

Reduce[Thread[SquaredEuclideanDistance[Array[a,24].v,#]&/@tri==4]/.Abs->Identity,Array[a,24],Integers]

Bipartite double

Graph["HigmanSimsGraph"]

bpd=GraphBipartiteDouble[Graph["HigmanSimsGraph"]]

GraphPlot[bpd]

Spectrum[bpd]//SpectrumForm//TraditionalForm

GraphData

GraphClassString

GraphClassString["HigmanSimsGraph"]

GraphDataString

Higman-Sims

GraphDataString[HigmanSimsGraph,{"HigmanSimsGraph","Higman-Sims graph","HigmanSimsGraph"},TimeConstraint->10,Debug->True]

BipartiteDouble

file=OpenWrite["bpd.m"]

WriteString[file,GraphDataString[bpd,
"StandardName"->"HigmanSimsBipartiteDoubleGraph",
"Name"->"bipartite double of the Higman-Sims graph",
"Classes"->{"DistanceRegular","Integral"},
"Vertices"->None,
Debug->True,
TimeConstraint->60
]]