Truncated Cubical Graph

Author

Eric W. Weisstein
June 21, 2023

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

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

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

Graph

Primary

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

Read and Wilson construction

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["TruncatedCubicalGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

Degenerate

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

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

Bilateral

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

Circular

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

Planar

GraphData["TruncatedCubicalGraph","Planar"]

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

Tutte embeddings

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

Tally[ReverseSort[Length/@faces]]

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

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

Tutte embedding construction 8

GraphPlot@

Tutte embedding construction 3

GraphPlot@

v[[23,2]]

v[[9,2]]

v=Join[CirclePoints[Csc[Pi/3]/2,3],CirclePoints[3/10,3],CirclePoints[{6/100,-Pi/2},3],CirclePoints[{2/100,-Pi/2},3]];
v=Join[v,r=Table[v[[6]]+i(v[[4]]-v[[6]])/5,{i,4}],RotationMatrix[2Pi/3].#&/@r,RotationMatrix[4Pi/3].#&/@r];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,1,4,17,18,19,20,5,2],e[4,16,15,14,13,6,24,23,22,21,5],{3,6},{13,24},{16,17},{20,21},e[23,9,22],e[19,8,18],e[14,7,15],e[9,12,11,8],e[12,10,11],{7,10}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Degenerate

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

LCF

GraphData["TruncatedCubicalGraph","LCF"]

GraphData["TruncatedCubicalGraph","HamiltonianCycleCount"]

GraphData["TruncatedCubicalGraph","LCFSignature"]

GraphData["TruncatedCubicalGraph","LCFNotations"]

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

Tally[LCFNotation[#][[2]]&/@%]

LCF compute all

Length[FindHamiltonianCycle[GraphData["TruncatedCubicalGraph"],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData["TruncatedCubicalGraph"],All])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

(gs=Flatten[{
(* all LCF's with order >1, sorted by order and with bilateral graphs first *)
Join[DeleteCases[#,{_Missing,_}][[All,1]],Cases[#,{_Missing,_}][[All,2]]]&/@Map[{BilateralLCFGraph@#,#}&,Map[LCFGraph@@#&,SplitBy[DeleteCases[lcf,{_,1}],Last],{2}],{2}],
(* order-1 bilateral only *)
DeleteMissing[BilateralLCFGraph@@@Cases[lcf,{_,1}]]}])//Timing

Length[gs]

MinimalCrossing

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

Perspective

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

UnitDistance

GraphData["TruncatedCubicalGraph","UnitDistance"]

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

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

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

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

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

UnitDistance exact construction

v=Join[
CirclePoints[1/(Sqrt[3]),6],
c=CirclePoints[Csc[Pi/12]/2,12],
UnitDistancePoint[Sequence@@#,2]&/@Partition[c,2,2,1]
];

g=Graph[Range[Length[v]],UndirectedEdge@@@Join[
{{1,3},{3,5},{1,5},{2,6},{2,4},{4,6}},
Partition[Range[7,18],2,1,1],
Table[{i,i+18},{i,6}],
Table[{5+2i,18+i},{i,6}],
Table[{6+2i,18+i},{i,6}]
],
VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[g]

Norm[v[[20]]]//FullSimplify

v=Join[
CirclePoints[{1/(Sqrt[3]),0},6],
c=CirclePoints[{Csc[Pi/12]/2,1.01616},12],
UnitDistancePoint[Sequence@@#,2]&/@Partition[c,2,2,1]
];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[
{{1,3},{3,5},{1,5},{2,6},{2,4},{4,6}},
Partition[Range[7,18],2,1,1],
Table[{i,i+18},{i,6}],
Table[{5+2i,18+i},{i,6}],
Table[{6+2i,18+i},{i,6}]
],
VertexCoordinates->v,VertexLabels->"Name"]

EdgeLengths[g]//N

v=Join[
CirclePoints[{1/(Sqrt[3]),0},6],
c=CirclePoints[{Csc[Pi/12]/2,q},12],
UnitDistancePoint[Sequence@@#,2]&/@Partition[c,2,2,1]
];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[
{{1,3},{3,5},{1,5},{2,6},{2,4},{4,6}},
Partition[Range[7,18],2,1,1],
Table[{i,i+18},{i,6}],
Table[{5+2i,18+i},{i,6}],
Table[{6+2i,18+i},{i,6}]
],
VertexCoordinates->v,VertexLabels->"Name"]

vv=Lookup[Options[g],VertexCoordinates];

FullSimplify[SquaredEuclideanDistance@@vv[[{5,23}]],0<q<2π]

Solve[(1/6) (8-(Sqrt[2]) (3+(Sqrt[3])) Cos[q]-(Sqrt[2]) (-3+(Sqrt[3])) Sin[q])==1&&0<q<2π,q]//FullSimplify

gs=(v=Join[
CirclePoints[{1/(Sqrt[3]),0},6],
c=CirclePoints[{Csc[Pi/12]/2,#},12],
UnitDistancePoint[Sequence@@#,2]&/@Partition[c,2,2,1]
];
Graph[Range[Length[v]],UndirectedEdge@@@Join[
{{1,3},{3,5},{1,5},{2,6},{2,4},{4,6}},
Partition[Range[7,18],2,1,1],
Table[{i,i+18},{i,6}],
Table[{5+2i,18+i},{i,6}],
Table[{6+2i,18+i},{i,6}]
],
VertexCoordinates->v,VertexLabels->"Name"])&/@{2 (π+ArcTan[((-3 (Sqrt[2])+(Sqrt[6])-2 (Sqrt[11]))/(2+3 (Sqrt[2])+(Sqrt[6])))]),2ArcTan[((-3 (Sqrt[2])+(Sqrt[6])+2 (Sqrt[11]))/(2+3 (Sqrt[2])+(Sqrt[6])))]}

RootReduce[2 ArcTan[((-3 (Sqrt[2])+(Sqrt[6])+2 (Sqrt[11]))/(2+3 (Sqrt[2])+(Sqrt[6])))]]//FullSimplify

c=CirclePoints[{Csc[Pi/12]/2,2 ArcTan[((-3 (Sqrt[2])+(Sqrt[6])+2 (Sqrt[11]))/(2+3 (Sqrt[2])+(Sqrt[6])))]},12]//FullSimplify

v=Join[
CirclePoints[{1/(Sqrt[3]),0},6],
c,
UnitDistancePoint[Sequence@@#,2]&/@Partition[c,2,2,1]//RootReduce
]//FullSimplify//ToRadicals;//Timing

g=Graph[Range[Length[v]],UndirectedEdge@@@Join[
{{1,3},{3,5},{1,5},{2,6},{2,4},{4,6}},
Partition[Range[7,18],2,1,1],
Table[{i,i+18},{i,6}],
Table[{5+2i,18+i},{i,6}],
Table[{6+2i,18+i},{i,6}]
],
VertexCoordinates->v,VertexLabels->"Name"];

UnitDistanceGraphQ[g,WorkingPrecision->Infinity]

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

gs={,,,};

Matchstick

GraphData["TruncatedCubicalGraph","Matchstick"]

GraphData["TruncatedCubicalGraph","Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData["TruncatedCubicalGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["TruncatedCubicalGraph","Polyhedral"]

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

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

3D Canonical

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

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

3D Canonical construction

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

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->50,MaxIterations->50000,PrecisionGoal->20,"ProgressInterval"->1000,"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["TruncatedCubicalGraph","CayleyGraphGeneratingGroupNames"]

FiniteGroupData[{"CrystallographicPointGroup",29},"IsomorphicGroups"]

GraphData["CuboctahedralGraph","CayleyGraphGeneratingGroups"]

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

Projections

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

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

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

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

v=Lookup[Options[g],VertexCoordinates];

FullSimplify[v[[5,1]]-v[[18,1]],z>0]

Solve[((1+(Sqrt[2])-(1/2) (3+2 (Sqrt[2])) z)/(Sqrt[2+(z^2)]))==0,z]//FullSimplify

{(2/(5+3 (Sqrt[2]))),1,1}

(1/(2/(5+3 (Sqrt[2]))))//FullSimplify

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedCube","Polyhedron"],{(2/(5+3 (Sqrt[2]))),1,1},VertexLabels->"Name"]

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

v=Lookup[Options[g,VertexCoordinates];

FullSimplify[Mean[v[[{5,11,14}]]][[1]]-v[[8,1]],z>0]

Solve[((2-(5+3 (Sqrt[2])) z)/(3 (Sqrt[2+(z^2)])))==0,z]//FullSimplify

N[%]

{(1/7) (-8+9 (Sqrt[2])),1,1}

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedCube","Polyhedron"],{(1/7) (-8+9 (Sqrt[2])),1,1},VertexLabels->"Name"]

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

v=Lookup[Options[g],VertexCoordinates];

FullSimplify[First[Mean[v[[{5,11,14}]]]-v[[4]]],z>0]

Solve[(((2/3)+(Sqrt[2])-(1/3) (5+3 (Sqrt[2])) z)/(Sqrt[2+(z^2)]))==0,z]//FullSimplify

N[%]

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

{.115,.395,.275}/.395

1/(Sqrt[2.])

.29(Sqrt[2])

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

v=GraphEmbedding[g]//FullSimplify

Equal@@v[[{1,23}]]

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

{.115,.395,-.115}/.115

2.+(Sqrt[2])

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

PolyhedronProjectionGraph[PolyhedronData["TruncatedCube","Polyhedron"],{1,2+(Sqrt[2]),1.2},VertexLabels->"Name"]

v=GraphEmbedding[g]//FullSimplify

Equal@@v[[{8,13}]]

Equal@@v[[{2,6},2]]

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

v=PolyhedronData["TruncatedCube","VertexCoordinates"][[1]]

Max[v]

v/Max[v]//FullSimplify

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

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

v=Mean[PolyhedronData["TruncatedCube","Lines"][[2,1]]]//FullSimplify

Max[v]

v/Max[v]//FullSimplify

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

{0, 0, 1}

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

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

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

{1, 0, 1}

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

{1, 1, 1}

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