Decomposing Polyhedra

The idea behind this notebook is that computing the gram matrix of a very large polyhedron is very difficult, but computing the gram matrix of a smaller polyhedron is much easier. Furthermore, as established in the glue.nb notebook, we have a method of gluing polyhedra together that satisfy certain criteria. So this might help compute the gram matrices of large, complicated polyhedra.

Dependencies

This notebook uses IGraphM for computing the duals of polyhedra, finding cycles in a graph, and checking whether graphs are planar and/or 3-connected.

Get["https://raw.githubusercontent.com/szhorvat/IGraphM/master/IGInstaller.m"];

<<IGraphM`

Import Polyhedra

Function to convert some representation of a graph to mathematica’s representation. You can give it the option `format->graph6` if in graph6 format.

Clear[format,edgeList,graph6];
Options[graphFromPlantri]={format->edgeList};
graphFromPlantri[data_,OptionsPattern[]]:=If[format===edgeList,PlanarGraph[Graph[Partition[ToExpression[StringCases[data,DigitCharacter..]],2]/.{x_,y_}->(x\[UndirectedEdge]y)],VertexLabels->"Name"],
PlanarGraph[ImportString[data,"Graph6"],VertexLabels->"Name"]]

Polyhedra Decomposition

Heads up: I think these functions are quite a bit buggy, but it’s hard to tell for sure. It’s not super useful anyway, since we can’t verify that the faces are compatible just from the graph alone.

Function to tell if a polyhedron is prime, i.e. cannot be decomposed. About  and not likely able to improve. There are about  possible cycles (it’s been rigorously proven to be P-hard to count the number of cycles), and I don’t see a way of getting around that. This algorithm basically works by checking if any cycle splits the polyhedron into two polyhedra (i.e. 3-connected planar graphs). If so, it is not prime.

primePolyhedronQ[graph_]:=Block[{cycles,valid,faceDecomposable,vertexDecomposable,dualGraph},
cycles=FindCycle[graph,Infinity,All]/.(x_\[UndirectedEdge]y_)->x;
valid=Select[cycles,Not[IGConnectedQ[VertexDelete[graph,#]]]&];
faceDecomposable=AnyTrue[valid,With[{components=ConnectedComponents[VertexDelete[graph,#]]},
KVertexConnectedGraphQ[Subgraph[graph,Join[components[[1]],#]],3]&&KVertexConnectedGraphQ[Subgraph[graph,Join[components[[2]],#]],3]]&];
If[faceDecomposable,Return[False]];
dualGraph=IGDualGraph[graph];
cycles=FindCycle[dualGraph,Infinity,All]/.(x_\[UndirectedEdge]y_)->x;
valid=Select[cycles,Not[IGConnectedQ[VertexDelete[dualGraph,#]]]&];
Not[AnyTrue[valid,With[{components=ConnectedComponents[VertexDelete[dualGraph,#]]},
KVertexConnectedGraphQ[Subgraph[dualGraph,Join[components[[1]],#]],3]&&KVertexConnectedGraphQ[Subgraph[dualGraph,Join[components[[2]],#]],3]]&]]
]

Function to find the possible decompositions of a graph. Returns a list where the first element of the list is the number of possible face decompositions and the second is the number of possible vertex decompositions. This corresponds to face gluing (the kind of gluing we’ve been working with) and vertex gluing (like in Kontorovich’s students’ paper). Should be easy to modify to actually return the decompositions. I wonder if we could extend this recursively to “prime factorize” polyhedra? Such a “factorization” clearly won’t be unique, however. Note that these decompositions might not actually work for the purposes of glue.nb, as the faces might not be “compatible,” e.g. a square face glued onto a rhombus.

decomposable[graph_]:=Block[{cycles,valid,faceDecomposable,vertexDecomposable,dualGraph},
cycles=FindCycle[graph,Infinity,All]/.(x_\[UndirectedEdge]y_)->x;
valid=Select[cycles,Not[IGConnectedQ[VertexDelete[graph,#]]]&];
faceDecomposable=Length[Select[valid,With[{components=ConnectedComponents[VertexDelete[graph,#]]},
KVertexConnectedGraphQ[Subgraph[graph,Join[components[[1]],#]],3]||KVertexConnectedGraphQ[Subgraph[graph,Join[components[[2]],#]],3]]&]];
dualGraph=IGDualGraph[graph];
cycles=FindCycle[dualGraph,Infinity,All]/.(x_\[UndirectedEdge]y_)->x;
valid=Select[cycles,Not[IGConnectedQ[VertexDelete[dualGraph,#]]]&];
vertexDecomposable=Length[Select[valid,With[{components=ConnectedComponents[VertexDelete[dualGraph,#]]},
KVertexConnectedGraphQ[Subgraph[dualGraph,Join[components[[1]],#]],3]||KVertexConnectedGraphQ[Subgraph[dualGraph,Join[components[[2]],#]],3]]&]];
{faceDecomposable,vertexDecomposable}
]

Slight modification of the above function to actually return the possible decompositions.

decompositions[graph_]:=Block[{cycles,valid,faceDecomposable,vertexDecomposable,dualGraph,faceDecompositions,vertexDecompositions},
cycles=FindCycle[graph,Infinity,All]/.(x_\[UndirectedEdge]y_)->x;
valid=Select[cycles,Not[IGConnectedQ[VertexDelete[graph,#]]]&];
faceDecomposable=Select[valid,With[{components=ConnectedComponents[VertexDelete[graph,#]]},
KVertexConnectedGraphQ[Subgraph[graph,Join[components[[1]],#]],3]&&KVertexConnectedGraphQ[Subgraph[graph,Join[components[[2]],#]],3]]&];
faceDecompositions=Table[With[{components=ConnectedComponents[VertexDelete[graph,cycle]]},
{Subgraph[graph,Join[components[[1]],cycle]],Subgraph[graph,Join[components[[2]],cycle]]}],{cycle,faceDecomposable}];
dualGraph=IGDualGraph[graph];
cycles=FindCycle[dualGraph,Infinity,All]/.(x_\[UndirectedEdge]y_)->x;
valid=Select[cycles,Not[IGConnectedQ[VertexDelete[dualGraph,#]]]&];
vertexDecomposable=Select[valid,With[{components=ConnectedComponents[VertexDelete[dualGraph,#]]},
KVertexConnectedGraphQ[Subgraph[dualGraph,Join[components[[1]],#]],3]&&KVertexConnectedGraphQ[Subgraph[dualGraph,Join[components[[2]],#]],3]]&];
vertexDecompositions=Table[With[{components=ConnectedComponents[VertexDelete[dualGraph,cycle]]},
{Subgraph[dualGraph,Join[components[[1]],cycle]],Subgraph[dualGraph,Join[components[[2]],cycle]]}],{cycle,vertexDecomposable}];
{faceDecompositions,vertexDecompositions}
]

Function to read data from a file and convert it into a list of graphs. The easiest way to use this is to download a massive list from plantri (in graph6 format if it is very large, to keep the file small), and give that filename here. I highly recommend you put a semicolon at the end of that line to suppress the output; it tends to be pretty massive.

readData[filename_]:=graphFromPlantri[#,format->graph6]&/@Flatten[StringSplit[ReadList[FileNameJoin[{NotebookDirectory[],filename}],String],": "]][[2;;-1;;2]]