Truncated Tetrahedral Graph

Author

Eric W. Weisstein
June 20, 2023

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

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

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

Embeddings

Names

GraphData["TruncatedTetrahedralGraph","StandardName"]

GraphData["TruncatedTetrahedralGraph","StandardNames"]

Primary

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

Construction from Read and Wilson

g=Graph[Range[12],UndirectedEdge@@@{{1,2},{1,3},{1,5},{2,3},{2,10},{3,4},{4,6},{4,8},{5,7},{5,9},{6,7},{6,8},{7,9},{8,11},{9,12},{10,11},{10,12},{11,12}},VertexCoordinates->(10^(-4)){{6849,-9599},{10371,-15702},{10371,-11633},{13894,-9599},{13894,2608},{17416,-3495},{17416,573},{20938,-9599},{20938,2608},{24461,-15702},{24461,-11633},{27983,-9599}}]

RecognizeGraph@g

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["TruncatedTetrahedralGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

Degenerate

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

Bilateral

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

Circular

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

Planar

GraphData["TruncatedTetrahedralGraph","Planar"]

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

Tutte embeddings

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

Tally[ReverseSort[Length/@faces]]

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

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

Circulant

GraphData["TruncatedTetrahedralGraph","Graph","Circulant"]//StyleGraphs

Halin

GraphData["TruncatedTetrahedralGraph","Halin"]

GraphData["TruncatedTetrahedralGraph","Graph","Halin"]//StyleGraphs

LCF

GraphData["TruncatedTetrahedralGraph","LCF"]

GraphData["TruncatedTetrahedralGraph","LCFSignature"]

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

LCF compute all

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

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

lcf

LCFGraph@@@lcf//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]

UnitDistance

GraphData["TruncatedTetrahedralGraph","UnitDistance"]

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

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

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

UnitDistanceGraphEmbeddingQ/@gs

UnitDistance by refinement

UnitDistanceEmbeddingRefine/@GraphData["TruncatedTetrahedralGraph","Graph","All"]

Select[%,UnitDistanceGraphEmbeddingQ]

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

Select[%,UnitDistanceGraphEmbeddingQ]

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

gs={,,};

UnitDistance by FindUnitDistanceEmbedding

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

FindUnitDistanceEmbedding[GraphData["TruncatedTetrahedralGraph"],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

FindUnitDistanceEmbedding[GraphData["TruncatedTetrahedralGraph"],MaxIterations->50000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance exact construction triangle

c=CirclePoints[Csc[Pi/6]/2,6];

v=Join[
CirclePoints[Csc[Pi/3]/2,3],
c,
UnitDistancePoint[Sequence@@#,1]&/@Partition[c,2,2]
];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[Partition[Range[3],2,1,1],Partition[Range[4,9],2,1,1],{{4,10},{5,10},{6,11},{7,11},{9,12},{8,12},{2,11},{3,12},{1,10}}],VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[g]

Outward-pointing:

c=CirclePoints[{Csc[Pi/6]/2,q},6];
v=Join[
CirclePoints[Csc[Pi/3]/2,3],
c,
UnitDistancePoint[Sequence@@#,1]&/@Partition[c,2,2]
];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[Partition[Range[3],2,1,1],Partition[Range[4,9],2,1,1],{{4,10},{5,10},{6,11},{7,11},{9,12},{8,12},{2,11},{3,12},{1,10}}],VertexCoordinates->v,VertexLabels->"Name"]

vv=FullSimplify[Lookup[Options[g],VertexCoordinates],0<q<2π]

FullSimplify[SquaredEuclideanDistance@@vv[[{1,10}]],0<q<2π]

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

Solve[(10/3)-Cos[q]+(Sqrt[3]) Sin[q]==0,q]

N[%]

Solve[(10/3)-Cos[q]+(Sqrt[3]) Sin[q]==0,q,Reals]

Inward-pointing:

c=CirclePoints[{Csc[Pi/6]/2,q},6];
v=Join[
CirclePoints[Csc[Pi/3]/2,3],
c,
UnitDistancePoint[Sequence@@#,2]&/@Partition[c,2,2]
];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[Partition[Range[3],2,1,1],Partition[Range[4,9],2,1,1],{{4,10},{5,10},{6,11},{7,11},{9,12},{8,12},{2,11},{3,12},{1,10}}],VertexCoordinates->v,VertexLabels->"Name"]

vv=FullSimplify[Lookup[Options[g],VertexCoordinates],0<q<2π]

FullSimplify[SquaredEuclideanDistance@@vv[[{1,10}]],0<q<2π]

UnitDistance construction

None of this shape:

GraphData["TruncatedTetrahedralGraph","Graphics","All"][[6]]

s=Sqrt[3]/2;
Solve[{
(u-1/2)^2+v^2==1,
(1/2-u)^2+(y-v)^2==1,
(a-u)^2+(b-v)^2==1,
(a-1/2)^2+(b-y)^2==1,
(a-1/2)^2+(b-1)^2==1},{a,b,u,v,y},Reals]//FullSimplify

coords={{-1/2,0},{0,s},{1/2,0},{0,s+1},{1/2,1},{a,b},{u,v},{1/2,y},{-1/2,y},{-u,v},{-a,b},{-1/2,1}};
edges=UndirectedEdge@@@{{1,2},{2,3},{1,3},{2,4},{3,7},{1,10},{4,5},{5,6},{6,7},{7,8},{8,9},{9,10},{10,11},{11,12},{4,12},{6,8},{9,11},{5,12}};
soln=Solve[{
(u-1/2)^2+v^2==1,
(1/2-u)^2+(y-v)^2==1,
(a-u)^2+(b-v)^2==1,
(a-1/2)^2+(b-y)^2==1,
(a-1/2)^2+(b-1)^2==1},{a,b,u,v,y},Reals];
If[soln==={},{},
(*
soln=Union[soln,SameTest->(N[#[[All,2]],10]==N[#2[[All,2]],10]&)];
soln=Pick[soln,DuplicateFreeQ[Round[10^3.coords]/.#]&/@soln];
*)
gs=Graph[Range[12],edges,VertexCoordinates->(coords/.#),VertexLabels->"Name"]&/@soln]

UnitDistanceGraphEmbeddingQ/@gs

RecognizeGraph/@gs

coords={{-1/2,0},{0,s},{1/2,0},{0,s+1},{1/2,1},{a,b},{u,v},{1/2,y},{-1/2,y},{-u,v},{-a,b},{-1/2,1}};
edges=UndirectedEdge@@@{{1,2},{2,3},{1,3},{2,4},{3,7},{1,10},{4,5},{5,6},{6,7},{7,8},{8,9},{9,10},{10,11},{11,12},{4,12}};
soln=NSolve[{
(u-1/2)^2+v^2==1,
(1/2-u)^2+(y-v)^2==1,
(a-u)^2+(b-v)^2==1,
(a-1/2)^2+(b-y)^2==1,
(a-1/2)^2+(b-1)^2==1},{a,b,u,v,y},Reals];
If[soln==={},{},
soln=Union[soln,SameTest->(N[#[[All,2]],10]==N[#2[[All,2]],10]&)];
soln=Pick[soln,DuplicateFreeQ[Round[10^3.coords]/.#]&/@soln];
Graph[Range[12],edges,VertexCoordinates->(coords/.#),VertexLabels->"Name"]&/@soln]

Try this one:

s=Sqrt[3]/2;
cs[q_]:=Through[{Cos,Sin}[q]]
rot[v_,q_]:=v[[1]]+RotationMatrix[q].(v[[2]]-v[[1]])

Manipulate[Column[{gg=Graph[Range[12],UndirectedEdge@@@{{1,2},{2,3},{1,3},{1,4},{2,5},{3,6},{4,7},{7,10},{4,10},{8,11},{5,11},{5,8},{6,12},{9,12},{6,9},{9,10},{7,11},{8,12}},VertexCoordinates->{
{0,s},{1/2,0},{-1/2,0},
{0,s}+cs[π/2+q],{1/2,0}+cs[-π/6+q],{-1/2,0}+cs[-5π/6+q],
rot[{{0,s}+cs[π/2+q],{0,s}},30Degree],rot[{{1/2,0}+cs[-π/6+q],{1/2,0}},30Degree],rot[{{-1/2,0}+cs[-5π/6+q],{-1/2,0}},30Degree],
rot[{{0,s}+cs[π/2+q],{0,s}},-30Degree],rot[{{1/2,0}+cs[-π/6+q],{1/2,0}},-30Degree],rot[{{-1/2,0}+cs[-5π/6+q],{-1/2,0}},-30Degree]
},VertexLabels->"Name"],
EdgeLengths[gg]//N}],{q,0,2π}]

v={
{0,s},{1/2,0},{-1/2,0},
{0,s}+cs[π/2+q],{1/2,0}+cs[-π/6+q],{-1/2,0}+cs[-5π/6+q],
rot[{{0,s}+cs[π/2+q],{0,s}},30Degree],rot[{{1/2,0}+cs[-π/6+q],{1/2,0}},30Degree],rot[{{-1/2,0}+cs[-5π/6+q],{-1/2,0}},30Degree],
rot[{{0,s}+cs[π/2+q],{0,s}},-30Degree],rot[{{1/2,0}+cs[-π/6+q],{1/2,0}},-30Degree],rot[{{-1/2,0}+cs[-5π/6+q],{-1/2,0}},-30Degree]
};

FullSimplify[SquaredEuclideanDistance@@v[[{9,10}]],0<q<π]

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

vnew=FullSimplify[TrigExpand[v/.q->ArcCos[1-((Sqrt[3])/2)]]]

g=Graph[Range[12],UndirectedEdge@@@{{1,2},{2,3},{1,3},{1,4},{2,5},{3,6},{4,7},{7,10},{4,10},{8,11},{5,11},{5,8},{6,12},{9,12},{6,9},{9,10},{7,11},{8,12}},VertexCoordinates->vnew,VertexLabels->"Name"]

RecognizeGraph@g

DegenerateEmbeddingQ@g

UnitDistanceGraphEmbeddingQ@g

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

gs={,,};

Matchstick

GraphData["TruncatedTetrahedralGraph","Matchstick"]

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

Perspective

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

3D default

Graph3D[GraphData["TruncatedTetrahedralGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["TruncatedTetrahedralGraph","Polyhedral"]

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

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

3D Canonical

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

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

3D Canonical construction

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

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

If[%===False,Quit[]]

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["TruncatedTetrahedralGraph","CayleyGraphGeneratingGroupNames"]

Projections

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

XXX

g=PolyhedronProjectionGraph[PolyhedronData["TruncatedTetrahedron","Polyhedron"],{(7/(Sqrt[3])),1,2 (Sqrt[(2/3)]),π-ArcTan[(Sqrt[10])]},VertexLabels->"Name"]

v=GraphEmbedding[g];

ArcTan@@(v[[4]]-v[[6]])//FullSimplify

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

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

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

FullSimplify[v[[8]]-v[[9]],x>0&&z>0]

Solve[{-x (3+2 (Sqrt[6]) z)+7 (Sqrt[3]) (1+(z^2))==0,-2 (Sqrt[6])+3 z==0},{x,z}]//FullSimplify

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

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

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

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

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

FullSimplify[Subtract@@v[[{6,10}]],z>0]

Solve[1-2 (Sqrt[2]) z==0,z]

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

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

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

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

FullSimplify[Mean[v[[{9,10}]]]-v[[8]],z>0]

Solve[2 (Sqrt[2])-7 z==0,z]

{0, 0, 1}

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

{0, 1, 0}

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

v=GraphEmbedding[g];

ArcTan@@(v[[8]]-v[[7]])//FullSimplify

{Sqrt[2], 0, 1}

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

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

RegionIntersection[Line[v[[{9,10}]]],Line[v[[{7,8}]]]]