Graph Thickness

Author

Eric W. Weisstein
August 11, 2022

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

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

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

Graphic

Decomposition of (Subscript[K, 9]) into 3 planar graphs, illustrating a thickness of 3.

With[{
red=UndirectedEdge@@@{{2,3},{2,4},{2,6},{2,7},{2,9},{3,9},{4,6},{4,9},{5,7},{5,9},{6,9},{7,9}},
blue=UndirectedEdge@@@{{1,2},{1,5},{2,5},{2,8},{3,4},{3,5},{3,8},{4,5},{4,8},{5,6},{5,8},{6,8}},
green=UndirectedEdge@@@{{1,3},{1,4},{1,6},{1,7},{1,8},{1,9},{3,6},{3,7},{4,7},{6,7},{7,8},{8,9}},
v={{126,-940},{432,-485},{865,-575},{945,-240},{1000,580},{1195,-485},{1235,95},{1340,-895},{1880,-940}}
},
parts=Thread[Style@@#]&/@{{red,Red},{green,Green},{blue,Blue}};
GraphicsGrid[{
{"",g1=Graph[Range[9],Join@@parts,VertexCoordinates->v,VertexSize->.2,VertexStyle->Black],""},
gs=Graph[Range[9],#,VertexCoordinates->v,VertexSize->.2,VertexStyle->Black]&/@parts
}]
]

RecognizeGraph[g1]

PlanarGraphQ/@gs

RecognizeGraph/@gs

RecognizeGraph[ConnectedGraphComponents[gs[[1]]][[1]]]

GraphData[%,"Graph","All"]

V5

K9 =Graph[Flatten[{
red=Map[{#,EdgeColor->Red}&,{{2,3},{2,4},{2,6},{2,7},{2,9},{3,9},{4,6},{4,9},{5,7},{5,9},{6,9},{7,9}}],
blue=Map[{#,EdgeColor->Blue}&,{{1,2},{1,5},{2,5},{2,8},{3,4},{3,5},{3,8},{4,5},{4,8},{5,6},{5,8},{6,8}}],
green=Map[{#,EdgeColor->Green}&,{{1,3},{1,4},{1,6},{1,7},{1,8},{1,9},{3,6},{3,7},{4,7},{6,7},{7,8},{8,9}}]
},1],v={{{126.0,-940.0}},{{432,-485.0}},{{865.0,-575.0}},{{945.0,-240.0}},{{1000.0,580.0}},{{1195.0,-485.0}},{{1235.0,95.0}},{{1340.0,-895.0}},{{1880.0,-940.0}}}];

ShowGraphArray[{{{},K9,{}},
Graph[#,v]&/@{red,green,blue}},
VertexStyle->Disk[.05],AspectRatio->Automatic]

IsomorphicQ[K9,CompleteGraph[9]]

PlanarQ/@(Graph[#,v]&/@{red,green,blue})

{V[#],M[#],Ceiling[M[#]/(3V[#]-6)]}&[K9]

Parametrized family table

<<MathWorld`Graphs`

GraphDataCountTable["Thickness",Join[Thread[GraphClassesThatAreClass["Planar"]->000012],
Thread[{{"Grid",2}}->000012],{"Complete"->124156,"MoebiusLadder"->007395}]]

Parametrized families

Andrasfai

seq=Table[GraphData[{"Andrasfai",n},"Thickness"],{n,10}]

Antelope m×n

DeleteCases[Sort[Flatten[Table[{{m,n},XXX,GraphData[{"Antelope",{m,n}},"Thickness"]},{n,2,10},{m,2,n}],1]],{_,x_,x_}]

Antelope n×n

seq=Table[GraphData[{"Antelope",{n,n}},"Thickness"],{n,15}]

Antiprism

Entity["Graph",{"Antiprism",n}]["Thickness"]

seq=Table[GraphData[{"Antiprism",n},"Thickness"],{n,3,25}]

Apollonian

seq=Table[GraphData[{"Apollonian",n},"Thickness"],{n,6}]

Barbell

seq=Table[GraphData[{"Barbell",n},"Thickness"],{n,3,20}]

Bishop m×n

DeleteCases[Sort[Flatten[Table[{{m,n},0,GraphData[{"Bishop",{m,n}},"Thickness"]},{n,10},{m,n}],1]],{_,x_,x_}]

Bishop n×n

seq=Table[GraphData[{"Bishop",{n,n}},"Thickness"],{n,10}]

BlackBishop m×n

DeleteCases[Sort[Flatten[Table[{{m,n},Piecewise[{
{0,Min[m,n]==1||m==n==2},
{1,m==n==3},
{4,Min[m,n]==3&&Max[m,n]==4},
{Mod[m,2]+1,m==n},
{Max[m,n]-2,Min[m,n]==2},
{n+1,n==m+1},
{Min[m,n],Mod[Min[m,n],2]==0}
},XXX],GraphData[{"BlackBishop",{m,n}},"Thickness"]},{n,10},{m,n}],1]],{_,x_,x_}]

BlackBishop n×n

seq=Table[GraphData[{"BlackBishop",{n,n}},"Thickness"],{n,10}]

Book

seq=Table[GraphData[{"Book",n},"Thickness"],{n,20}]

Bruhat

seq=Table[GraphData[{"Bruhat",n},"Thickness"],{n,6}]

Table[n!,{n,6}]

Centipede

seq=Table[GraphData[{"Centipede",n},"Thickness"],{n,10}]

CocktailParty

seq=Table[GraphData[{"CocktailParty",n},"Thickness"],{n,20}]

Do[Print[{k,GraphThickness[CocktailPartyGraph[k]]//Timing}],{k,5}]

GraphThickness[CocktailPartyGraph[5],Debug->True]//Timing

Complete

A124156

Entity["Graph",{"Complete",n}]["Thickness"]

seq=Table[GraphData[{"Complete",n},"Thickness"],{n,20}]

seq=Table[Piecewise[{{3,n==9||n==10}},Floor[(n+7)/6]],{n,200}]

Do[Print[{k,FindLinearRecurrence[Drop[seq,k]]//Head//Timing}],{k,0,10}]

FindLinearRecurrence[Drop[seq,10]]

Do[Print[{i,GraphThickness[GraphData[{"Complete",i}]]//Timing,MaxMemoryUsed[]1.*^-9,"GB"}],{i,8}]

GraphThickness[GraphData[{"Complete",8}],Debug->True]//Timing

CompleteBipartite m×n

Entity["Graph",{"CompleteBipartite",{m,n}}]["Thickness"]

ceiling is a typo for floor...

Sort@DeleteCases[Flatten[Table[{m,n,Reduce[Floor[((2r(m-2))/(m-2r))]==n,r,PositiveIntegers]},{n,3,129,2},{m,3,n,2}],1],{_,_,False}]

Sort[%]

Sort@Flatten[Table[{{m,n},GraphData[{"CompleteBipartite",{m,n}},"Thickness"]},{n,20},{m,n}],1]

GraphData[{"CompleteBipartite",{13,17}},"Thickness"]

GetGraphData[{"CompleteBipartite",{13,17}},"File"]

CompleteBipartite n×n

Entity["Graph",{"CompleteBipartite",{n,n}}]["Thickness"]

seq=Table[GraphData[{"CompleteBipartite",{n,n}},"Thickness"],{n,20}]

Table[Floor[(((n+5))/4)],{n,30}]

Do[Print[{i,GraphThickness[GraphData[{"CompleteBipartite",{i,i}}]]//Timing}],{i,2}]

CompleteTripartite k×m×n

Entity["Graph",{"CompleteTripartite",{k,m,n}}]["Thickness"]

DeleteCases[Flatten[Table[
{{k,m,n},
Piecewise[{
{0,k==m==n==1},
{3,k==m==n},
{2,Max[k,m,n]==k m n/(Max[k,m,n]Min[k,m,n])}
},1],
GraphData[{"CompleteTripartite",{k,m,n}},"Thickness"]
},{n,10},{m,n},{k,m}],2],{_,x_,x_}]

CompleteTripartite n×n×n

Entity["Graph",{"CompleteTripartite",{n,n,n}}]["Thickness"]

seq=Table[GraphData[{"CompleteTripartite",{n,n,n}},"Thickness"],{n,10}]

CrossedPrism

seq=Table[GraphData[{"CrossedPrism",2n},"Thickness"],{n,2,10}]

Crown

seq=Table[GraphData[{"Crown",n},"Thickness"],{n,3,20}]

CubeConnectedCycle

Entity["Graph",{"CubeConnectedCycle",n}]["Thickness"]

seq=Table[GraphData[{"CubeConnectedCycle",n},"Thickness"],{n,3,8}]

Cycle

Entity["Graph",{"Cycle",n}]["Thickness"]

seq=Table[GraphData[{"Cycle",n},"Thickness"],{n,3,20}]

CycleComplement

seq=Table[GraphData[{"CycleComplement",n},"Thickness"],{n,3,20}]

DiagonalIntersection

seq=Table[GraphData[{"DiagonalIntersection",n},"Thickness"],{n,3,14}]

Dipyramid

seq=Table[GraphData[{"Dipyramid",n},"Thickness"],{n,3,20}]

Empty

Entity["Graph",{"Empty",n}]["Thickness"]

seq=Table[GraphData[{"Empty",n},"Thickness"],{n,25}]

FibonacciCube

seq=Table[GraphData[{"FibonacciCube",n},"Thickness"],{n,15}]

Fiveleaper m×n

DeleteCases[Sort[Flatten[Table[{{m,n},0,GraphData[{"Fiveleaper",{m,n}},"Thickness"]},{n,10},{m,n}],1]],{_,x_,x_}]

Fiveleaper n×n

seq=Table[GraphData[{"Fiveleaper",{n,n}},"Thickness"],{n,10}]

Flower

seq=Table[GraphData[{"Flower",n},"Thickness"],{n,5,20}]

FoldedCube

seq=Table[GraphData[{"FoldedCube",n},"Thickness"],{n,2,10}]

Gear

seq=Table[GraphData[{"Gear",n},"Thickness"],{n,3,20}]

Goldberg

seq=Table[GraphData[{"Goldberg",n},"Thickness"],{n,3,20}]

Grid m×n

Entity["Graph",{"Grid",{m,n}}]["Thickness"]

Table[GraphData[{"Grid",{m,n}},"Thickness"],{n,10},{m,n}]

Grid n×n

Entity["Graph",{"Grid",{n,n}}]["Thickness"]

Table[GraphData[{"Grid",{n,n}},"Thickness"],{n,10}]

Grid k×m×n

Entity["Graph",{"Grid",{k,m,n}}]["Thickness"]

Table[GraphData[{"Grid",{k,m,n}},"Thickness"],{n,5},{m,n},{k,m}]

Grid n×n×n

Entity["Graph",{"Grid",{n,n,n}}]["Thickness"]

Table[GraphData[{"Grid",{n,n,n}},"Thickness"],{n,10}]

HalvedCube

seq=Table[GraphData[{"HalvedCube",n},"Thickness"],{n,10}]

Hanoi

seq=Table[GraphData[{"Hanoi",n},"Thickness"],{n,5}]

Helm

seq=Table[GraphData[{"Helm",n},"Thickness"],{n,3,20}]

HexagonalGrid n×n×n

seq=Table[GraphData[{"HexagonalGrid",{n,n,n}},"Thickness"],{n,5}]

Hypercube

Entity["Graph",{"Hypercube",n}]["Thickness"]

seq=Table[GraphData[{"Hypercube",n},"Thickness"],{n,0,10}]

Table[Ceiling[(n+1)/4],{n,20}]

GraphThickness[Graph[{"Hypercube",3}]]

Do[Print[{i,GraphThickness[GraphData[{"Hypercube",i}]]//Timing}],{i,2}]

Keller

Entity["Graph",{"Keller",n}]["Thickness"]

seq=Table[GraphData[{"Keller",n},"Thickness"],{n,5}]

King m×n

DeleteCases[Sort[Flatten[Table[{{m,n},XXX,GraphData[{"King",{m,n}},"Thickness"]},{n,10},{m,n}],1]],{_,x_,x_}]

King n×n

seq=Table[GraphData[{"King",{n,n}},"Thickness"],{n,10}]

Knight m×n

Entity["Graph",{"Knight",{m,n}}]["Thickness"]

DeleteCases[Sort[Flatten[Table[{{m,n},XXX,GraphData[{"Knight",{m,n}},"Thickness"]},{n,10},{m,n}],1]],{_,x_,x_}]

Knight n×n

Entity["Graph",{"Knight",{n,n}}]["Thickness"]

seq=Table[GraphData[{"Knight",{n,n}},"Thickness"],{n,20}]

Ladder

Entity["Graph",{"Ladder",n}]["Thickness"]

seq=Table[GraphData[{"Ladder",n},"Thickness"],{n,20}]

LadderRung

seq=Table[GraphData[{"LadderRung",n},"Thickness"],{n,20}]

MengerSponge

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

MoebiusLadder

A007395

Entity["Graph",{"MoebiusLadder",n}]["Thickness"]

seq=Table[GraphData[{"MoebiusLadder",n},"Thickness"],{n,3,25}]

Do[Print[{n,GraphThickness[MoebiusLadder[n]]//Timing}],{n,3,25}]

GraphThickness[MoebiusLadder[10],Debug->True]

Mycielski

Entity["Graph",{"Mycielski",n}]["Thickness"]

seq=Table[GraphData[{"Mycielski",n},"Thickness"],{n,10}]

Odd

Entity["Graph",{"Odd",n}]["Thickness"]

seq=Table[GraphData[{"Odd",n},"Thickness"],{n,7}]

Pan

seq=Table[GraphData[{"Pan",n},"Thickness"],{n,3,20}]

Path

Entity["Graph",{"Path",n}]["Thickness"]

seq=Table[GraphData[{"Path",n},"Thickness"],{n,20}]

PathComplement

seq=Table[GraphData[{"PathComplement",n},"Thickness"],{n,20}]

Prism

Entity["Graph",{"Prism",n}]["Thickness"]

seq=Table[GraphData[{"Prism",n},"Thickness"],{n,3,25}]

Queen m×n

DeleteCases[Sort[Flatten[Table[{
{m,n},
XXX,
GraphData[{"Queen",{m,n}},"Thickness"]},{n,10},{m,n}],1]],{_,x_,x_}]

DeleteCases[%,{_,_,_Missing}]

Queen n×n

seq=Table[GraphData[{"Queen",{n,n}},"Thickness"],{n,10}]

Rook m×n

DeleteCases[Sort[Flatten[Table[{{m,n},Piecewise[{{0,Min[m,n]==1},{(2^n)-2,Min[m,n]==2}},m n],GraphData[{"Rook",{m,n}},"Thickness"]},{n,10},{m,n}],1]],{_,x_,x_}]

Rook n×n

seq=Table[GraphData[{"Rook",{n,n}},"Thickness"],{n,10}]

RookComplement m×n

DeleteCases[Sort[Flatten[Table[{{m,n},XXX,GraphData[{"RookComplement",{m,n}},"Thickness"]},{n,10},{m,n}],1]],{_,x_,x_}]

RookComplement n×n

seq=Table[GraphData[{"RookComplement",{n,n}},"Thickness"],{n,10}]

SierpinskiCarpet

seq=Table[GraphData[{"SierpinskiCarpet",n},"Thickness"],{n,4}]

SierpinskiSieve

seq=Table[GraphData[{"SierpinskiSieve",n},"Thickness"],{n,5}]

SierpinskiTetrahedron

seq=Table[GraphData[{"SierpinskiTetrahedron",n},"Thickness"],{n,4}]

StackedBook n×n

seq=Table[GraphData[{"StackedBook",{n,n}},"Thickness"],{n,10}]

StackedPrism n×n

seq=Table[GraphData[{"StackedPrism",{n,n}},"Thickness"],{n,3,5}]

Star

Entity["Graph",{"Star",n}]["Thickness"]

seq=Table[GraphData[{"Star",n},"Thickness"],{n,25}]

Sun

seq=Table[GraphData[{"Sun",n},"Thickness"],{n,3,20}]

Sunlet

seq=Table[GraphData[{"Sunlet",n},"Thickness"],{n,3,20}]

Tetrahedral

seq=Table[GraphData[{"Tetrahedral",n},"Thickness"],{n,6,10}]

TorusGrid m×n

DeleteCases[Sort[Flatten[Table[{{m,n},XXX,GraphData[{"TorusGrid",{m,n}},"Thickness"]},{n,3,10},{m,3,n}],1]],{_,x_,x_}]

TorusGrid n×n

seq=Table[GraphData[{"TorusGrid",{n,n}},"Thickness"],{n,3,10}]

Transposition

Entity["Graph",{"Prism",n}]["Thickness"]

seq=Table[GraphData[{"Transposition",n},"Thickness"],{n,6}]

Triangular

seq=Table[GraphData[{"Triangular",n},"Thickness"],{n,2,10}]

TriangularGrid

seq=Table[GraphData[{"TriangularGrid",n},"Thickness"],{n,10}]

TriangularHoneycombAcuteKnight

seq=Table[GraphData[{"TriangularHoneycombAcuteKnight",n},"Thickness"],{n,20}]

TriangularHoneycombBishop

seq=Table[GraphData[{"TriangularHoneycombBishop",n},"Thickness"],{n,9}]

TriangularHoneycombKing

seq=Table[GraphData[{"TriangularHoneycombKing",n},"Thickness"],{n,11}]

TriangularHoneycombObtuseKnight

seq=Table[GraphData[{"TriangularHoneycombObtuseKnight",n},"Thickness"],{n,20}]

TriangularHoneycombQueen

seq=Table[GraphData[{"TriangularHoneycombQueen",n},"Thickness"],{n,10}]

TriangularHoneycombRook

seq=Table[GraphData[{"TriangularHoneycombRook",n},"Thickness"],{n,10}]

TriangularSnake

seq=Table[GraphData[{"TriangularSnake",n},"Thickness"],{n,1,20,2}]

Web

seq=Table[GraphData[{"Web",n},"Thickness"],{n,3,20}]

Wheel

Entity["Graph",{"Wheel",n}]["Thickness"]

seq=Table[GraphData[{"Wheel",n},"Thickness"],{n,4,20}]

WhiteBishop m×n

DeleteCases[Sort[Flatten[Table[{{m,n},XXX,GraphData[{"WhiteBishop",{m,n}},"Thickness"]},{n,2,10},{m,2,n}],1]],{_,x_,x_}]

WhiteBishop n×n

seq=Table[GraphData[{"WhiteBishop",{n,n}},"Thickness"],{n,2,10}]

Thickness

2

Select[GraphData[All],GraphData[#,"Thickness"]===2&]

3

Select[GraphData[All],GraphData[#,"Thickness"]===3&]

4

Select[GraphData[All],GraphData[#,"Thickness"]===4&]

{7, 1004} [2]

g=GraphData[{7,1004}]

GraphThickness[GraphData[{7,1004}],Debug->True]

e=EdgeList[g]

Length[e]

Length[subg=Select[Subsets[EdgeList[g],{14}],PlanarGraphQ[Graph[#]]&]]

SelectFirst[Subsets[subg,{2}],Union@@#===e&]

Length[subg=Select[Subsets[EdgeList[g],{13,14}],PlanarGraphQ[Graph[#]]&]]

pl=SelectFirst[Subsets[subg,{2}],Union@@#===e&]

Graph/@pl

PlanarGraphQ/@%

Union@@pl==e

{"Complete", 5} [2]

g=GraphData["K5"]

GraphThickness[g,Debug->True]

subg=Select[Rest[Subsets[EdgeList[g]]],PlanarGraphQ[Graph[#]]&];

SelectFirst[Subsets[subg,{2}],IsomorphicGraphQ[g,Graph[Union@@#]]&]

subg=Select[Subsets[EdgeList[g],{9}],PlanarGraphQ[Graph[#]]&];

SelectFirst[Subsets[subg,{2}],IsomorphicGraphQ[g,Graph[Union@@#]]&]

{"Complete", 6} [2]

g=GraphData["K6"]

GraphThickness[g,Debug->True]

subg=Select[Rest[Subsets[EdgeList[g]]],PlanarGraphQ[Graph[#]]&];

SelectFirst[Subsets[subg,{2}],IsomorphicGraphQ[g,Graph[Union@@#]]&]

subg=Select[Subsets[EdgeList[g],{9}],PlanarGraphQ[Graph[#]]&];

SelectFirst[Subsets[subg,{2}],IsomorphicGraphQ[g,Graph[Union@@#]]&]

{"Complete", 7} [2]

g=GraphData["K7"]

GraphThickness[g,Debug->True]

e=EdgeList[g]

Length[subg=Select[Subsets[EdgeList[g],{15}],PlanarGraphQ[Graph[#]]&]]

pl=SelectFirst[Subsets[subg,{2}],Union@@#===e&]

PlanarGraphQ/@(gr=Graph/@pl)

Union@@pl===e

{"Complete", 8} [2]

g=GraphData["K8"]

GraphThickness[g,Debug->True]

Binomial[223440,2]

{"Complete", 9} [3]

g=GraphData["K9"]

GraphThickness[g,Debug->True]

{"CompleteBipartite", {6, 6}} [2]

g=GraphData["K6,6"]

GraphThickness[g,Debug->True]

{"CompleteBipartite", {7, 7}} [3]

g=GraphData["K7,7"]

GraphThickness[g,Debug->True]

{"Quartic", {10, 41}} [2]

g=GraphData[{"Quartic",{10,41}}]

GraphThickness[g,Debug->True]

e=EdgeList[g]

Length[subg=Select[Subsets[EdgeList[g],{17,18}],PlanarGraphQ[Graph[#]]&]]

pl=SelectFirst[Subsets[subg,{2}],Union@@#===e&]

PlanarGraphQ/@(gs=Graph/@pl)

RecognizeGraph[GraphUnion@@gs]

{"Quartic", {10, 45}} [2]

g=GraphData[{"Quartic",{10,45}}]

GraphThickness[g,Debug->True]

e=EdgeList[g]

Length[e]

Length[subg=Select[Subsets[EdgeList[g],{17,18}],PlanarGraphQ[Graph[#]]&]]

SelectFirst[Subsets[subg,{2}],Union@@#===e&]

pl=SelectFirst[Subsets[subg,{2}],Union@@#===e&]

PlanarGraphQ/@(gs=Graph/@pl)

RecognizeGraph[GraphUnion@@gs]

{"Turan", {9, 5}}

g=GraphData[{"Turan",{9,5}}]

Out of memory on byblis68

Print[{#,MemoryConstrained[GraphThickness[GraphData[#],Debug->True],300*^9]//Timing}]&/@{{"Turan",{9,5}}};