Snub Cubical Graph

Author

Eric W. Weisstein
June 21, 2023

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

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

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

Graph

<<MathWorld`Graphs`

Names

GraphData["SnubCubicalGraph","StandardName"]

GraphData["SnubCubicalGraph","StandardNames"]

Primary

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

All

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

Embedding types

GraphDataEmbeddings[GraphData["SnubCubicalGraph","EdgeList"]]

Degenerate

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

Bilateral

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

Circular

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

Planar

GraphData["SnubCubicalGraph","Planar"]

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

Tutte embeddings

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

Tally[ReverseSort[Length/@faces]]

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

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

Tutte embedding construction 3 #1

GraphPlot@

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

RecognizeGraph[g]

Tutte embedding construction 3 #2

GraphPlot@

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

RecognizeGraph[g]

Planar embedding 1

s=1/2;
t=2/3;
v=Join[
{{-1,-1},{1,-1},{1,1},{-1,1}},
Table[{-s+2k s/3,-s},{k,0,2}],
Table[{s,-s+2k s/3},{k,0,2}],
Table[{s-2k s/3,s},{k,0,2}],
Table[{-s,s-2k s/3},{k,0,2}],
{{0,-t},{t,0},{0,t},{-t,0}},
{{-(1/3),(1/6)},{-(1/6),-(1/3)},{(1/3),-(1/6)},{(1/6),(1/3)}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[
{{1,2},{2,3},{3,4},{1,4},{1,17},{2,17},{2,18},{3,18},{3,19},{4,19},{4,20},{1,20},{3,11},{4,14},{1,5},{2,8}},
Partition[Range[5,16],2,1,1],
{{20,5},{20,14},{19,14},{19,11},{18,11},{8,18},{5,17},{8,17},{17,6},{6,16},{20,15},{13,15},{19,12},{12,10},{18,9},{9,7},{13,21},{16,21},{16,22},{22,7},{7,23},{10,23},{10,24},{24,13},{12,24},{15,21},{9,23},{6,22},{21,22},{22,23},{23,24},{21,24}}
],VertexCoordinates->v,VertexLabels->"Name"]

Planar embedding 2

s=1/2;
t=2/3;
v=Join[
{{-1,-1},{1,-1},{1,1},{-1,1}},
Table[{-s+2k s/3,-s},{k,0,2}],
Table[{s,-s+2k s/3},{k,0,2}],
Table[{s-2k s/3,s},{k,0,2}],
Table[{-s,s-2k s/3},{k,0,2}],
{{0,-t},{t,0},{0,t},{-t,0}},
{{-(1/3),(1/6)},{-(1/6),-(1/3)},{(1/3),-(1/6)},{(1/6),(1/3)}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[
{{1,2},{2,3},{3,4},{1,4},{1,17},{2,17},{2,18},{3,18},{3,19},{4,19},{4,20},{1,20},{3,11},{4,14},{1,5},{2,8}},
Partition[Range[5,16],2,1,1],
{{20,5},{20,14},{19,14},{19,11},{18,11},{8,18},{5,17},{8,17},{17,6},{6,16},{20,15},{13,15},{19,12},{12,10},{18,9},{9,7},{13,21},{16,21},{16,22},{22,7},{7,23},{10,23},{10,24},{24,13},{12,24},{15,21},{9,23},{6,22},{21,22},{22,23},{23,24},{21,24}}
],VertexCoordinates->v,VertexLabels->"Name"]

g=

RecognizeGraph[g]

MinimalCrossing

GraphData["SnubCubicalGraph",{"RCN","CN"}]

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

Circulant

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

Halin

GraphData["SnubCubicalGraph","Halin"]

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

Perspective

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

LCF

GraphData["SnubCubicalGraph","HamiltonianCycleCount"]

GraphData["SnubCubicalGraph","LCFSignature"]

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

LCFNotation/@%

Tally[%[[All,-1]]]

LCF compute all

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

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

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1|2}]//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|2}],Last],{2}],{2}],
(* order-1 bilateral only *)
DeleteMissing[BilateralLCFGraph@@@Cases[lcf,{_,XXX}]]}])//Timing

Length[gs]

(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|2}],Last],{2}],{2}],
(* order-1 bilateral only *)
DeleteMissing[BilateralLCFGraph@@@Cases[lcf,{_,2}]]}])//Timing

Length[gs]

UnitDistance

GraphData["SnubCubicalGraph","UnitDistance"]

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

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

Matchstick

GraphData["SnubCubicalGraph","Matchstick"]

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

3D default

Graph3D[GraphData["SnubCubicalGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["SnubCubicalGraph","Polyhedral"]

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

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

3D Canonical

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

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

3D Canonical construction

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

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->50,MaxIterations->50000,PrecisionGoal->20,"ProgressInterval"->1000,"TangentFactor"->1/5,"PlanarFactor"->1/5,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]

Embeddings

GraphDataEmbeddings[g]

Projections

PolyhedronData["SnubCube","Orientations"]

PolyhedronData["SnubCube"]

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

{0, 0, 1}

Graphics3D[PolyhedronData["SnubCube","Lines"],Boxed->False,ViewPoint->100{0,0,1}]

g1=PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{0,0,1}]

RecognizeGraph[g]

{1, 0, 1}

lines=PolyhedronData["SnubCube","Lines"]/.Line[l_]:>Mean[l];

lines[[5]]//FullSimplify

N[%]

Graphics3D[PolyhedronData["SnubCube","Lines"],Boxed->False,ViewPoint->100{1,0,1}]

