Unfoldings of the tesseract

Here’s my solution to Joseph O’Rourke’s MathOverflow question for an enumeration of the unfoldings of the tesseract into 3D.  The question was addressed in an article in The Journal of Recreational Mathematics, reprinted here.  The basic idea is to write a bijection between so-called “paired trees” with 8 nodes and the unfoldings.  The paper shows the paired trees but not really the resulting unfoldings, which is the remaining piece that O’Rourke is asking about.

It’s easier to look at the 2D unfoldings first.

Unfoldings of the cube into 2D

A cube has 6 faces and an unfolding of a cube yields a tree structure where two nodes are adjacent iff the corresponding squares share an edge in the unfolding.  Furthermore, the nodes come in opposite face pairs which clearly cannot be adjacent.  This yields the idea of a paired tree - a tree where the nodes are paired so that no two adjacent nodes are paired.  The idea is to enumerate all possible paired trees and, then, generate an unfolding from each of these.

Six-pairings

Here’s the generation of the paired trees.  GraphData has all trees of order six, as well as their automorphism groups.

Do[
tree6[k]=GraphData[{"Tree",{6,k}}];
aut6[k] = GraphData[{"Tree",{6,k}},"AutomorphismGroup"],
{k,1,6}]

A pairing is simple a partition of the six vertices into three disjoint subsets of two vertices each.  We can sort them to put them into a cannonical form; there are then 15 such pairings.

