Menger Sponge Graph

Author

Eric W. Weisstein
June 13, 2022

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/MengerSpongeGraph.nb.

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

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

References

https://mathematica.stackexchange.com/questions/223033/what-are-vertexes-edges-returned-by-graphdata-for-mengersponge

Graphic

GraphicsRow[Table[MengerSpongeGraph[n],{n,2}]]

Special Cases

DeleteCases[Table[{n,RecognizeGraph[MengerSpongeGraph[n]]},{n,3}],{_,{}}]//Column

Properties

mengers4=MengerSpongeGraph/@Range[4];//Timing

MaxMemoryUsed[]/10^9. GB

mengers5=MengerSpongeGraph/@Range[5];//Timing

MaxMemoryUsed[]/10^9. GB

Acyclic

seq=Table[GraphData[{"MengerSponge",n},"Acyclic"],{n,3}]

AdjacencyMatrixCount

seq=Table[GraphData[{"MengerSponge",n},"AdjacencyMatrixCount"],{n,2}]

Table[((((20^n))!)/48),{n,2}]

Arboricity

seq=Table[GraphData[{"MengerSponge",n},"Arboricity"],{n,3}]

ArcTransitive

seq=Table[GraphData[{"MengerSponge",n},"ArcTransitive"],{n,3}]

ArcTransitivity

seq=Table[GraphData[{"MengerSponge",n},"ArcTransitivity"],{n,3}]

AutomorphismCount

