Truncated Octahedral Graph

Author

Eric W. Weisstein
June 21, 2023

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

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

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

Graph

Names

GraphData["TruncatedOctahedralGraph","StandardName"]

GraphData["TruncatedOctahedralGraph","StandardNames"]

Primary

GraphData["TruncatedOctahedralGraph"]//StyleGraphs[#,ImageSize->Small]&

Construction from Read and Wilson

Rule[#,GraphData[#]]&/@GraphData["Polyhex"]

g0=CenterGraph@GraphData[{"Fusene",{4,4}},"Graph","Labeled"]

v=Join[GraphEmbedding[g0],Sequence@@Table[RotationMatrix[2Pi i/3].#&/@{v[[9]]+{-1/2,(Sqrt[3])/2},v[[12]]+{1/2,(Sqrt[3])/2}},{i,0,2}]];
ee=Join[EdgeList[g0],UndirectedEdge@@@{e[19,22,21,24,23,20,19,9],{12,20},{1,22},{2,21},{18,23},{16,24},{3,6},{15,17},{4,13}}];
g=Graph[Range@Length@v,ee,VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

v=Join@@{
3/10Through[{Cos,Sin}[2π#/6]]&/@Range[0,5],
5/10Through[{Cos,Sin}[2π#/6]]&/@Range[0,5],
7/10Through[{Cos,Sin}[2π(#-7/100)/3-π/6]]&/@Range[0,2],
7/10Through[{Cos,Sin}[2π(#+7/100)/3-π/6]]&/@Range[0,2],
Through[{Cos,Sin}[2π(#-1/10)/3-π/6]]&/@Range[0,2],
Through[{Cos,Sin}[2π(#+1/10)/3-π/6]]&/@Range[0,2]
};
g=Graph[Range[24],UndirectedEdge@@@{{1,2},{1,6},{1,7},{2,3},{2,8},{3,4},{3,9},{4,5},{4,10},{5,6},{5,11},{6,12},{7,8},{7,16},{8,14},{9,10},{9,17},{10,15},{11,12},{11,18},{12,13},{13,16},{13,19},{14,17},{14,20},{15,18},{15,21},{16,22},{17,23},{18,24},{19,22},{19,24},{20,22},{20,23},{21,23},{21,24}},VertexCoordinates->v]

RecognizeGraph[g]

All

GraphData["TruncatedOctahedralGraph","Graph","All"]//StyleGraphs

Inexact

Select[GraphData["TruncatedOctahedralGraph","Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData["TruncatedOctahedralGraph","EdgeList"]]

Default embedding

GraphPlot@GraphData["TruncatedOctahedralGraph","Edges"]

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

RecognizeGraph[g]

g=Graph[Range[24],UndirectedEdge@@@{{1,2},{1,3},{1,5},{2,4},{2,7},{3,6},{3,20},{4,8},{4,9},{5,7},{5,22},{6,8},{6,18},{7,10},{8,11},{9,11},{9,12},{10,12},{10,17},{11,13},{12,14},{13,15},{13,16},{14,16},{14,17},{15,18},{15,21},{16,21},{17,19},{18,20},{19,22},{19,23},{20,24},{21,23},{22,24},{23,24}},VertexCoordinates->(10^(-4)){{4028,-4934},{7068,-4934},{10108,-15469},{10108,-4934},{10108,5600},{11628,-12835},{11628,2966},{13148,-10202},{13148,-4934},{13148,333},{14667,-7568},{14667,-2301},{17707,-7568},{17707,-2301},{19227,-10202},{19227,-4934},{19227,333},{20747,-12835},{20747,2966},{22267,-15469},{22267,-4934},{22267,5600},{25307,-4934},{28347,-4934}}]

RecognizeGraph@g

Degenerate

GraphData["TruncatedOctahedralGraph","Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData["TruncatedOctahedralGraph","Graph","Degenerate"]

Bilateral

GraphData["TruncatedOctahedralGraph","Graph","Bilateral"]//StyleGraphs

Circular

GraphData["TruncatedOctahedralGraph","Graph","Circular"]//StyleGraphs

Planar

GraphData["TruncatedOctahedralGraph","Graph","Planar"]//StyleGraphs

Tutte embeddings

faces=ReverseSort@SymmetricallyDistinctFaces[GraphData["TruncatedOctahedralGraph"]]

Tally[ReverseSort[Length/@faces]]

IGLayoutTutte[GraphData["TruncatedOctahedralGraph"],"OuterFace"->#]&/@faces

gs=Annotate[#,VertexLabels->None]&/@{}

Tutte embedding construction 6

GraphPlot@

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

RecognizeGraph[g]

MinimalCrossing

GraphData["TruncatedOctahedralGraph","Graph","MinimalCrossing"]//StyleGraphs

Degenerate

GraphData["TruncatedOctahedralGraph","Graph","Degenerate"]//StyleGraphs

LCF

GraphData["TruncatedOctahedralGraph","Graph","LCF"]//StyleGraphs

Perspective

GraphData["TruncatedOctahedralGraph","Graph","Perspective"]//StyleGraphs

UnitDistance

GraphData["TruncatedOctahedralGraph","UnitDistance"]

GraphData["TruncatedOctahedralGraph","UnitDistance"]

UnitDistanceGraphQ[GraphData["TruncatedOctahedralGraph"],Debug->True]//Timing

GraphData["TruncatedOctahedralGraph","Graph","UnitDistance"]//StyleGraphs

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

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

FindUnitDistanceEmbedding[GraphData["TruncatedOctahedralGraph"],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

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

UnitDistance construction

SetProperty[,VertexLabels->Automatic]

{X,Y}={x,-1/2}+{1/2,y}-{b,c};
v={
(*1*) {x,1/2},
(*2*) {x,-1/2},
(*3*) {b,-c},
(*4*) {X,-Y},
(*5*) {b,c},
(*6*) {X,Y},
(*7*) {1/2,-y},
(*8*) {a+1,1/2},
(*9*) {-a,1/2},
(*10*) {a+1,-1/2},
(*11*) {-a,-1/2},
(*12*) {1/2,y},
(*13*) {-1/2,-y},
(*14*) {a,1/2},
(*15*) {-a-1,1/2},
(*16*) {a,-1/2},
(*17*) {-a-1,-1/2},
(*18*) {-1/2,y},
(*19*) {-X,-Y},
(*20*) {-b,-c},
(*21*) {-X,Y},
(*22*) {-b,c},
(*23*) {-x,1/2},
(*24*) {-x,-1/2}};
ee=GraphData["TruncatedOctahedralGraph","Edges"];
eqn=DeleteCases[UnitEdgeEquations[v,ee],True]

collinear=Thread[Mean[v[[{17,18}]]]==v[[22]]]

soln=NSolve[Join[eqn,collinear],{x,a,y,b,c},Reals]

gs=Graph[Range[24],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln

UnitDistanceGraphEmbeddingQ/@gs

soln=NSolve[Join[eqn,{Y==-1}],{x,a,y,b,c},Reals]

gs=Graph[Range[24],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln

Manipulate[
(
soln=NSolve[Join[eqn,{x==Rationalize[x0],a==Rationalize[a0]}],{x,a,y,b,c},Reals];
gs=Graph[Range[24],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln
),{x0,0,2},{a0,0,2}]

collinear=Thread[Mean[v[[{17,18}]]]==v[[22]]]

soln=Solve[Join[eqn,collinear,{perp}],{x,a,y,b,c},Reals]

gs=Graph[Range[24],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln

perp=Dot[Subtract@@v[[{4,7}]],Subtract@@v[[{7,3}]]]==0

perp=((1/2)-b) (-b+x)+((1/2)+c) (c-y)==0;

soln=Solve[Join[eqn,{2x==a-x,perp}],{x,a,y,b,c},Reals];
gs=Select[Graph[Range[24],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln,UnitDistanceGraphEmbeddingQ]

gs

LabelGraph[]

v[[3]]

{a,1/2}+{1/2,y}-{c,d}

{xx,yy}={(1/2)+a-c,(1/2)-d+y};
v={{a,1/2},{a,-1/2},{xx,yy},{c,d},{xx,-yy},{c,-d},{1/2,y},{x+1,1/2},{-x,1/2},{x+1,-1/2},{-x,-1/2},{1/2,-y},{-1/2,y},{x,1/2},{-x-1,1/2},{x,-1/2},{-x-1,-1/2},{-1/2,-y},{-c,d},{-xx,yy},{-c,-d},{-xx,-yy},{-a,1/2},{-a,-1/2}};
ee=GraphData["TruncatedOctahedralGraph","Edges"];
eqn=UnitEdgeEquations[v,ee]//FullSimplify//Union

var=Variables[Subtract@@@eqn]

Length/@{eqn ,var}

soln=Solve[eqn,var,Reals]//FullSimplify

Graph[Range[24],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln

soln=Solve[Join[eqn,{x==1/10,d==9/10}],var,Reals]//FullSimplify

Graph[Range[24],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln

soln=Solve[Join[eqn,{x==1/10,d==1/10}],var,Reals]//FullSimplify

Graph[Range[24],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln

gs={,, ,}

UnitDistanceGraphEmbeddingQ/@gs

gs=Select[gs,UnitDistanceGraphEmbeddingQ]

gs={,,,,,,}

MinimalCrossing construction

g=RotateGraph[MinimalCrossingGraph[GraphData["TruncatedOctahedralGraph"],"CrossingNumber"->-1]]

RotateGraph[MinimalCrossingGraph[GraphData["TruncatedOctahedralGraph"],"CrossingNumber"->-1]]

RecognizeGraph[g]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Tutte embeddings

<<IGraphM`

faces=IGFaces[GraphData["TruncatedOctahedralGraph"]]

IGLayoutTutte[GraphData["TruncatedOctahedralGraph"],"OuterFace"->#]&/@faces

3D default

Graph3D[GraphData["TruncatedOctahedralGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["TruncatedOctahedralGraph","Polyhedral"]

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

Graphics3D[{FaceForm[Green,Red],GraphData["TruncatedOctahedralGraph","Polyhedron"]}]

3D Canonical

GraphData["TruncatedOctahedralGraph","Graph",{"3D","Canonical"}]

Graphics3D[{Opacity[.5],Red,GraphData["TruncatedOctahedralGraph","Polyhedron","Canonical"],Yellow,Sphere[]}]

3D Canonical construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData["TruncatedOctahedralGraph"],-1]}]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->100,MaxIterations->50000,PrecisionGoal->20,"ProgressInterval"->500,"TangentFactor"->1/10,"PlanarFactor"->1/10,Debug->True])//Timing

SimplePolyhedronQ[can]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

(lens=Mean/@Split[Sort[PolyhedronEdgeLengths[can]],Abs[#1-#2]<1.*^-10&])//N

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

Cayley graph generators

GraphData["TruncatedOctahedralGraph","CayleyGraphGeneratingGroupNames"]

FiniteGroupData[{"SymmetricGroup",4},"IsomorphicGroups"]

GraphData["TruncatedOctahedralGraph","CayleyGraphGeneratingGroups"]

UndirectedGraph[CayleyGraph[System`SymmetricGroup[4]]]//RecognizeGraph

UndirectedGraph[CayleyGraph[FiniteGroupData[{"CrystallographicPointGroup",30},"PermutationGroupRepresentation"]]]//RecognizeGraph

UndirectedGraph[CayleyGraph[FiniteGroupData[{"CrystallographicPointGroup",31},"PermutationGroupRepresentation"]]]//RecognizeGraph

UndirectedGraph[CayleyGraph[FiniteGroupData["Tetrahedral","PermutationGroupRepresentation"]]]//RecognizeGraph

Projections

Manipulate[PolyhedronProjectionGraph[PolyhedronData["TruncatedOctahedron","Polyhedron"],{a,b,c}],{a,-1,1},{b,-1,1},{c,-1,1}]

{1, 3, 0}

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedOctahedron","Polyhedron"],{1,3,0},VertexLabels->"Name"]

{0,1,2 (Sqrt[2])}

2Take[SelectFirst[PolyhedronData["TruncatedOctahedron","Polygons"][[All,1]],Length[#]==4&],2]//Mean

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedOctahedron","Polyhedron"],{0,1,2 (Sqrt[2])},VertexLabels->"Name"]

{0,(Sqrt[2]),1}

-Sqrt[2]SelectFirst[PolyhedronData["TruncatedOctahedron","Polygons"][[All,1]],Length[#]==6&]//Mean

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedOctahedron","Polyhedron"],{0,(Sqrt[2]),1},VertexLabels->"Name"]

{1, 1, 0}

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedOctahedron","Polyhedron"],{1,1,0},VertexLabels->"Name"]

{0, 1, 0}

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedOctahedron","Polyhedron"],{0,1,0},VertexLabels->"Name"]

{0, 1, 1}

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedOctahedron","Polyhedron"],{0,1,1},VertexLabels->"Name"]

{1, 1, 1}

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedOctahedron","Polyhedron"],{1,1,1,π/6+π/2},VertexLabels->"Name"]

v=GraphEmbedding[g];

ArcTan@@(v[[16]]-v[[9]])//FullSimplify

{1, 2, 0}

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedOctahedron","Polyhedron"],{1,2,0},VertexLabels->"Name"]