Brouwer-Haemers Graph

Author

Eric W. Weisstein
October 17, 2018

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Brouwer-HaemersGraph.nb.

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

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

Embddings

GraphData["BrouwerHaemersGraph"]//StyleGraphs[#,VertexSize->.5,System`EdgeStyle->GrayLevel[.4]]&

2-D

GraphicsGrid[Partition[GraphData["BrouwerHaemersGraph","Image","All"],UpTo[4]],ImageSize->400]

3-D Embedding

Show[GraphData["BrouwerHaemersGraph","Image3D"]]

LCF

h=HamiltonianCycles[Graph[g="BrouwerHaemersGraph"],10^3];//Timing

Tally[Last/@(lcf=LCF[GraphData[g,"EdgeIndices"],h,All])]//Timing

Wikipedia

SVGToGraph["http://upload.wikimedia.org/wikipedia/commons/2/24/E7_graph.svg"]

System`CompleteGraph[4]//InputForm

iSVG[s_]:=Module[{e,v},
e=ToExpression[StringCases[s,RegularExpression["<line x1=\"(.*)\" y1=\"(.*)\" x2=\"(.*)\" y2=\"(.*)\""]:>{{"$1","$2"},{"$3","$4"}}]];
v=ToExpression[StringCases[s,RegularExpression["<circle cx=\"(.*)\" cy=\"(.*)\" r=\".*\""]:>{"$1","$2"}]];
System`Graph[Range[Length[v]],UndirectedEdge@@@(e/.Thread[v->Range[Length[v]]]),VertexCoordinates->v]
]

s=Import["http://upload.wikimedia.org/wikipedia/commons/b/b1/Brouwer_Haemers_graph.svg","String"]

(ss=Rest[StringSplit[s,"<g id=\"edges"]])//Length

RecognizeGraph/@(gs=iSVG/@ss)

CombinatoricaGraph[System`CompleteGraph[3]]

LCFEmbeddingQ/@CombinatoricaGraph/@gs

ToCommonEdges[#,GraphData["BrouwerHaemersGraph"]]&/@gs

Matrices

GraphDataMatrices["BrouwerHaemersGraph"]

Construction

distanceregular.org

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

VertexCount[g]

GraphDiameter[g]//Timing

RegularParameters[g]//Timing

IntersectionArray[g]//Timing

IntegerSpectrum[g]//SpectrumForm

GroupOrder[GraphAutomorphismGroup[g]]

HamiltonianGraphQ[g]

FiniteFields package

<<FiniteFields`

BH[q_Integer]:=Module[{gf=GF@@FactorInteger[q][[1]],pl,pow},
pl=PowerList[gf];
pow=Union[gf[#]^4&/@pl];
MakeGraph[Prepend[pl,0],MemberQ[pow,gf[#1] -gf[#2]]&,Type->Undirected]
]/;PrimePowerQ[q]

BH[81]

BH[81]//RecognizeGraph

Other QuarticResidueGraphs

QuarticResidueGraph[q_Integer]:=Module[{gf=GF@@FactorInteger[q][[1]],pl,sq},
pl=PowerList[gf];
sq=Union[gf[#]^4&/@pl];
MakeGraph[Prepend[pl,0],MemberQ[sq,gf[#1] -gf[#2]]&,Type->Undirected]
]/;PrimePowerQ[q]

l=Select[Range[100],PrimePowerQ]

RecognizeGraph/@QuarticResidueGraph/@l

Local GQ3,9

localgq39=DeleteVertices[g=Graph["GQ3,9"],Neighborhood[g,1,1]]

RecognizeGraph[localgq39]

DeleteVertices[g=Graph["GQ3,9"],Neighborhood[g,2,1]]//RecognizeGraph

From Scratch

by Oleksandr Pavlyk and Ed Pegg Jr  
This graph is the graph on GF(81) where two points are adjacent when their difference is a fourth power

p=3;n=4;

ideal[x_]:=(x^4)+ (x^3)+(x^2)+1

Check irreducibility:

Factor[ideal[x],Modulus->p]

GFPolyReduce[GFPoly[pol_,m_]]:=Block[{x},GFPoly[Function@@{PolynomialMod[Collect[pol[x],x,Mod[#,m]&],ideal[x],Modulus->m]/.x->#},m]]

GFPoly/:GFPoly[pol1_,m_]*GFPoly[pol2_,m_]:=GFPolyReduce[GFPoly[Function@@{pol1[#1]*pol2[#]},m]]

GFPoly/:GFPoly[pol1_,m_]+GFPoly[pol2_,m_]:=GFPolyReduce[GFPoly[Function@@{pol1[#1]+pol2[#]},m]]

GFPoly/:-GFPoly[pol1_,m_]:=GFPolyReduce[GFPoly[Function@@{-pol1[#1]},m]]

generators=Join[{GFPoly[0&,p]},Table[With[{k=k},GFPolyReduce[GFPoly[#^k&,p]]],{k,0,n}]]

Timing[Length[allelems=FixedPoint[Union[Flatten[Join[Outer[Times,#,#],Outer[Plus,#,#]]]]&,generators]]]

fourthpowers={GFPoly[0&,3],GFPoly[1&,3],GFPoly[2&,3],GFPoly[((#1)^2)&,3],GFPoly[2 ((#1)^2)&,3],GFPoly[1+#1+((#1)^2)&,3],GFPoly[2 #1+((#1)^2)&,3],GFPoly[#1+2 ((#1)^2)&,3],GFPoly[2+2 #1+2 ((#1)^2)&,3],GFPoly[1+((#1)^2)+((#1)^3)&,3],GFPoly[1+#1+((#1)^2)+((#1)^3)&,3],GFPoly[2+2 #1+((#1)^2)+((#1)^3)&,3],GFPoly[2+2 ((#1)^2)+((#1)^3)&,3],GFPoly[#1+2 ((#1)^2)+((#1)^3)&,3],GFPoly[2 #1+2 ((#1)^2)+((#1)^3)&,3],GFPoly[1+((#1)^2)+2 ((#1)^3)&,3],GFPoly[#1+((#1)^2)+2 ((#1)^3)&,3],GFPoly[2 #1+((#1)^2)+2 ((#1)^3)&,3],GFPoly[2+2 ((#1)^2)+2 ((#1)^3)&,3],GFPoly[1+#1+2 ((#1)^2)+2 ((#1)^3)&,3],GFPoly[2+2 #1+2 ((#1)^2)+2 ((#1)^3)&,3]};

BrouwerHaemersGraph :=Module[{v=Flatten[Table[If[MemberQ[fourthpowers,allelems[[a]]-allelems[[b]]],{a,b},Sequence@@{}],{a,80},{b,a+1,81}],1]},
Graph[List/@v,CircularEmbedding[Max[Flatten[v]]]]
]

GraphData

GraphClasses

GraphClassString["BrouwerHaemersGraph"]

GraphDataString

GraphDataString[BrouwerHaemersGraph,
"Name"->"Brouwer-Haemers graph",
"StandardName"->"BrouwerHaemersGraph",
"Skip"->{"Perfect"},
"Classes"->{"DeterminedBySpectrum","DistanceRegular"},
TimeConstraint->120,
Debug->True
]