seq=GroupOrder[GraphAutomorphismGroup[#]]&/@Take[mengers,4]

ConnectedInducedSubgraphCount

seq=Table[GraphData[{"MengerSponge",n},"ConnectedInducedSubgraphCount"],{n,3}]

BalabanIndex

seq=Table[GraphData[{"MengerSponge",n},"BalabanIndex"],{n,2}]

Bandwidth

seq=Table[GraphData[{"MengerSponge",n},"Bandwidth"],{n,3}]

BridgeCount

seq=Table[GraphData[{"MengerSponge",n},"BridgeCount"],{n,3}]

BurningNumber

seq=Table[GraphData[{"MengerSponge",n},"BurningNumber"],{n,3}]

CharacteristicPolynomial

(poly=Table[GraphData[{"MengerSponge",n},"CharacteristicPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x])//Column

coef=Factor/@FindLinearRecurrence[poly]

ToPolynomialRecurrence[p,x,n,coef]

FormattedPolynomialRecurrence[p,x,n,coef]//TraditionalForm

TeXForm[%]

LinearRecurrence[coef,poly,{2-k0,Length[coef]-k0+1}]

FullSimplify[RSolve[Prepend[Table[p[k+k0-1,x]==poly[[k]],{k,Length[coef]}],ToPolynomialRecurrence[p,x,n,coef]],p[n,x],n],n∈Integers&&n>0]

gf=Factor[(z^k0)FindGeneratingFunction[poly,z]]

FullSimplify[SeriesCoefficient[gf,{z,0,n}],n>0]

Factor[Take[poly2-poly,kmax-k0-Count[poly,_Missing]+1]]

FullSimplify[poly2-poly]

Chordal

seq=Table[GraphData[{"MengerSponge",n},"Chordal"],{n,3}]

ChordCount

seq=Table[GraphData[{"MengerSponge",n},"ChordCount"],{n,3}]

Chordless

seq=Table[GraphData[{"MengerSponge",n},"Chordless"],{n,3}]

ChordlessCycleCount

seq=Table[GraphData[{"MengerSponge",n},"ChordlessCycleCount"],{n,3}]

FindSequenceFunction[seq,n]

Chords

seq=Table[GraphData[{"MengerSponge",n},"Chords"],{n,3}]

ChromaticallyUnique

seq=Table[GraphData[{"MengerSponge",n},"ChromaticallyUnique"],{n,3}]

ChromaticInvariant

seq=Table[GraphData[{"MengerSponge",n},"ChromaticInvariant"],{n,3}]

ChromaticNumber

seq=Table[GraphData[{"MengerSponge",n},"ChromaticNumber"],{n,3}]

ChromaticPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"ChromaticPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

Circumference

seq=Table[GraphData[{"MengerSponge",n},"Circumference"],{n,3}]

Classes

Intersection@@(GraphData[#,"Classes"]&/@GraphData["MengerSponge"])

CliqueCount

A292209

seq=Table[GraphData[{"MengerSponge",n},"CliqueCount"],{n,3}]

FullSimplify[1+(20^n)x+2^(2n+1)(5^n-2^n)(x^2)/.x->1]

seq=Table[3 (20^n)-2 (8^n)+1,{n,20}]

FindLinearRecurrence[seq]

LinearRecurrence[{29,-188,160},{45,1073,22977},20]

gf=x FindGeneratingFunction[seq,x]

CoefficientList[Series[((-45+232 x-320 (x^2))/(-1+29 x-188 (x^2)+160 (x^3))),{x,0,20}],x]

CliqueCoveringNumber

seq=Table[GraphData[{"MengerSponge",n},"CliqueCoveringNumber"],{n,3}]

CliqueNumber

seq=Table[GraphData[{"MengerSponge",n},"CliqueNumber"],{n,3}]

CliquePolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"CliquePolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

Table[1+(20^n)x+2^(2n+1)(5^n-2^n)(x^2),{n,3}]//Column

CochromaticGraphNames

Table[GraphData[{"MengerSponge",n},"CochromaticGraphNames"],{n,3}]//Column

Select[GraphData["MengerSponge"],GraphData[#,"ChromaticallyUnique"]=!=False&]

ComplementOddChordlessCycleCount

seq=Table[GraphData[{"MengerSponge",n},"ComplementOddChordlessCycleCount"],{n,3}]

ConnectedComponentCount

seq=Table[GraphData[{"MengerSponge",n},"ConnectedComponentCount"],{n,3}]

ConnectedDominatingSetCount

seq=Table[GraphData[{"MengerSponge",n},"ConnectedDominatingSetCount"],{n,3}]

FindSequenceFunction[seq,n]

ConnectedDominationNumber

seq=Table[GraphData[{"MengerSponge",n},"ConnectedDominationNumber"],{n,3}]

FindSequenceFunction[seq,n]

ConnectedDominationPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"ConnectedDominationPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

coef=Factor/@FindLinearRecurrence[poly]

ToPolynomialRecurrence[p,x,n,coef]

FormattedPolynomialRecurrence[p,x,n,coef]//TraditionalForm

TeXForm[%]

LinearRecurrence[coef,poly,{2-k0,Length[coef]-k0+1}]

FullSimplify[RSolve[Prepend[Table[p[k+k0-1,x]==poly[[k]],{k,Length[coef]}],ToPolynomialRecurrence[p,x,n,coef]],p[n,x],n],n∈Integers&&n>0]

gf=Factor[(z^k0)FindGeneratingFunction[poly,z]]

FullSimplify[SeriesCoefficient[gf,{z,0,n}],n>0]

Factor[Take[poly2-poly,kmax-k0-Count[poly,_Missing]+1]]

FullSimplify[poly2-poly]

ConnectedInducedSubgraphCount

seq=Table[GraphData[{"MengerSponge",n},"ConnectedInducedSubgraphCount"],{n,3}]

FindSequenceFunction[DeleteMissing[seq],n]

ConnectedInducedSubgraphPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"CharacteristicPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

coef=Factor/@FindLinearRecurrence[poly]

ToPolynomialRecurrence[p,x,n,coef]

FormattedPolynomialRecurrence[p,x,n,coef]//TraditionalForm

TeXForm[%]

LinearRecurrence[coef,poly,{2-k0,Length[coef]-k0+1}]

FullSimplify[RSolve[Prepend[Table[p[k+k0-1,x]==poly[[k]],{k,Length[coef]}],ToPolynomialRecurrence[p,x,n,coef]],p[n,x],n],n∈Integers&&n>0]

gf=Factor[(z^k0)FindGeneratingFunction[poly,z]]

FullSimplify[SeriesCoefficient[gf,{z,0,n}],n>0]

poly2=Table[XXX,{n,3}]

FullSimplify[poly2-poly]

CrossingNumber

seq=Table[GraphData[{"MengerSponge",n},"CrossingNumber"],{n,3}]

CycleCount

seq=Table[GraphData[{"MengerSponge",n},"CycleCount"],{n,3}]

CyclePolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"CyclePolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

coef=Factor/@FindLinearRecurrence[poly]

ToPolynomialRecurrence[p,x,n,coef]

FormattedPolynomialRecurrence[p,x,n,coef]//TraditionalForm

TeXForm[%]

LinearRecurrence[coef,poly,{2-k0,Length[coef]-k0+1}]

FullSimplify[RSolve[Prepend[Table[p[k+k0-1,x]==poly[[k]],{k,Length[coef]}],ToPolynomialRecurrence[p,x,n,coef]],p[n,x],n],n∈Integers&&n>0]

gf=Factor[(z^k0)FindGeneratingFunction[poly,z]]

FullSimplify[SeriesCoefficient[gf,{z,0,n}],n>0]

Factor[Take[poly2-poly,kmax-k0-Count[poly,_Missing]+1]]

FullSimplify[poly2-poly]

Cyclic

Table[GraphData[{"MengerSponge",n},"Cyclic"],{n,3}]

CyclomaticNumber

seq=Table[GraphData[{"MengerSponge",n},"CyclomaticNumber"],{n,3}]

FullSimplify[(2^(1+2 n)) (-(2^n)+(5^n))-(20^n)+1]

Table[(20^n)-2 (8^n)+1,{n,3}]

DetourIndex

seq=Table[GraphData[{"MengerSponge",n},"DetourIndex"],{n,3}]

FindSequenceFunction[seq,n]

DetourMatrix

MatrixForm/@Table[GraphData[{"MengerSponge",n},"DetourMatrix"],{n,3}]

MatrixForm/@Table[SparseArray[{i_,j_}:>Abs[i-j],n],{n,3}]

DetourPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"DetourPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

coef=Factor/@FindLinearRecurrence[poly]

ToPolynomialRecurrence[p,x,n,coef]

FormattedPolynomialRecurrence[p,x,n,coef]//TraditionalForm

TeXForm[%]

LinearRecurrence[coef,poly,{2-k0,Length[coef]-k0+1}]

FullSimplify[RSolve[Prepend[Table[p[k+k0-1,x]==poly[[k]],{k,Length[coef]}],ToPolynomialRecurrence[p,x,n,coef]],p[n,x],n],n∈Integers&&n>0]

gf=Factor[(z^k0)FindGeneratingFunction[poly,z]]

FullSimplify[SeriesCoefficient[gf,{z,0,n}],n>0]

Factor[Take[poly2-poly,kmax-k0-Count[poly,_Missing]+1]]

FullSimplify[poly2-poly]

Diameter

seq=Table[GraphData[{"MengerSponge",n},"Diameter"],{n,3}]

Do[Print[{n,GraphDiameter[MengerSpongeGraph[n]]//Timing}],{n,4}]

DistanceMatrix

MatrixForm/@Table[GraphData[{"MengerSponge",n},"DistanceMatrix"],{n,3}]

MatrixForm/@Table[SparseArray[{i_,j_}:>Abs[i-j],n],{n,3}]

DistancePolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"DistancePolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

coef=Factor/@FindLinearRecurrence[poly]

ToPolynomialRecurrence[p,x,n,coef]

FormattedPolynomialRecurrence[p,x,n,coef]//TraditionalForm

TeXForm[%]

LinearRecurrence[coef,poly,{2-k0,Length[coef]-k0+1}]

FullSimplify[RSolve[Prepend[Table[p[k+k0-1,x]==poly[[k]],{k,Length[coef]}],ToPolynomialRecurrence[p,x,n,coef]],p[n,x],n],n∈Integers&&n>0]

gf=Factor[(z^k0)FindGeneratingFunction[poly,z]]

FullSimplify[SeriesCoefficient[gf,{z,0,n}],n>0]

Factor[Take[poly2-poly,kmax-k0-Count[poly,_Missing]+1]]

FullSimplify[poly2-poly]

DistinguishingNumber

seq=Table[GraphData[{"MengerSponge",n},"DistinguishingNumber"],{n,3}]

DomaticNumber

Possibly 3 for n >= 2

seq=Table[GraphData[{"MengerSponge",n},"DomaticNumber"],{n,3}]

DominatingSetCount

seq=Table[GraphData[{"MengerSponge",n},"DominatingSetCount"],{n,3}]

DominationNumber

seq=Table[GraphData[{"MengerSponge",n},"DominationNumber"],{n,3}]

DominationPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"DominationPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

EdgeChromaticNumber

Probably 6 for n > 1

seq=Table[GraphData[{"MengerSponge",n},"EdgeChromaticNumber"],{n,3}]

EdgeConnectivity

Table[GraphData[{"MengerSponge",n},"EdgeConnectivity"],{n,3}]

EdgeCount

A291066

seq=EdgeCount/@mengers

FindLinearRecurrence[seq]

seq=LinearRecurrence[{28,-160},{24,672},20]

FindSequenceFunction[seq,n]//FullSimplify

Table[(2^(2n+1))((5^n)-(2^n)),{n,20}]

Table[2 (4^n)((5^n)-(2^n)),{n,20}]

gf=x FindGeneratingFunction[seq,x]

CoefficientList[Series[(24/(1-28 x+160 (x^2))),{x,0,20}],x]

EdgeCoverCount

seq=Table[GraphData[{"MengerSponge",n},"EdgeCoverCount"],{n,3}]

EdgeCoverNumber

seq=Table[GraphData[{"MengerSponge",n},"EdgeCoverNumber"],{n,3}]

FindSequenceFunction[seq,n]

x FindGeneratingFunction[seq,x]

EdgeCoverPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"EdgeCoverPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

EulerianCycleCount

seq=Table[GraphData[{"MengerSponge",n},"EulerianCycleCount"],{n,3}]

FaceCount

seq=Table[GraphData[{"MengerSponge",n},"FaceCount"],{n,3}]

FlowPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"FlowPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

FractionalChromaticNumber

Praobably 2

seq=Table[GraphData[{"MengerSponge",n},"FractionalChromaticNumber"],{n,3}]

FractionalEdgeChromaticNumber

seq=Table[GraphData[{"MengerSponge",n},"FractionalEdgeChromaticNumber"],{n,3}]

Girth

seq=Table[GraphData[{"MengerSponge",n},"Girth"],{n,3}]

Gonality

seq=Table[GraphData[{"MengerSponge",n},"Gonality"],{n,3}]

HamiltonConnected

seq=Table[GraphData[{"MengerSponge",n},"HamiltonConnected"],{n,3}]

HamiltonDecompositionCount

seq=Table[GraphData[{"MengerSponge",n},"HamiltonDecompositionCount"],{n,3}]

Hamiltonian

Table[GraphData[{"MengerSponge",n},"Hamiltonian"],{n,3}]

HamiltonianCycleCount

seq=Table[GraphData[{"MengerSponge",n},"HamiltonianCycleCount"],{n,3}]

HamiltonianNumber

seq=Table[GraphData[{"MengerSponge",n},"HamiltonianNumber"],{n,3}]

HamiltonianPathCount

seq=Table[GraphData[{"MengerSponge",n},"HamiltonianPathCount"],{n,3}]

HamiltonianWalkCount

seq=Table[GraphData[{"MengerSponge",n},"HamiltonianWalkCount"],{n,3}]

HararyIndex

seq=Table[GraphData[{"MengerSponge",n},"HararyIndex"],{n,3}]

HexagonCount

A292075

seq=Table[GraphData[{"MengerSponge",n},"HexagonCount"],{n,3}]

(seq=CycleCount[#,6]&/@mengers)//Timing

FindLinearRecurrence[seq]

FindSequenceFunction[seq]

gf=x FindGeneratingFunction[seq,x]

IdiosyncraticPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"IdiosyncraticPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x,y]])//Column

IndependenceNumber

seq=Table[GraphData[{"MengerSponge",n},"IndependenceNumber"],{n,3}]

IndependencePolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"IndependencePolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

IndependenceRatio

seq=Table[GraphData[{"MengerSponge",n},"IndependenceRatio"],{n,3}]

IndependentEdgeSetCount

seq=Table[GraphData[{"MengerSponge",n},"IndependentEdgeSetCount"],{n,3}]

IndependentVertexSetCount

seq=Table[GraphData[{"MengerSponge",n},"IndependentVertexSetCount"],{n,3}]

IntersectionNumber

seq=Table[GraphData[{"MengerSponge",n},"IntersectionNumber"],{n,3}]

IrredundancePolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"IrredundancePolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

IrredundantSetCount

seq=Table[GraphData[{"MengerSponge",n},"IrredundantSetCount"],{n,3}]

KirchhoffIndex

seq=Table[GraphData[{"MengerSponge",n},"KirchhoffIndex"],{n,3}]

KirchhoffSumIndex

seq=Table[GraphData[{"MengerSponge",n},"KirchhoffSumIndex"],{n,3}]

LaplacianMatrix

MatrixForm/@Table[GraphData[{"MengerSponge",n},"LaplacianMatrix"],{n,3}]

LaplacianPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"LaplacianPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

LeafCount

seq=Table[GraphData[{"MengerSponge",n},"LeafCount"],{n,3}]

LongestCycleCount

seq=Table[GraphData[{"MengerSponge",n},"LongestCycleCount"],{n,3}]

LovaszNumber

seq=Table[GraphData[{"MengerSponge",n},"LovaszNumber"],{n,3}]

MatchingGeneratingPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"MatchingGeneratingPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

MatchingNumber

seq=Table[GraphData[{"MengerSponge",n},"MatchingNumber"],{n,3}]

MatchingPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"MatchingPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

MaximalCliqueCount

===EdgeCount

A291066

seq=Table[GraphData[{"MengerSponge",n},"MaximalCliqueCount"],{n,3}]

FindSequenceFunction[seq,n]

SeriesCoefficient[FindGeneratingFunction[seq,x],{x,0,n}]

MaximalIndependentEdgeSetCount

seq=Table[GraphData[{"MengerSponge",n},"MaximalIndependentEdgeSetCount"],{n,3}]

MaximalIndependentVertexSetCount

seq=Table[GraphData[{"MengerSponge",n},"MaximalIndependentVertexSetCount"],{n,3}]

MaximalIrredundantSetCount

seq=Table[GraphData[{"MengerSponge",n},"MaximalIrredundantSetCount"],{n,3}]

MaximalIrredundantSetSignature

seq=Table[GraphData[{"MengerSponge",n},"MaximalIrredundantSetSignature"],{n,3}]

MaximumCliqueCount

===EdgeCount

A291066

seq=Table[GraphData[{"MengerSponge",n},"MaximumCliqueCount"],{n,3}]

MaximumIndependentEdgeSetCount

seq=Table[GraphData[{"MengerSponge",n},"MaximumIndependentEdgeSetCount"],{n,3}]

MaximumIndependentVertexSetCount

seq=Table[GraphData[{"MengerSponge",n},"MaximumIndependentVertexSetCount"],{n,3}]

MaximumIrredundantSetCount

seq=Table[GraphData[{"MengerSponge",n},"MaximumIrredundantSetCount"],{n,3}]

MaximumLeafNumber

seq=Table[GraphData[{"MengerSponge",n},"MaximumLeafNumber"],{n,3}]

MaximumVertexDegree

seq=Table[GraphData[{"MengerSponge",n},"MaximumVertexDegree"],{n,3}]

Max[VertexDegree[#]]&/@mengers5

MeanDistance

MeanDistance/@Take[mengers,3]

MinimalDominatingSetCount

seq=Table[GraphData[{"MengerSponge",n},"MinimalDominatingSetCount"],{n,3}]

MinimalDominatingSetSignature

seq=Table[GraphData[{"MengerSponge",n},"MinimalDominatingSetSignature"],{n,3}]

MinimalEdgeCoverCount

seq=Table[GraphData[{"MengerSponge",n},"MinimalEdgeCoverCount"],{n,3}]

MinimalEdgeCoverSignature

seq=Table[GraphData[{"MengerSponge",n},"MinimalEdgeCoverSignature"],{n,3}]

MinimumCliqueCoveringCount

seq=Table[GraphData[{"MengerSponge",n},"MinimumCliqueCoveringCount"],{n,3}]

MinimumConnectedDominatingSetCount

seq=Table[GraphData[{"MengerSponge",n},"MinimumConnectedDominatingSetCount"],{n,3}]

FindSequenceFunction[seq,n]

MinimumDistinguishingLabelingCount

seq=Table[GraphData[{"MengerSponge",n},"MinimumDistinguishingLabelingCount"],{n,3}]

MinimumDominatingSetCount

seq=Table[GraphData[{"MengerSponge",n},"MinimumDominatingSetCount"],{n,3}]

MinimumEdgeCoverCount

seq=Table[GraphData[{"MengerSponge",n},"MinimumEdgeCoverCount"],{n,3}]

MinimumVertexDegree

seq=Table[GraphData[{"MengerSponge",n},"MinimumVertexDegree"],{n,3}]

Min[VertexDegree[#]]&/@mengers5

MolecularTopologicalIndex

seq=Table[GraphData[{"MengerSponge",n},"MolecularTopologicalIndex"],{n,3}]

FindSequenceFunction[seq,n]

FindGeneratingFunction[seq,x]//Factor

Nonhamiltonian

Table[GraphData[{"MengerSponge",n},"Nonhamiltonian"],{n,3}]

NormalizedLaplacianMatrix

MatrixForm/@Table[GraphData[{"MengerSponge",n},"NormalizedLaplacianMatrix"],{n,3}]

OddChordlessCycleCount

seq=Table[GraphData[{"MengerSponge",n},"OddChordlessCycleCount"],{n,3}]

PathCount

seq=Table[GraphData[{"MengerSponge",n},"PathCount"],{n,3}]

PathPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"PathPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

PentagonCount

seq=Table[GraphData[{"MengerSponge",n},"PentagonCount"],{n,3}]

(seq=CycleCount[#,5]&/@mengers)//Timing

Perfect

Table[GraphData[{"MengerSponge",n},"Perfect"],{n,3}]

ProjectivePlaneCrossingNumber

seq=Table[GraphData[{"MengerSponge",n},"ProjectivePlaneCrossingNumber"],{n,3}]

Radius

seq=Table[GraphData[{"MengerSponge",n},"Radius"],{n,3}]

Do[Print[{{"MengerSponge",n},System`GraphRadius[MengerSpongeGraph[n]]//Timing}],{n,5}]

Uses > 380 GB

RankPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"RankPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x,y]])//Column

RectilinearCrossingNumber

seq=Table[GraphData[{"MengerSponge",n},"RectilinearCrossingNumber"],{n,3}]

ReliabilityPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"ReliabilityPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

SigmaPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"SigmaPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

Skewness

seq=Table[GraphData[{"MengerSponge",n},"Skewness"],{n,3}]

SpanningTreeCount

seq=Table[GraphData[{"MengerSponge",n},"SpanningTreeCount"],{n,2}]

SquareCount

A292076

seq=Table[GraphData[{"MengerSponge",n},"SquareCount"],{n,3}]

(seq=CycleCount[#,4]&/@mengers)//Timing

Do[Print[{{"MengerSponge",n},CycleCount[MengerSpongeGraph[n],4]//Timing}],{n,6}]

MaxMemoryUsed[]/10^9.GB

seq={0,192,5952,137664,2907456,59398080};

FindLinearRecurrence[seq]

FindSequenceFunction[seq]

gf=x FindGeneratingFunction[seq,x]

StabilityIndex

seq=Table[GraphData[{"MengerSponge",n},"StabilityIndex"],{n,3}]

TopologicalIndex

seq=Table[GraphData[{"MengerSponge",n},"TopologicalIndex"],{n,3}]

ToroidalCrossingNumber

seq=Table[GraphData[{"MengerSponge",n},"ToroidalCrossingNumber"],{n,3}]

Traceable

Table[GraphData[{"MengerSponge",n},"Traceable"],{n,3}]

TriangleCount

seq=Table[GraphData[{"MengerSponge",n},"TriangleCount"],{n,3}]

(seq=Monitor[Table[CycleCount[MengerSpongeGraph[n],3],{n,4}],n])//Timing

TuttePolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"TuttePolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x,y]])//Column

Untraceable

Table[GraphData[{"MengerSponge",n},"Untraceable"],{n,3}]

VertexConnectivity

Table[GraphData[{"MengerSponge",n},"VertexConnectivity"],{n,3}]

Do[Print[{{"MengerSponge",n},System`VertexConnectivity[MengerSpongeGraph[n]]//Timing}],{n,5}]

VertexCount

A009964

seq=Table[VertexCount[MengerSpongeGraph[n]],{n,4}]

FindLinearRecurrence[seq]

FindSequenceFunction[seq,n]

20^Range[0,10]

LinearRecurrence[{20},{1},20]

VertexCoverNumber

vertex cover number == vertex count - independence number

seq=Table[GraphData[{"MengerSponge",n},"VertexCoverNumber"],{n,3}]

VertexCoverPolynomial

(poly=Factor[Table[GraphData[{"MengerSponge",n},"VertexCoverPolynomial"],{n,k0=1,kmax=3}]/.f_Function:>f[x]])//Column

VertexDegrees

seq=Table[GraphData[{"MengerSponge",n},"VertexDegrees"],{n,1}]

WienerIndex

A292036

seq=Table[GraphData[{"MengerSponge",n},"WienerIndex"],{n,3}]

Do[Print[{{"MengerSponge",n},WienerIndex[MengerSpongeGraph[n]]//Timing}],{n,4}]

WienerSumIndex

seq=Table[GraphData[{"MengerSponge",n},"WienerSumIndex"],{n,3}]

Construction

By hand

MengerMesh[1,3]

v=PropertyValue[{MengerMesh[1,3],3},MeshCellCentroid];

Graphics3D[{Sphere[v,.2],MapIndexed[Text[#2[[1]],#]&,v]},Boxed->False]

c2=MeshCells[MengerMesh[1,3],3]

e=With[{c2=MeshCells[MengerMesh[1,3],3][[All,1]]},Select[Subsets[c2,{2}],Length[Intersection@@#]==4&]/.Thread[c2->Range[Length[c2]]]]

Graphics3D[{Sphere[v,.05],GraphicsComplex[v,Line[e]],MapIndexed[Text[#2[[1]],#]&,v]},Boxed->False]

Works, but too slow b/c of Subsets

MengerSpongeGraph1[n_Integer?Positive,opts___?OptionQ]:=Module[{mesh=MengerMesh[n,3],c2},
c2=MeshCells[mesh,3][[All,1]];
System`Graph[
Select[Subsets[c2,{2}],Length[Intersection@@#]==4&]/.Thread[c2->Range[Length[c2]]],
opts,
VertexCoordinates->PropertyValue[{mesh,3},MeshCellCentroid]
]]

Table[MengerMesh[n,3],{n,2}]

Table[MengerSpongeGraph1[n],{n,2}]

VertexCount/@Table[MengerSpongeGraph1[n],{n,2}]

MengerGraph[n_Integer?Positive,k_:2,opts___?OptionQ]:=Module[{mesh=MengerMesh[n,k],a},
a=mesh["ConnectivityMatrix"[k,k-1]];
System`Graph[
Range[If[k==2,8,20]^n],
UndirectedEdge@@@Sort[DeleteCases[UpperTriangularize[a.Transpose[a]]["NonzeroPositions"],{x_,x_}]],opts,VertexCoordinates->PropertyValue[{mesh,k},MeshCellCentroid]]]

MengerSpongeGraph2[n_]:=MengerGraph[n,3]

Table[MengerSpongeGraph2[n],{n,2}]

Too slow; cf. bug(335072)

MengerGraph3[n_Integer?Positive,k_:2,opts___?OptionQ]:=Module[{mesh=MengerMesh[n,k],a},
a=mesh["ConnectivityMatrix"[k,k-1]];
System`Graph[
Range[If[k==2,8,20]^n],
UndirectedEdge@@@Sort[DeleteCases[UpperTriangularize[a.Transpose[a]]["NonzeroPositions"],{x_,x_}]],opts,VertexCoordinates->RegionCentroid[MeshPrimitives[mesh,k]]]]

MengerSpongeGraph3[n_]:=MengerGraph3[n,3]

MengerSpongeGraph3[2]

VertexCount/@Table[MengerSpongeGraph2[n],{n,2}]

IsomorphicGraphQ[MengerSpongeGraph2[2],MengerSpongeGraph[2]]

RecognizeGraph/@Table[MengerSpongeGraph2[n],{n,3}]

Table[MengerSpongeGraph1[n]//Timing//First,{n,2}]

Table[MengerSpongeGraph2[n]//Timing//First,{n,4}]

Table[MengerSpongeGraph3[n]//Timing//First,{n,2}]

MeshConnectivityGraph (V12.1)

MeshConnectivityGraph[MengerMesh[1,3],3]

RecognizeGraph[%]

MeshConnectivityGraph[MengerMesh[2,3],3]

RecognizeGraph[%]

men=MengerMesh[2,3];
GraphPlot3D[GraphData[{"MengerSponge",2}],PerformanceGoal->"Speed",VertexCoordinates->(Mean[MeshCoordinates[men][[#]]]&/@MeshCells[men,3][[All,1]])]

Embeddings

{"MengerSponge", 1}

GraphData[{"MengerSponge",1},"StandardName"]

All

GraphData[{"MengerSponge",1},"Graph","All"]//StyleGraphs

Halin

GraphData[{"MengerSponge",1},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"MengerSponge",1},"LCFSignature"]

GraphData[{"MengerSponge",1},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"MengerSponge",1},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"MengerSponge",1}],Debug->True]//Timing

GraphData[{"MengerSponge",1},"Graph","UnitDistance"]//StyleGraphs

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"MengerSponge",1},"Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

FindUnitDistanceEmbedding[GraphData[{"MengerSponge",1}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

UnitDistance FindSubgraphUnitDistanceEmbedding

{{"MengerSponge",1},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"MengerSponge",1}],TimeConstraint->300,"Results"->All]//Timing}

gs=UniqueEmbeddings[l]

gs={,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,};

Matchstick

GraphData[{"MengerSponge",1},"Graph","Matchstick"]//StyleGraphs

MinimalCrossing

GraphData[{"MengerSponge",1},{"RCN","CN"}]

GraphData[{"MengerSponge",1},"Graph","MinimalCrossing"]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"MengerSponge",1},"Edges"]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

GraphLayout->"TutteEmbedding"

g1=System`Graph[v,e,GraphLayout->"TutteEmbedding",VertexLabels->"Name"]

Square/rotated square

GraphEmbedding[g1]//Chop[#,10^-4]&

emb1=6{{0,1},{1,1},{1,0},{0,2/3},{2/3,0},{0,1/3},{0.16666666666659086`,0.16671863997354944`},{0.33333333333325754`,0},{-1,1},{1,-1},{-0.1666666666665909`,0.16671863997354938`},{0.16666666666662877`,-0.16662335557747135`},{-1,0},{-1,-1},{0,-1},{-0.6666666666665909`,0},{0,-0.6666450111220453`},{-0.3333333333332576`,0},{-0.1666666666666288`,-0.1666233555774714`},{0,-0.333297240758996`}}//Round

System`Graph[v,e,VertexCoordinates->emb1,VertexLabels->"Name"]

Square/square

emb2={{0,6},{6,6},{6,0},{0,4},{4,0},{0,2},{2,2},{2,0},{-6,6},{6,-6},{-2,2},{2,-2},{-6,0},{-6,-6},{0,-6},{-4,0},{0,-4},{-2,0},{-2,-2},{0,-2}}/2

System`Graph[VertexList@MengerSpongeGraph[1],EdgeList@MengerSpongeGraph[1],VertexCoordinates->emb2,VertexLabels->"Name"]

Rotated octahedron/rotated square

emb3={{0,6},{6,6}/(Sqrt[2]),{6,0},{0,4},{4,0},{0,2},{1,1},{2,0},{-6,6}/(Sqrt[2]),{6,-6}/(Sqrt[2]),{-1,1},{1,-1},{-6,0},{-6,-6}/(Sqrt[2]),{0,-6},{-4,0},{0,-4},{-2,0},{-1,-1},{0,-2}}

System`Graph[v,e,VertexCoordinates->emb3,VertexLabels->"Name"]

Rotated octahedron/rotated octahedron

emb4={{0,6},{3 (Sqrt[2]),3 (Sqrt[2])},{6,0},{0,4},{4,0},{0,2},{1,1}(Sqrt[2]),{2,0},{-3 (Sqrt[2]),3 (Sqrt[2])},{3 (Sqrt[2]),-3 (Sqrt[2])},(Sqrt[2]){-1,1},(Sqrt[2]){1,-1},{-6,0},{-3 (Sqrt[2]),-3 (Sqrt[2])},{0,-6},{-4,0},{0,-4},{-2,0},(Sqrt[2]){-1,-1},{0,-2}}

System`Graph[v,e,VertexCoordinates->emb4,VertexLabels->"Name"]

Exact 3D

MengerSpongeGraph[1]

MinimalCrossing construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData[{"MengerSponge",1}],"CrossingNumber"->-1]]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData[{"MengerSponge",1},"Edges"]]

3D All

GraphData[{"MengerSponge",1},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"MengerSponge",1},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"MengerSponge",1},"Graph",{"3D","Polyhedron"}]

{"MengerSponge", 2}

GraphData[{"MengerSponge",2},"StandardName"]

All

GraphData[{"MengerSponge",2},"Graph","All"]//StyleGraphs

Halin

GraphData[{"MengerSponge",2},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"MengerSponge",2},"LCFSignature"]

GraphData[{"MengerSponge",2},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"MengerSponge",2},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"MengerSponge",2}],Debug->True]//Timing

GraphData[{"MengerSponge",2},"Graph","UnitDistance"]//StyleGraphs

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"MengerSponge",2},"Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

FindUnitDistanceEmbedding[GraphData[{"MengerSponge",2}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

UnitDistance FindSubgraphUnitDistanceEmbedding

{{"MengerSponge",2},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"MengerSponge",2}],TimeConstraint->300,"Results"->All]//Timing}

gs=UniqueEmbeddings[l]

Matchstick

GraphData[{"MengerSponge",2},"Graph","Matchstick"]//StyleGraphs

MinimalCrossing

GraphData[{"MengerSponge",2},{"RCN","CN"}]

GraphData[{"MengerSponge",2},"Graph","MinimalCrossing"]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"MengerSponge",2},"Edges"]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Exact 3D

MengerSpongeGraph[2]

MinimalCrossing construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData[{"MengerSponge",2}],"CrossingNumber"->-1]]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData[{"MengerSponge",2},"Edges"]]

3D All

GraphData[{"MengerSponge",2},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"MengerSponge",2},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"MengerSponge",2},"Graph",{"3D","Polyhedron"}]

{"MengerSponge", 3}

GraphData[{"MengerSponge",3},"StandardName"]

All

GraphData[{"MengerSponge",3},"Graph","All"]//StyleGraphs

Halin

GraphData[{"MengerSponge",3},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"MengerSponge",3},"LCFSignature"]

GraphData[{"MengerSponge",3},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"MengerSponge",3},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"MengerSponge",3}],Debug->True]//Timing

GraphData[{"MengerSponge",3},"Graph","UnitDistance"]//StyleGraphs

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"MengerSponge",3},"Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

FindUnitDistanceEmbedding[GraphData[{"MengerSponge",3}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

UnitDistance FindSubgraphUnitDistanceEmbedding

{{"MengerSponge",3},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"MengerSponge",3}],TimeConstraint->300,"Results"->All]//Timing}

gs=UniqueEmbeddings[l]

Matchstick

GraphData[{"MengerSponge",3},"Graph","Matchstick"]//StyleGraphs

MinimalCrossing

GraphData[{"MengerSponge",3},{"RCN","CN"}]

GraphData[{"MengerSponge",3},"Graph","MinimalCrossing"]//StyleGraphs

Default embedding

g=Graph@GraphData[{"MengerSponge",3},"Edges"]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

MinimalCrossing construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData[{"MengerSponge",3}],"CrossingNumber"->-1]]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData[{"MengerSponge",3},"Edges"]]

3D All

GraphData[{"MengerSponge",3},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"MengerSponge",3},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"MengerSponge",3},"Graph",{"3D","Polyhedron"}]

GraphData

GraphDataString

file=OpenWrite["~/mengersponge.m"]

Do[WriteString[file,GraphDataString[MengerSpongeGraph[n],
"StandardName"->{"MengerSponge",n},
"Name"->ToString[n]<>"\[Hyphen]Menger sponge graph",
"Embeddings"->None,
"Embeddings3D"->Automatic,
"EmbeddingClasses3D"->{{"Grid","Primary"}},
"AlternateNames"->{},
"AlternateStandardNames"->{},
"Classes"->{"MengerSponge"},
"Information"->"MengerSponge",
"NotationRules"->{"MengerSponge"->n},
"Skip"->{"Arboricity","CliqueCoveringNumber","Pancyclic","Skewness"},
Debug->True,
TimeConstraint->10
]],{n,3}]

Close[file]