Faces and NetFaces relation in polyhedron

Question

I'm trying to generate some plots of polyhedra with coloured faces. To determine the colours, I require the adjacency information of the faces. For the 3D plot this works really well. Say I want to colour the neighbours of a given face:

adjacency = Graph[UndirectedEdge @@@ PolyhedronData["Icosahedron", "AdjacentFaceIndices"]];

neighbor[f_] := Select[VertexList[adjacency], GraphDistance[adjacency, f, #] == 1 &]

live = Table[MemberQ[neighbor@1, i], {i, 20}]

Graphics3D[
 PolyhedronData["Icosahedron", "Faces"] /. 
  Polygon[l_] :> 
   MapIndexed[ {Glow@@If[live[[#2[[1]]]], Black, White], Polygon[#]} &, l],
 Lighting -> None, Boxed -> False]

This works because the face indices used by AdjacencyFaceIndices are in the same order as faces returned by PolyhedronData["Icosahedron", "Faces"]. However, this does not seem to be the case for "NetFaces":

Graphics[
 PolyhedronData["Icosahedron", "NetFaces"] /. 
  Polygon[l_] :> 
   MapIndexed[{EdgeForm@Black, If[live[[#2[[1]]]], Black, White], Polygon[#]} &, l]
]

Is there any way to find a valid mapping of positions in "NetFaces" to face indices, such that I can create a net of my coloured polyhedron? Of course, this mapping is not unique, but any valid mapping would do.

It might be useful to note that this is reproducible with something as simple as a cube, but I've used an icosahedron so I could fit all the coloured faces into the 3D plot as well.

Answer 1

Edit: Recently Szabolcs released the new version of IGraphM (v0.2.0). Now the code below works pretty fine.

Let us imagine that we move polyhedron faces a bit:

name = "Icosahedron";
{poly, net} = PolyhedronData[name, {"Faces", "NetFaces"}];

Graphics3D[Normal@poly /. 
  Polygon@pts_ :> Polygon@Transpose[.9 Transpose@pts + .1 Mean@pts]]

Now we can construct a graph in the following way: each face corresponds to a triangle fan (gray lines below). The center vertex in the fan marks the face (black points). Initial faces have common vertices. They are marked by complete subgraphs (orange lines). We can construct this graph for the polyhedron and the net as well.

ids[p_] := FirstCase[p, _Polygon][[1]];
graph[p_] := Graph[#, VertexStyle -> _Integer -> Black] &@Flatten[{
       Style[UndirectedEdge@##, Orange] & @@@ Subsets[#, {2}] & /@ 
        GatherBy[Catenate@#, First],
       Style[UndirectedEdge@##, Darker@Gray] & @@@ Partition[#, 2, 1, 1] & /@ #,
       Style[UndirectedEdge[{##}, #2], Darker@Gray] & @@@ # & /@ #
       }] &@MapIndexed[Thread@{#1, #2[[1]]} &, ids@p];
{netG, polyG} = graph /@ {net, poly};
{netCol, polyCol} = VertexList /@ {netG, polyG} /. {_Integer -> 1, {__Integer} -> 2};

netG

Graph3D[polyG, ViewAngle -> 0.3]

One can see that the first graph is the subgraph of the second one. We can find the subgraph isomorphism with IGraphM package (thanks to Szabolcs and Kuba). If you don't have this package you can use this comprehensive list of definitions.

<< IGraphM`;

subisomorphism = First@Normal@
  IGLADGetSubisomorphism[{netG, VertexColors -> netCol}, {polyG, 
    VertexColors -> polyCol}];

The following list is the face-to-face correspondence (bijection, similar to Kuba's fromNet):

netToPoly[name, "Faces"] = Cases[#, _@__Integer] &@subisomorphism
(* {1 -> 1, 2 -> 12, 3 -> 5, 4 -> 3, 5 -> 15, 6 -> 14, 7 -> 18, 8 -> 7, 
 9 -> 11, 10 -> 9, 11 -> 2, 12 -> 20, 13 -> 4, 14 -> 13, 15 -> 17, 16 -> 16, 
 17 -> 8, 18 -> 6, 19 -> 19, 20 -> 10} *)

The following list is the vertex-to-vertex correspondence. Note, that several vertices of the net can correspond to one vertex of the polyhedron (it is surjection):

netToPoly[name, "Vertices"] = 
 Union@DeleteCases[#, _@__Integer][[;; , ;; , 1]] &@subisomorphism
(* {1 -> 12, 2 -> 12, 3 -> 12, 4 -> 12, 5 -> 12, 6 -> 8, 7 -> 2, 8 -> 4, 
 9 -> 6, 10 -> 10, 11 -> 8, 12 -> 3, 13 -> 7, 14 -> 11, 15 -> 5, 16 -> 1, 17 -> 3, 
 18 -> 9, 19 -> 9, 20 -> 9, 21 -> 9, 22 -> 9} *)

There are nice color visualizations of such a map in other answers. Let me do something new (see code below):

Firstly, I produce graphs of connected faces

faceGraph[g_Graph] := 
  Graph@Cases[Tally@Cases[EdgeList@g, _[{_, i_}, {_, j_}] :> {i, j}], 
   {e_, 2} :> e];

netFG = faceGraph@netG;
polyFG = Graph[EdgeList@faceGraph@polyG /. Reverse /@ netToPoly[name, "Faces"]];
root = Last@GraphCenter@netFG;
{Graph[netFG, VertexLabels -> "Name"], 
  Graph[polyFG, VertexLabels -> "Name"]} // GraphicsRow

Then, I do some geometry which is similar to skeletal animation in computer graphics

net3D = MapAt[N@# /. {p__Real} :> {p, 0.} &, net, 1];
netFaces = Flatten@N@Normal@net3D;
polyFaces = Flatten[N@Normal@poly][[Sort[netToPoly[name, "Faces"]][[;; , 2]]]];

children = GroupBy[
   DeleteCases[Thread[DepthFirstScan[netFG, root] -> VertexList@netFG], 
    root -> root], First -> Last];

ClearAll[fold, rotate, anchor]
polyVertexIDs[fID_] := ids[poly][[fID /. netToPoly[name, "Faces"]]];
commonNetVertexIDs[fID1_, fID2_] := 
  ids[net][[fID1]] ⋂ ids[net][[fID2]];
commonPolyVertexIDs[fID1_, fID2_] := 
  commonNetVertexIDs[fID1, fID2] /. netToPoly[name, "Vertices"];
anchor[fID1_, fID2_] := 
  Sequence @@ {#2 - #, #} & @@ net3D[[1, commonNetVertexIDs[fID1, fID2]]];
maxAngle[fID1_, fID2_] := 
  ArcTan[Cross[#2, #].Cross[#, #3], #.Cross@##2] &[
       Normalize[#2 - #], #3 - #, #4 - #] & @@ 
     N@poly[[1, {#[[1]], #[[2]], Complement[polyVertexIDs@fID1, #][[1]], 
        Complement[polyVertexIDs@fID2, #][[1]]}]] &@
   commonPolyVertexIDs[fID1, fID2];
rotate[parentID_, childID_, t_] := 
  GeometricTransformation[fold[t, childID], 
   RotationTransform[t maxAngle[parentID, childID], anchor[parentID, childID]]];
fold[t_, id_: root] := {netFaces[[id]], 
     If[Head@# === Missing, {}, rotate[id, #, t] & /@ #]} &@children@id;

Manipulate[
 Graphics3D[fold[t], 
  PlotRange -> {MinMax@net[[1, ;; , 1]], MinMax@net[[1, ;; , 2]], {-0.5, 2.5}}, 
  Boxed -> False, ImageSize -> 700, ViewVector -> {0, -100, 30}], {t, -1, 1}]

The same for "RhombicHexecontahedron":

Answer 2

Intro

This is completely different approach, since what we know about the net is not enough and the relation between faces and net faces isn't included, let's create the net from the polyhedron.

The only issue with the present code is that the net is generated automatically and doesn't have to be the same as the one in PolyhedronData.

The idea is to unwrap the polyhedron. We take a path through all faces and rotate faces that are left to the plane of the first one.

Example

polyhedron = "SnubCube";

selectedFace = 3;
g = Graph@PolyhedronData[polyhedron, "AdjacentFaceIndices"];

neighbors = Rest@VertexList@NeighborhoodGraph[g, selectedFace]

{4, 8, 33}

Graphics3D[
   GraphicsComplex[
    PolyhedronData[polyhedron, "VertexCoordinates"],
    {
     White, Polygon[#],
     Red, Polygon[#[[selectedFace]]],
     Orange, Polygon[#[[neighbors]]]
     }
    ], Lighting -> "Neutral"
] & @ PolyhedronData[polyhedron, "FaceIndices"]

Graphics[{
    EdgeForm@Thin, White, Polygon@#,
    Red, Polygon@#[[selectedFace]],
    Orange, Polygon@#[[neighbors]]
}] & @ generateNet[polyhedron]

Code

The code is based on Random polyhedra walk

generateNet[polyhedron_] := 
 Module[{adjacencyGraph, path, coordinates, polys, result, init, 
   trans, bottomFace, nextFace, pivotEdge}
  ,
  adjacencyGraph = 
   UndirectedEdge @@@ 
     PolyhedronData[polyhedron, "AdjacentFaceIndices"] // Graph;
  path = Partition[FindShortestTour[adjacencyGraph][[2]], 2, 1];
  coordinates = N@PolyhedronData[polyhedron, "VertexCoordinates"];
  polys = PolyhedronData[polyhedron, "FaceIndices"];
  
  result = <||>;
  init = RotationTransform[
      {Cross[#2 - #, #3 - #2] & @@ #, {0, 0, 1}},
      Mean@#
      ] &@coordinates[[polys[[path[[1, 1]]]]]];
  
  coordinates = init /@ coordinates;
  (result[#] = Part[coordinates, polys[[#]]]) &@path[[1, 1]];
  Do[
   If[
    Not@MemberQ[Keys@result, path[[step, 2]]]
    ,
    
    {bottomFace, nextFace} = path[[step]];
    
    pivotEdge = Intersection @@ polys[[{bottomFace, nextFace}]];
    
    trans = polygonTransformation[
      Part[coordinates, polys[[bottomFace]]],
      Part[coordinates, polys[[nextFace]]],
      Part[coordinates, pivotEdge]
      ];
    
    coordinates = trans /@ coordinates;
    (result[#] = Part[coordinates, polys[[#]]]) &@path[[step, 2]];
    
    ],
   {step, Length[path] - 1}
   ];

  Sort[Normal@result][[;; , 2, ;; , ;; 2]]
];



polygonTransformation[coor1_, coor2_, commonEdge_] := Module[{
   normal1, normal2, angle
   },
  
  {normal1, normal2} = Function[{c1, c12, pivotV, c2},
     {Cross[c1 - c12, c12 - pivotV],
      Cross[pivotV - c12, c12 - c2]}
     ][
    Mean@coor1, Mean@commonEdge, First@commonEdge, Mean@coor2
    ];
  angle = VectorAngle @@ ({normal1, normal2});
  
  RotationTransform[angle , {normal2, normal1}, Mean@commonEdge]
  ]

Answer 3

TL;DR; The mapping from "Icosahedron" faces' indices to net faces' indices is given by:

{9 -> 10, 19 -> 20, 8 -> 19, 10 -> 17, 7 -> 9, 20 -> 8, 12 -> 18, 
 13 -> 15, 6 -> 7, 3 -> 6, 2 -> 16, 4 -> 13, 16 -> 5, 5 -> 4, 1 -> 14,
 15 -> 11, 14 -> 3, 18 -> 2, 11 -> 12, 17 -> 1}

but the answer isn't fully automatic, though imo worth sharing.

The idea is to find a subgraph in polyhedron faces adjacency graph generated by net faces adjacency graph.

The problem is that usually such relation isn't unique so we have to play with the input for IGLADGetSubisomorphism till we find the solution.

(the net contains full information but one would have to have a procedure of assembling the polyhedron from the net to know what are all neighbors of edge faces)

---

We will need additional function:

• IGLADGetSubisomorphism by Szabolcs from his great package IGraphM

---

netFacesAdjacencyGraph = AdjacencyGraph@Outer[
 Boole[Length[Intersection[##]] == 2] &,
 #, #
 , 1] &@PolyhedronData["Icosahedron", "NetFaceIndices"];


polyhedronFacesAdjacencyGraph = Graph[
    UndirectedEdge @@@ PolyhedronData["Icosahedron", "AdjacentFaceIndices"]
];

So we have to fit the left one inside the right one.

<< IGraphM`

fromNet = Normal @ First @ IGLADGetSubisomorphism[
    netFacesAdjacencyGraph, 
    polyhedronFacesAdjacencyGraph
]

{1 -> 9, 2 -> 11, 3 -> 1, 4 -> 12, 5 -> 5, 6 -> 3, 7 -> 15, 8 -> 14, 9 -> 10, 10 -> 7, 11 -> 19, 12 -> 18, 13 -> 2, 14 -> 20, 15 -> 4, 16 -> 13, 17 -> 17, 18 -> 16, 19 -> 6, 20 -> 8}

Done :P

HighlightGraph[
   polyhedronFacesAdjacencyGraph, 
   Style[
       EdgeList[netFacesAdjacencyGraph] /. fromNet, 
       Blue, [email protected]
   ]
]

---

That's it. Now, let's just grab reversed relation:

toNet = Reverse /@ fromNet;

selectedInPoly = 13;

neighborsInPoly = Rest @ VertexList @ NeighborhoodGraph[
    polyhedronFacesAdjacencyGraph,
    selectedInPoly
]

faces = First @ Normal @ N @ PolyhedronData["Icosahedron", "Faces"];
netFaces = First@Normal@PolyhedronData["Icosahedron", "NetFaces"];

Graphics3D[  Table[ {Which[
    i === selectedInPoly, Red,
    MemberQ[neighborsInPoly, i], Orange,
    True, White],
   faces[[i]], Black, Inset[i, 1.1 Mean@faces[[i, 1]]]
   },
  {i, Length@faces}  ],
 Lighting -> "Neutral" ] 

Graphics[ Table[ {
   EdgeForm@Black,
   Which[
    (i) === (selectedInPoly /. toNet), Red,
    MemberQ[neighborsInPoly /. toNet, i], Orange,
    True, White ],
   netFaces[[i]], Black, Inset[Text[(i /. fromNet)], Mean@netFaces[[i, 1]]]
   },
  {i, Length@netFaces} ] ]

So, as we can see on the right example, this isn't the transformation we were after, 15 should be in place of 20.

Manual adjustments - if we reverse edge list in polyhedronFacesAdjacencyGraph, then it gives the correct transformation:

fromNet =  Normal @ First @ IGLADGetSubisomorphism[
   Graph @ Reverse @ EdgeList @ netFacesAdjacencyGraph, 
   polyhedronFacesAdjacencyGraph
]

but I don't know how to include the procedure to find proper neighbors of edge faces :-/

Answer 4

Komei Fukuda researched the problem and developed a few nice software packages to address it and optimise the computation complexity. This answer uses Fukuda's codebase.

Just to help understanding the non-triviality of the problem, here are a few simple but pathological cases and the debunking of two conjectures:

• Is every unfolding of a convex polytope non-selfoverlapping?

• Is every unfolding of a convex polytope unambiguous?

Here are all Fukuda's papers about the matter, paywall-free

---

To install Fukuda's packages:

1. Download (or make) the cddml lib for your machine. I used the win32 newlib
2. Download the UnfoldPolytope2 package

Edit the package and change the main function to colorize the faces:

UnfoldPolytope[facets_List,s_Integer]:=
    Block[{odfacets,circfacets,edg,faAdj,vertices,veAdj,
    t,tree,cotree,sptree,i,tr,vervec},
    odfacets = facets;
    {edg,faAdj} = MakeEdgesFromFacets[odfacets];
    vertices = Union[Flatten[facets,1]];
    veAdj = Flatten[{Position[vertices,#[[1]]], Position[vertices,#[[2]]]}]& /@ edg;
    t = BreadthFirstSearch[MakeAdjTable[Length[vertices],veAdj],1];
    tree = Flatten[Position[veAdj,#]& /@ Position[t,1]];
    cotree = Complement[Table[i,{i,1,Length[edg]}],tree];
    sptree = MakeAdjTable[Length[odfacets],faAdj[[cotree]]];
    tr = Table[{i},{i,Length[facets]}];
    vervec = VerticalVector[odfacets];
    Do[{sptree,tr,odfacets,vervec} = Unfold[sptree,tr,N[odfacets],vervec];
       ,{i,1,Length[odfacets]-1}];
    Graphics3D[({If[MemberQ[faAdj,Sort[{s,#}]],Red,
                                  If[s==#,Yellow,Green]], 
                     Polygon[odfacets[[#]]]}&/@Range@Length@odfacets)]
    ]

Get the SnubCube (or any other polyhedron) description in the format required by Fukuda's code and run it.

cddml = Install["c:\\Downloads\\cddml_w32new"]
<< "c:\\Downloads\\UnfoldPolytope2.m"

inedata = -Flatten /@ (CoefficientArrays[#, {x, y, z}] & /@ ((List @@@ 
             PolyhedronData["SnubCube", "RegionFunction"])[x, y, z] /. 
             GreaterEqual[x__, y__] :> LessEqual[-x + y, 0] /. 
             LessEqual :> Equal)) // N;
{m, d}    = Dimensions@inedata;
{{extlist, linearity}, ecdlist, eadlist, icdlist0, iadlist0} = 
                               AllVerticesWithAdjacency[m, d, Flatten@inedata];
icdlist   = Most@icdlist0;
vlist     = Rest /@ extlist;
facets    = (vlist[[#1]] &) /@ icdlist;
facets1   = OrderFacets[facets];

t = UnfoldPolytope[facets1, #] & /@ Range@Length@facets1;
Export["c:\\test.gif", t, "DisplayDurations" -> 2];

Uninstall[cddml]