g2=PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{1,0,1}]

{1, 1, 1}

g3=PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{1,1,1}]

{(NumericalApproximation[Root, (RowDefault["-1.84", FEExpressionsNumericalApproximationElider]), Root[1-#1+((#1)^2)+((#1)^3)&,1], ]),0,1}

Graphics3D[{PolyhedronData["SnubCube","Lines"],MapIndexed[Text[#2[[1]],#]&,PolyhedronData["SnubCube","VertexCoordinates"]]},Boxed->False,ViewPoint->100{-1.84,0,1},ViewVertical->{0,1,0}]

PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{-1.84,0,1}]

g=PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{x,0,1}]

FullSimplify[Lookup[Options[g],VertexCoordinates][[{2,6}]],x∈Reals]

FullSimplify[Subtract@@%]

Solve[(((NumericalApproximation[Root, (RowDefault["-2.29", FEExpressionsNumericalApproximationElider]), Root[-2-6 ((#1)^2)-4 ((#1)^4)+((#1)^6)&,1], ])+x (NumericalApproximation[Root, (RowDefault["-1.24", FEExpressionsNumericalApproximationElider]), Root[-2+2 ((#1)^2)-2 ((#1)^4)+((#1)^6)&,1], ]))/(Sqrt[1+(x^2)]))==0,x]//FullSimplify

g4=PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{(NumericalApproximation[Root, (RowDefault["-1.84", FEExpressionsNumericalApproximationElider]), Root[1-#1+((#1)^2)+((#1)^3)&,1], ]),0,1}]

{(NumericalApproximation[Root, (RowDefault["0.383", FEExpressionsNumericalApproximationElider]), Root[-4+8 #1+6 ((#1)^2)+((#1)^3)&,1], ]), 1, 1}

Graphics3D[{PolyhedronData["SnubCube","Lines"],MapIndexed[Text[#2[[1]],#]&,PolyhedronData["SnubCube","VertexCoordinates"]]},Boxed->False,ViewPoint->100{.384,1,1},ViewVertical->{1,1,1}]

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

GraphEmbedding[g][[{11,14}]]

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

FullSimplify[Lookup[Options[g],VertexCoordinates][[{11,14}]],x∈Reals]

FullSimplify[Subtract@@%]

Solve[(((Sqrt[2]) ((NumericalApproximation[Root, (RowDefault["-0.676", FEExpressionsNumericalApproximationElider]), Root[-2+6 ((#1)^2)-4 ((#1)^4)+((#1)^6)&,1], ])+x (NumericalApproximation[Root, (RowDefault["1.76", FEExpressionsNumericalApproximationElider]), Root[-1+10 ((#1)^2)-28 ((#1)^4)+8 ((#1)^6)&,2], ])))/(Sqrt[2+(x^2)]))==0,x]//FullSimplify

g5=PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{(NumericalApproximation[Root, (RowDefault["0.383", FEExpressionsNumericalApproximationElider]), Root[-4+8 #1+6 ((#1)^2)+((#1)^3)&,1], ]),1,1},VertexLabels->"Name"]

Nice embeddings based on projections

{0, 0, 1}

PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{0,0,1},VertexLabels->"Name"]

v=Table[0,24]

v[[{11,15,23,24,16,12,20,19}]]=CirclePoints[8]

v[[{17,9,13,21,7,5,6,8,22,14,10,18,4,2,1,3}]]=CirclePoints[2,16]

g=SetProperty[GraphData["SnubCubicalGraph"],VertexCoordinates->v]

{1, 0, 1}

PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{1,0,1},VertexLabels->"Name"]

v=Table[0,24]

v[[{1,5,20,24}]]=CirclePoints[4]

v[[{15,11,8,4}]]=CirclePoints[2,4]

v[[{9,17,21,13,7,23,6,16,22,10,14,18,12,2,19,3}]]=RotateRight[CirclePoints[3,16],-2]

g=SetProperty[GraphData["SnubCubicalGraph"],VertexCoordinates->(RotationMatrix[π/2].#&/@v)]

RecognizeGraph[g]

{1, 1, 1}

PolyhedronProjectionGraph[PolyhedronData["SnubCube","Polyhedron"],{1,1,1},VertexLabels->"Name"]

v=Table[0,24]

v[[{24,17,8,11,14,1}]]=CirclePoints[6]

v[[{3,5,13,22,20,12}]]=RotateRight[CirclePoints[2,6],-5]

v[[{9,15,21,7,23,6,16,10,4,18,2,19}]]=RotateRight[CirclePoints[3,12],5]

Manipulate[(
v=Table[0,24];
v[[{24,17,8,11,14,1}]]=CirclePoints[6];
v[[{3,5,13,22,20,12}]]=RotateRight[CirclePoints[2,6],off1];
v[[{9,15,21,7,23,6,16,10,4,18,2,19}]]=RotateRight[CirclePoints[3,12],off2]
);
g=SetProperty[GraphData["SnubCubicalGraph"],VertexCoordinates->v],
{off1,-6,6,1},{off2,-12,12,1}]

gs={,,,,,};

Stereographic projections

Quiet@GraphPlot[SkeletonGraph[PolyhedronData[poly,"Faces"]//Normal,#],Method->None]&/@Range[.2,1.5,.1]

Properties

Classes

GraphData[g,"Classes"]

Matrices

GraphDataMatrices[g]

Properties

TableForm[GraphDataTable[g,x],TableDepth->2]//TraditionalForm

GraphData

GraphClassString

GraphClassString[g]