pairsOfSix = Union[Map[Sort,Partition[#,2]& /@ Permutations[Range[6]],2]];
pairsOfSix//Length

Given a tree, a possible pair is a partition of the vertices such that no two adjacent vertices are paired.

possiblePairs[k_Integer] := Select[pairsOfSix,
Intersection[#,Sort /@ List@@@EdgeList[tree6[k]]]==={}&]

In addition, we must account for the symmetries of the graph.

samePairingQ[k_][pair1_,pair2_]:=MemberQ[Map[Sort,
PermutationReplace[pair2,aut6[k]],2],pair1];
actualPairs[k_Integer]:=Union[possiblePairs[k],SameTest->samePairingQ[k]]

There are 11 such paired trees.

Total[Length/@Table[actualPairs[k],{k,1,6}]]

Here’s what they look like.

colors={Red,Yellow,Blue};
showAllPairs[k_Integer]:=HighlightGraph[tree6[k],
MapIndexed[Style[#1,colors[[#2[[1]]]]]&,#,{2}],
VertexLabels->Placed["Name",Tooltip], ImageSize->250]& /@
actualPairs[k];
rows = Row/@Table[showAllPairs[k],{k,1,6}];
Framed/@ReplacePart[rows,{1,0}->Column]

Embedding the paired trees in the cube

Here’s a graph representing the connections between the faces of a cube.

facialConnections={1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]4,1\[UndirectedEdge]5,
2\[UndirectedEdge]6,3\[UndirectedEdge]6,4\[UndirectedEdge]6,5\[UndirectedEdge]6,
2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]5,2\[UndirectedEdge]5};

In 2D

faceGraph = Graph[Range[6],facialConnections,
VertexLabels -> "Name",
VertexCoordinates -> {{0,-1},
{1,-1/3},{1,1/3},{-1,1/3},{-1,-1/3},
{0,1}}]

And in 3D

faceGraph3D = Graph3D[Range[6],facialConnections,
VertexLabels -> "Name",ViewPoint -> {2,2,1},Boxed->True,
VertexCoordinates -> {{0,0,-1},{1,0,0},{0,1,0},{-1,0,0},{0,-1,0},{0,0,1}}]

The following function checks if a permutation mapping the six vertices of one of our paired trees to the six vertices of the facial graph is a legal homomorphism respecting the pairings.

(* Compute permutations that preserve pairings *)
Clear[pairedPermutations];
pairedPermutations[{a_Integer,b_Integer},{c_Integer,d_Integer}] := {
{a->c,b->d},{a->d,b->c}
};
pairedPermutations[pairs1_List,pairs2_List] := Module[
{pairedPairs,mappedPairs,arbitraryHead},
pairedPairs = Transpose[{pairs1,#}]& /@ Permutations[pairs2];
mappedPairs = Apply[pairedPermutations,pairedPairs,{2}];
Join@@@Flatten@Apply[Outer[arbitraryHead,##,1]&,mappedPairs,{1}]]

Clear[checkHomomorphism];
checkHomomorphism[tree_Graph, pairs_List, permutation_List] := Module[
{treeEdges, permutationRules,permutedEdges,permutedPairs},
treeEdges = EdgeList[tree];
permutedEdges = Sort[Sort/@(treeEdges/.permutation)];
Intersection[permutedEdges,facialConnections]===permutedEdges];

We can visualize such a homorphism as follows.

Clear[visualizeHomomorphism];
visualizeHomomorphism[tree_Graph,permutation_List] := Module[
{treeEdges, permutationRules,permutedEdges},
treeEdges = EdgeList[tree];
permutedEdges = Sort[Sort/@(treeEdges/.permutation)];
HighlightGraph[faceGraph,permutedEdges,
GraphHighlightStyle->"Thick"]];

visualizeHomomorphism[tree6[4],Thread[Range[6]->{1,6,2,4,3,5}]]

Or, in 3D.

visualizeHomomorphism3D[tree_Graph,permutation_List] := Module[
{treeEdges, permutationRules,permutedEdges},
treeEdges = EdgeList[tree];
permutationRules = Thread[Range[6]->permutation];
permutedEdges = Sort[Sort/@(treeEdges/.permutationRules)];
HighlightGraph[faceGraph3D,permutedEdges]];

visualizeHomomorphism3D[tree6[4],{1,6,2,4,3,5}]

Now, let's embed each of them into the facial graph.

good = Table[
{tree6[i],First@Select[
pairedPermutations[actualPairs[i][[j]],{{1,6},{2,4},{3,5}}],
checkHomomorphism[tree6[i],UndirectedEdge@@@actualPairs[i][[j]],#]&,1]},
{i,1,6},{j,1,Length[actualPairs[i]]}];//AbsoluteTiming

And check.

good /. {g_Graph,perm_List} :> visualizeHomomorphism[g,perm]

To the plane

To unfold one of these trees into the plane, we’ll traverse the tree and use the adjacency information from the cube to figure out how to place the squares down.

Here’s one way to look at the cube.

pairedSquares = {
{vertexIndices[1]={1,2,3,4},
vertexIndices[6]={5,6,8,7}},
{vertexIndices[2]={1,5,7,2},
vertexIndices[4]={4,3,8,6}},
{vertexIndices[3]={1,4,6,5},
vertexIndices[5]={3,2,7,8}}
};
squares = Flatten[pairedSquares,1];
directedEdges = Flatten[Apply[DirectedEdge,
Partition[#,2,1,1]& /@ squares,{2}]];
Graph[Range[8],directedEdges,VertexCoordinates -> {
{-2,2},{2,2},{2,-2},{-2,-2},
{-1,1},{-1,-1},{1,1},{1,-1}},
VertexLabels -> "Name"]

allGood = Flatten[good,1];
otherNeighbor[{v1_,v2_},square_List]:= First[Complement[
Union@@Select[Partition[square,2,1,1],MemberQ[#,v1]&],
{v1,v2}]];
visit[v1_,v2_]:=Module[{commonIndices,commonCoordinates,direction,
otherNeighborIndex1,otherNeighborIndex2},
commonIndices=Intersection[vertexIndices[v1],vertexIndices[v2]];
commonCoordinates = Thread[commonIndices->(commonIndices /.vertexCoordinates[v1])];
direction = Sign[Mean[(commonIndices /. commonCoordinates)]-center[v1]];
center[v2] = center[v1]+direction;
otherNeighborIndex1 = otherNeighbor[commonIndices,vertexIndices[v2]];
otherNeighborIndex2 = otherNeighbor[Reverse[commonIndices],vertexIndices[v2]];
vertexCoordinates[v2]=Join[commonCoordinates,
{otherNeighborIndex1 -> ((commonIndices[[1]] /.vertexCoordinates[v1])+direction),
otherNeighborIndex2 -> ((commonIndices[[2]] /.vertexCoordinates[v1])+direction)}];
{direction,center[v2],vertexCoordinates[v1],vertexCoordinates[v2]}
];

Table[
Clear[vertexCoordinates,center];
g = Graph[Range[6],EdgeList[allGood[[i,1]]] /. allGood[[i,2]]];
center[1] = {1/2,1/2};
vertexCoordinates[1]=Thread[vertexIndices[1]->{{0,0},{1,0},{1,1},{0,1}}];
DepthFirstScan[g,1,{"VisitedVertex"->visit}];
Graphics[{Opacity[0.5],EdgeForm[Black],
Table[Polygon[vertexIndices[v] /. vertexCoordinates[v]],{v,1,6}]
},Axes->True],
{i,1,Length[allGood]}]

Unfolding the tesseract into 3D

The eight-pairings

This part is nearly identical to the cube.  There are 261 paired trees on 8 nodes.

Do[
tree8[k]=GraphData[{"Tree",{8,k}}];
aut8[k] = GraphData[{"Tree",{8,k}},"AutomorphismGroup"],
{k,1,23}]
pairsOfEight = Union[Map[Sort,Partition[#,2]& /@ Permutations[Range[8]],2]];
possiblePairs[k_Integer] := Select[pairsOfEight,
Intersection[#,Sort /@ List@@@EdgeList[tree8[k]]]==={}&]
samePairingQ[k_][pair1_,pair2_]:=MemberQ[Map[Sort,
PermutationReplace[pair2,aut8[k]],2],pair1]
actualPairs[k_Integer]:=Union[possiblePairs[k],SameTest->samePairingQ[k]]
Table[actualPairs[k],{k,1,23}];
Total[Length/@%]

Hers’s an unnecessary visualization.

colors={Red,Yellow,Blue,Green};
showAllPairs[k_Integer]:=HighlightGraph[tree8[k],
MapIndexed[Style[#1,colors[[#2[[1]]]]]&,#,{2}],
VertexLabels->Placed["Name",Tooltip], ImageSize->250]& /@
actualPairs[k];
rows = Row/@Table[showAllPairs[k],{k,1,23}];
Framed/@ReplacePart[rows,{1,0}->Column]

The tesseract facial graph

The idea is to embed the paired trees into the graph representing the facial connectivity of the tesseract.

n = 4;
facialConnections = Union[Sort/@Flatten[Table[{
2i\[UndirectedEdge]#& /@ Complement[Range[2n],{2i,2i-1}],
2i-1\[UndirectedEdge]#& /@ Complement[Range[2n],{2i,2i-1}]},
{i,1,n}]]]

Note that paired vertices in the facial graph (indicated by color) are never connected.

facialGraph = Graph[Range[8],facialConnections,
VertexStyle -> {1->Red,2->Red,3->Yellow,4->Yellow,5->Blue,6->Blue,7->Green,8->Green},
VertexLabels->"Name"]

These functions will be used to embed the paired trees into the facial graph.

(* Compute permutations that preserve pairings *)
Clear[pairedPermutations, checkHomomorphism];
pairedPermutations[{a_Integer,b_Integer},{c_Integer,d_Integer}] := {
{a->c,b->d},{a->d,b->c}
};
pairedPermutations[pairs1_List,pairs2_List] := Module[
{pairedPairs,mappedPairs,arbitraryHead},
pairedPairs = Transpose[{pairs1,#}]& /@ Permutations[pairs2];
mappedPairs = Apply[pairedPermutations,pairedPairs,{2}];
Join@@@Flatten@Apply[Outer[arbitraryHead,##,1]&,mappedPairs,{1}]]
checkHomomorphism[tree_Graph, pairs_List, permutation_List] := Module[
{treeEdges, permutationRules,permutedEdges,permutedPairs},
treeEdges = EdgeList[tree];
permutedEdges = Sort[Sort/@(treeEdges/.permutation)];
Intersection[permutedEdges,facialConnections]===permutedEdges];

We ca visualize such a homorphism as follows.

Clear[visualizeHomomorphism];
visualizeHomomorphism[tree_Graph,permutation_List] := Module[
{treeEdges, permutationRules,permutedEdges},
treeEdges = EdgeList[tree];
permutedEdges = Sort[Sort/@(treeEdges/.permutation)];
HighlightGraph[facialGraph,permutedEdges,
GraphHighlightStyle -> "Thick"]];

visualizeHomomorphism[tree8[1],Thread[Range[8]->{1,3,2,4,5,7,6,8}]]

Generate all embeddings of the paired trees into the facial graph.  Takes a half minute or so.

good = Monitor[Table[
{tree8[i],First@Select[
pairedPermutations[actualPairs[i][[j]],
{{1,2},{3,4},{5,6},{7,8}}],
checkHomomorphism[tree8[i],UndirectedEdge@@@actualPairs[i][[j]],#]&,1]},
{i,1,22},{j,1,Length[actualPairs[i]]}],
{i,j}];//AbsoluteTiming

And check.

good /. {g_Graph,perm_List} :> visualizeHomomorphism[g,perm]

Unfold into space

(* Used this visualization to help with the following parts *)
tesseract = Graph3D[Range[8],
{1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]1,
5\[UndirectedEdge]6,6\[UndirectedEdge]7,7\[UndirectedEdge]8,8\[UndirectedEdge]5,
1\[UndirectedEdge]5,2\[UndirectedEdge]6,3\[UndirectedEdge]7,4\[UndirectedEdge]8,
9\[UndirectedEdge]10,10\[UndirectedEdge]11,11\[UndirectedEdge]12,12\[UndirectedEdge]9,
13\[UndirectedEdge]14,14\[UndirectedEdge]15,15\[UndirectedEdge]16,16\[UndirectedEdge]13,
9\[UndirectedEdge]13,10\[UndirectedEdge]14,11\[UndirectedEdge]15,12\[UndirectedEdge]16,
1\[UndirectedEdge]9,2\[UndirectedEdge]10,3\[UndirectedEdge]11,4\[UndirectedEdge]12,
5\[UndirectedEdge]13,6\[UndirectedEdge]14,7\[UndirectedEdge]15,8\[UndirectedEdge]16},
VertexCoordinates -> {
{2,2,2},{-2,2,2},{-2,-2,2},{2,-2,2},
{2,2,-2},{-2,2,-2},{-2,-2,-2},{2,-2,-2},
{1,1,1},{-1,1,1},{-1,-1,1},{1,-1,1},
{1,1,-1},{-1,1,-1},{-1,-1,-1},{1,-1,-1}
}, VertexLabels -> "Name"]

The following information is used when laying down the cuboids in space.

Clear[vertexIndices];
cubeGraph[1] = {
1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]1,
5\[UndirectedEdge]6,6\[UndirectedEdge]7,7\[UndirectedEdge]8,8\[UndirectedEdge]5,
1\[UndirectedEdge]5,2\[UndirectedEdge]6,3\[UndirectedEdge]7,4\[UndirectedEdge]8};
cubeGraph[2] = {
9\[UndirectedEdge]10,10\[UndirectedEdge]11,11\[UndirectedEdge]12,12\[UndirectedEdge]9,
13\[UndirectedEdge]14,14\[UndirectedEdge]15,15\[UndirectedEdge]16,16\[UndirectedEdge]13,
9\[UndirectedEdge]13,10\[UndirectedEdge]14,11\[UndirectedEdge]15,12\[UndirectedEdge]16};
cubeGraph[3] = {
1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]1,
9\[UndirectedEdge]10,10\[UndirectedEdge]11,11\[UndirectedEdge]12,12\[UndirectedEdge]9,
1\[UndirectedEdge]9,2\[UndirectedEdge]10,3\[UndirectedEdge]11,4\[UndirectedEdge]12};
cubeGraph[4] = {
5\[UndirectedEdge]6,6\[UndirectedEdge]7,7\[UndirectedEdge]8,8\[UndirectedEdge]5,
13\[UndirectedEdge]14,14\[UndirectedEdge]15,15\[UndirectedEdge]16,16\[UndirectedEdge]13,
5\[UndirectedEdge]13,6\[UndirectedEdge]14,7\[UndirectedEdge]15,8\[UndirectedEdge]16};
cubeGraph[5] = {
2\[UndirectedEdge]3,3\[UndirectedEdge]7,7\[UndirectedEdge]6,6\[UndirectedEdge]2,
10\[UndirectedEdge]11,11\[UndirectedEdge]15,15\[UndirectedEdge]14,14\[UndirectedEdge]10,
2\[UndirectedEdge]10,3\[UndirectedEdge]11,7\[UndirectedEdge]15,6\[UndirectedEdge]14};
cubeGraph[6] = {
1\[UndirectedEdge]4,4\[UndirectedEdge]8,8\[UndirectedEdge]5,5\[UndirectedEdge]1,
9\[UndirectedEdge]12,12\[UndirectedEdge]16,16\[UndirectedEdge]13,13\[UndirectedEdge]9,
1\[UndirectedEdge]9,4\[UndirectedEdge]12,8\[UndirectedEdge]16,5\[UndirectedEdge]13};
cubeGraph[7] = {
3\[UndirectedEdge]4,4\[UndirectedEdge]8,8\[UndirectedEdge]7,7\[UndirectedEdge]3,
11\[UndirectedEdge]12,12\[UndirectedEdge]16,16\[UndirectedEdge]15,15\[UndirectedEdge]11,
3\[UndirectedEdge]11,4\[UndirectedEdge]12,8\[UndirectedEdge]16,7\[UndirectedEdge]15};
cubeGraph[8] = {
1\[UndirectedEdge]2,2\[UndirectedEdge]6,6\[UndirectedEdge]5,5\[UndirectedEdge]1,
9\[UndirectedEdge]10,10\[UndirectedEdge]14,14\[UndirectedEdge]13,13\[UndirectedEdge]9,
1\[UndirectedEdge]9,2\[UndirectedEdge]10,6\[UndirectedEdge]14,5\[UndirectedEdge]13};
vertexIndices[i_]:= vertexIndices[i]=Union[Sequence@@@cubeGraph[i]]
vertexCoordinates[1]=Thread[vertexIndices[1]->{
{1,1,1},{0,1,1},{0,0,1},{1,0,1},{1,1,0},{0,1,0},{0,0,0},{1,0,0}
}];

allGood = Flatten[good,1];

(* Experiment with one of them *)
Clear[vertexCoordinates,center];
g = Graph[Range[8],EdgeList[allGood[[100,1]]] /. allGood[[100,2]],
VertexLabels->"Name"];
center[1] = {1/2,1/2,1/2};
vertexCoordinates[1]=Thread[vertexIndices[1]->{
{1,1,1},{0,1,1},{0,0,1},{1,0,1},{1,1,0},{0,1,0},{0,0,0},{1,0,0}
}];

(* We'll run a DepthFirstScan with this visitation funciton *)
visit[v1_,v2_]:=Module[{commonIndices,commonCoordinates,direction,
otherNeighborIndex1,otherNeighborIndex2,nextVertices,indexedCoordinate},
commonIndices=Intersection[vertexIndices[v1],vertexIndices[v2]];
commonCoordinates = Thread[commonIndices->(commonIndices /.vertexCoordinates[v1])];
direction = Sign[Mean[(commonIndices /. commonCoordinates)]-center[v1]];
center[v2] = center[v1]+direction;
indexedCoordinate[{i_,j_}] := j->((i/.vertexCoordinates[v1])+direction);
nextVertices = Flatten[{#,Complement[AdjacencyList[Graph[cubeGraph[v2]],#],
commonIndices]}]&/@commonIndices;
vertexCoordinates[v2]=Join[commonCoordinates,
indexedCoordinate /@ nextVertices
];
{direction,center[v2],vertexCoordinates[v1],vertexCoordinates[v2]}
];

DepthFirstScan[g,1,{"VisitedVertex"->visit}]

Graphics3D[{Opacity[0.9],
Table[Cuboid@@Sort[vertexIndices[v] /. vertexCoordinates[v]][[{1,-1}]],{v,1,8}]
}, Boxed->False]

OK, here’s all of them.

results = Table[
Clear[vertexCoordinates,center];
g = Graph[Range[8],EdgeList[allGood[[i,1]]] /. allGood[[i,2]]];
center[1] = {1/2,1/2,1/2};
vertexCoordinates[1]=Thread[vertexIndices[1]->{
{1,1,1},{0,1,1},{0,0,1},{1,0,1},{1,1,0},{0,1,0},{0,0,0},{1,0,0}
}];
DepthFirstScan[g,1,{"VisitedVertex"->visit}];
Graphics3D[{Opacity[0.9],
Table[Cuboid@@Sort[vertexIndices[v] /. vertexCoordinates[v]][[{1,-1}]],{v,1,8}]
}, Boxed->False],
{i,1,Length[allGood]}];
Length[results]
results

All code in one

If you just want to generate the images, the following code executed from a fresh kernel should do the job.  Takes less than a minute on my machine.  The trees on 8 vertices, along with their automorphism groups are loaded using GraphData so, if you haven’t used that before, it might take a while the first run.  Should be cached after that.

t=AbsoluteTime[];
Do[
tree8[k]=GraphData[{"Tree",{8,k}}];
aut8[k] = GraphData[{"Tree",{8,k}},"AutomorphismGroup"],
{k,1,23}];
pairsOfEight = Union[Map[Sort,Partition[#,2]& /@ Permutations[Range[8]],2]];
possiblePairs[k_Integer] := Select[pairsOfEight,
Intersection[#,Sort /@ List@@@EdgeList[tree8[k]]]==={}&]
samePairingQ[k_][pair1_,pair2_]:=MemberQ[Map[Sort,
PermutationReplace[pair2,aut8[k]],2],pair1];
actualPairs[k_Integer]:=Union[possiblePairs[k],SameTest->samePairingQ[k]];

n = 4;
facialConnections = Union[Sort/@Flatten[Table[{
2i\[UndirectedEdge]#& /@ Complement[Range[2n],{2i,2i-1}],
2i-1\[UndirectedEdge]#& /@ Complement[Range[2n],{2i,2i-1}]},
{i,1,n}]]];
(* Compute permutations that preserve pairings *)
Clear[pairedPermutations];
pairedPermutations[{a_Integer,b_Integer},{c_Integer,d_Integer}] := {
{a->c,b->d},{a->d,b->c}
};
pairedPermutations[pairs1_List,pairs2_List] := Module[
{pairedPairs,mappedPairs,arbitraryHead},
pairedPairs = Transpose[{pairs1,#}]& /@ Permutations[pairs2];
mappedPairs = Apply[pairedPermutations,pairedPairs,{2}];
Join@@@Flatten@Apply[Outer[arbitraryHead,##,1]&,mappedPairs,{1}]]
Clear[checkHomomorphism];
checkHomomorphism[tree_Graph, pairs_List, permutation_List] := Module[
{treeEdges, permutationRules,permutedEdges,permutedPairs},
treeEdges = EdgeList[tree];
permutedEdges = Sort[Sort/@(treeEdges/.permutation)];
Intersection[permutedEdges,facialConnections]===permutedEdges];

(* This part takes a minute *)
good = Table[
{tree8[i],First@Select[
pairedPermutations[actualPairs[i][[j]],
{{1,2},{3,4},{5,6},{7,8}}],
checkHomomorphism[tree8[i],UndirectedEdge@@@actualPairs[i][[j]],#]&,1]},
{i,1,22},{j,1,Length[actualPairs[i]]}];


Clear[vertexIndices];
cubeGraph[1] = {
1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]1,
5\[UndirectedEdge]6,6\[UndirectedEdge]7,7\[UndirectedEdge]8,8\[UndirectedEdge]5,
1\[UndirectedEdge]5,2\[UndirectedEdge]6,3\[UndirectedEdge]7,4\[UndirectedEdge]8};
cubeGraph[2] = {
9\[UndirectedEdge]10,10\[UndirectedEdge]11,11\[UndirectedEdge]12,12\[UndirectedEdge]9,
13\[UndirectedEdge]14,14\[UndirectedEdge]15,15\[UndirectedEdge]16,16\[UndirectedEdge]13,
9\[UndirectedEdge]13,10\[UndirectedEdge]14,11\[UndirectedEdge]15,12\[UndirectedEdge]16};
cubeGraph[3] = {
1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]1,
9\[UndirectedEdge]10,10\[UndirectedEdge]11,11\[UndirectedEdge]12,12\[UndirectedEdge]9,
1\[UndirectedEdge]9,2\[UndirectedEdge]10,3\[UndirectedEdge]11,4\[UndirectedEdge]12};
cubeGraph[4] = {
5\[UndirectedEdge]6,6\[UndirectedEdge]7,7\[UndirectedEdge]8,8\[UndirectedEdge]5,
13\[UndirectedEdge]14,14\[UndirectedEdge]15,15\[UndirectedEdge]16,16\[UndirectedEdge]13,
5\[UndirectedEdge]13,6\[UndirectedEdge]14,7\[UndirectedEdge]15,8\[UndirectedEdge]16};
cubeGraph[5] = {
2\[UndirectedEdge]3,3\[UndirectedEdge]7,7\[UndirectedEdge]6,6\[UndirectedEdge]2,
10\[UndirectedEdge]11,11\[UndirectedEdge]15,15\[UndirectedEdge]14,14\[UndirectedEdge]10,
2\[UndirectedEdge]10,3\[UndirectedEdge]11,7\[UndirectedEdge]15,6\[UndirectedEdge]14};
cubeGraph[6] = {
1\[UndirectedEdge]4,4\[UndirectedEdge]8,8\[UndirectedEdge]5,5\[UndirectedEdge]1,
9\[UndirectedEdge]12,12\[UndirectedEdge]16,16\[UndirectedEdge]13,13\[UndirectedEdge]9,
1\[UndirectedEdge]9,4\[UndirectedEdge]12,8\[UndirectedEdge]16,5\[UndirectedEdge]13};
cubeGraph[7] = {
3\[UndirectedEdge]4,4\[UndirectedEdge]8,8\[UndirectedEdge]7,7\[UndirectedEdge]3,
11\[UndirectedEdge]12,12\[UndirectedEdge]16,16\[UndirectedEdge]15,15\[UndirectedEdge]11,
3\[UndirectedEdge]11,4\[UndirectedEdge]12,8\[UndirectedEdge]16,7\[UndirectedEdge]15};
cubeGraph[8] = {
1\[UndirectedEdge]2,2\[UndirectedEdge]6,6\[UndirectedEdge]5,5\[UndirectedEdge]1,
9\[UndirectedEdge]10,10\[UndirectedEdge]14,14\[UndirectedEdge]13,13\[UndirectedEdge]9,
1\[UndirectedEdge]9,2\[UndirectedEdge]10,6\[UndirectedEdge]14,5\[UndirectedEdge]13};
vertexIndices[i_]:= vertexIndices[i]=Union[Sequence@@@cubeGraph[i]]
vertexCoordinates[1]=Thread[vertexIndices[1]->{
{1,1,1},{0,1,1},{0,0,1},{1,0,1},{1,1,0},{0,1,0},{0,0,0},{1,0,0}
}];

allGood = Flatten[good,1];

visit[v1_,v2_]:=Module[{commonIndices,commonCoordinates,direction,
otherNeighborIndex1,otherNeighborIndex2,nextVertices,indexedCoordinate},
commonIndices=Intersection[vertexIndices[v1],vertexIndices[v2]];
commonCoordinates = Thread[commonIndices->(commonIndices /.vertexCoordinates[v1])];
direction = Sign[Mean[(commonIndices /. commonCoordinates)]-center[v1]];
center[v2] = center[v1]+direction;
indexedCoordinate[{i_,j_}] := j->((i/.vertexCoordinates[v1])+direction);
nextVertices = Flatten[{#,Complement[AdjacencyList[Graph[cubeGraph[v2]],#],
commonIndices]}]&/@commonIndices;
vertexCoordinates[v2]=Join[commonCoordinates,
indexedCoordinate /@ nextVertices
];
{direction,center[v2],vertexCoordinates[v1],vertexCoordinates[v2]}
];

results = Table[
Clear[vertexCoordinates,center];
g = Graph[Range[8],EdgeList[allGood[[i,1]]] /. allGood[[i,2]]];
center[1] = {1/2,1/2,1/2};
vertexCoordinates[1]=Thread[vertexIndices[1]->{
{1,1,1},{0,1,1},{0,0,1},{1,0,1},{1,1,0},{0,1,0},{0,0,0},{1,0,0}
}];
DepthFirstScan[g,1,{"VisitedVertex"->visit}];
Graphics3D[{Opacity[0.9],
Table[Cuboid@@Sort[vertexIndices[v] /. vertexCoordinates[v]][[{1,-1}]],{v,1,8}]
}, Boxed->False],
{i,1,Length[allGood]}];
Length[results]
results
AbsoluteTime[]-t