# Finding Kuratowski subdivisions of nonplanar graphs

The graph

Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 1 <-> 5, 2 <-> 6, 3 <-> 7, 4 <-> 8, 5 <-> 9, 6 <-> 10,
7 <-> 11, 8 <-> 12, 9 <-> 13, 10 <-> 14, 11 <-> 14, 12 <-> 14, 13 <-> 14, 2 <-> 3,
3 <-> 4, 4 <-> 5, 10 <-> 11, 11 <-> 12, 12 <-> 13, 6 <-> 8, 7 <-> 9}]


which looks like is nonplanar, according to PlanarGraphQ

My question is, does Mathematica have commands which will help me find Kuratowski subdivisions in my graph, i.e. witnesses to its non-planarity ?

I would like to automate this using Mathematica, rather than do it by hand, because in future my graphs might be much larger.

I believe that the Open Graph Drawing Framework (OGDF), available on Github, can do this, but I would like to do it within Mathematica, if possible.

Other evidence of nonplanarity would also be useful, i.e. any sufficient condition for nonplanarity, that I can demonstrate using Mathematica.

Thank you.

EDIT:

I have already shown that there are no subgraphs isomorphic to $K_5$ or $K_{3,3}$, using Mathematica like this

subgraphsoforderfive =  Map[Subgraph[nonplanarminimalfourbyfournetwork, #] &,
Subsets[Range, {5}]];
Map[IsomorphicGraphQ[CompleteGraph, #] &, subgraphsoforderfive]


and this

subgraphsofordersix = Map[Subgraph[nonplanarminimalfourbyfournetwork, #] &,
Subsets[Range, {6}]];
Select[subgraphsofordersix, IsomorphicGraphQ[CompleteGraph[{3, 3}], #] &]


where nonplanarminimalfourbyfournetwork is the graph above.

• According to what I've learned from Wikipedia, several algorithms exist which will solve this problem in linear time. Many seem to use depth-first traversals of spanning trees for the graph. I would imagine that PlanarGraphQ uses state of the art algorithms in such a way that it could return the Kuratowski subdivisions in a nonplanar graph with ease. My question here is whether it is possible for users to access that part of PlanarGraphQ. If not, then I look forward to learning about some of those algorithms, and coding one myself in Mathematica, when I have more time ! – Simon Oct 10 '15 at 19:40
• If you need faster subgraph isomorphism testing, IGraph/M has that. – Szabolcs Oct 10 '15 at 19:56
• Thank you very much @Szabolcs. In fact for the time being the subgraph isomorphism testing is quite fast enough. The bigger problem is that I don't only want to know whether my graph has subgraphs isomorphic to $K_{3,3}$ or $K_5$ (it doesn't) but more generally, since it must have subgraphs isomorphic to subdivisions of $K_{3,3}$ or $K_5$, where are they in the big graph ? – Simon Oct 10 '15 at 20:02
• en.wikipedia.org/wiki/Kuratowski%27s_theorem – Simon Oct 10 '15 at 20:04
• The LTemplate package includes an example (Documentation/Examples) that exposes the Kuratowski subdivision finding functionality of the Boost Graph Library. However, the results it produces are often not very practical. – Szabolcs Nov 10 '17 at 12:14

Here is a (roughly?) quadratic algorithm (in the number of edges) making use of PlanarGraphQ as a black box. The strategy is to delete as many edges as possible while keeping the graph nonplanar. Each iteration of the While loop does the following: it removes edges starting from the last one until the graph becomes planar, then puts the last edge removed at the start of the edge list. This edge cannot be removed without making the graph planar. Doing the loop collects such unremovable edges until there is no other edge left to look at. Note that PlanarGraphQ is called Length[EdgeList[g]] times. The Unsubdivide function simply contracts vertices of degree 2 to get either $K_5$ or $K_{3,3}$ as an output. It's not entirely clear what information you want to keep at the end (e.g. the list of vertices in an edge of the contracted graph) so I've not kept anything (other than vertex names).

ClearAll[KuratowskiSubgraph, UnSubdivide];
Module[{edges, nfound, pos},
KuratowskiSubgraph[g_Graph] := (
edges = DeleteDuplicatesBy[EdgeList[g], Sort];
nfound = 0;
While[nfound < Length[edges],
pos = SelectFirst[Range[Length[edges] - 1, nfound, -1],
PlanarGraphQ[Graph[edges[[;; #]]]] &];
edges = Join[{edges[[pos + 1]]}, edges[[;; pos]]];
nfound += 1];
Graph[edges]);
];
UnSubdivide[g_Graph] :=
Graph[Fold[#1 /. {el1___, UndirectedEdge[a___, #2, b___],
el2___, UndirectedEdge[c___, #2, d___], el3___} :>
{el1, el2, el3, UndirectedEdge[a, b, c, d]} &,
EdgeList[g],
Select[VertexList[g], VertexDegree[g, #] == 2 &]]];


On the example you gave,

g = Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 1 <-> 5, 2 <-> 6, 3 <-> 7,
4 <-> 8, 5 <-> 9, 6 <-> 10, 7 <-> 11, 8 <-> 12, 9 <-> 13,
10 <-> 14, 11 <-> 14, 12 <-> 14, 13 <-> 14, 2 <-> 3, 3 <-> 4,
4 <-> 5, 10 <-> 11, 11 <-> 12, 12 <-> 13, 6 <-> 8, 7 <-> 9}]
g2 = KuratowskiSubgraph[g]
g3 = UnSubdivide[g2]


gives $K_{3,3}$ with vertices 1,3,6 connected to vertices 2,4,14. Looking at InputForm[g2] we can see what edges of the original graph connect 1 to 14 for instance: 1-5-9-13-14.

• Thank you. That looks very nice !! – Simon May 21 '17 at 14:16
• According to "Depth-first search and Kuratowski subgraphs" by Williamson, which gives an linear-time algorithm that I don't understand, one can initially decide to keep only $3|V|-5$ edges chosen at random (where $|V|$ is the number of vertices). Adding this step should make my algorithm quadratic in the number of vertices instead of edges. – Bruno Le Floch May 21 '17 at 15:11
• In concrete cases it is apparently pretty common for non-planar graphs to have many Kuratowski subgraphs. @Simon, can you post a bit more information about the kinds of graphs you end up testing? Perhaps someone can write some more clever code then. – Bruno Le Floch May 21 '17 at 17:52

IGraph/M now has functionality to work with planar graphs. Raspberry Pi support is still missing in release 0.3.100, but it will be re-added soon.

g = Graph[{1 <-> 2, 1 <-> 3, 1 <-> 4, 1 <-> 5, 2 <-> 6, 3 <-> 7,
4 <-> 8, 5 <-> 9, 6 <-> 10, 7 <-> 11, 8 <-> 12, 9 <-> 13,
10 <-> 14, 11 <-> 14, 12 <-> 14, 13 <-> 14, 2 <-> 3, 3 <-> 4,
4 <-> 5, 10 <-> 11, 11 <-> 12, 12 <-> 13, 6 <-> 8, 7 <-> 9}] Check that the graph is not planar:

IGPlanarQ[g]
(* False *)


We can find a Kuratowski subgraph as a set of edges:

kuratowski = IGKuratowskiEdges[g]
(* {11 \[UndirectedEdge] 12, 10 \[UndirectedEdge] 11,
8 \[UndirectedEdge] 12, 7 \[UndirectedEdge] 9,
7 \[UndirectedEdge] 11, 6 \[UndirectedEdge] 10,
5 \[UndirectedEdge] 9, 4 \[UndirectedEdge] 5, 4 \[UndirectedEdge] 8,
3 \[UndirectedEdge] 4, 3 \[UndirectedEdge] 7, 2 \[UndirectedEdge] 6,
1 \[UndirectedEdge] 5, 1 \[UndirectedEdge] 3, 1 \[UndirectedEdge] 2} *)


If the graph were planar, the result would have been {}.

Highlight it in the original graph:

HighlightGraph[g, Graph[kuratowski]] Is this homeomorphic to $K_{3,3}$ or to $K_5$? Let's reduce it:

IGSmoothen[Graph[kuratowski]]


It has 6 vertices, so it must be $K_{3,3}$. Let's make that a bit more obvious using an appropriate visualization:

IGLayoutBipartite[%] Finally, let us also do an explicit test using IGHomeomorphicQ.

IGHomeomorphicQ[Graph[kuratowski], CompleteGraph[{3, 3}]]
(* True *)


As a side note, IGraph/M can also work with combinatorial embeddings of non-planar graphs.

Generate an embedding from the particular drawing of this graph:

emb = IGCoordinatesToEmbedding[g]
(* <|1 -> {4, 5, 2, 3}, 2 -> {3, 1, 6}, 3 -> {7, 4, 1, 2},
4 -> {5, 1, 3, 8}, 5 -> {9, 1, 4}, 6 -> {10, 8, 2}, 7 -> {9, 3, 11},
8 -> {12, 4, 6}, 9 -> {5, 7, 13}, 10 -> {14, 11, 6},
11 -> {14, 12, 7, 10}, 12 -> {13, 8, 11, 14}, 13 -> {9, 12, 14},
14 -> {13, 12, 11, 10}|> *)


The embedding is not planar:

IGPlanarQ[emb]
(* False *)


We can find the faces of this particular embedding:

IGFaces[emb]
(* {{1, 4, 5}, {1, 5, 9, 13, 14, 10, 6, 2}, {1, 2, 3}, {1, 3,
4}, {2, 6, 8, 4, 3, 7, 9, 5, 4, 8, 12, 13, 9, 7, 11, 12, 8, 6, 10,
11, 7, 3}, {10, 14, 11}, {11, 14, 12}, {12, 14, 13}} *)


It has 8 faces, which means that it can be drawn on a surface of genus 2 (according to Euler's formula):

genus[emb_?IGEmbeddingQ] := (2 + Total[Length /@ emb]/2 - Length[emb] - Length@IGFaces[emb])/2

genus[emb]
(* 2 *)


Of course, this doesn't prove that there isn't an embedding on a surface of smaller genus.

Also, we could have figured this out from looking at a 3D drawing of the graph:

Graph3D[g, VertexLabels -> Automatic] From this 3D visualization it's clear that removing 3 <-> 4 and 11 <-> 12 would make a drawing on a spherical surface possible (which is the same as planarity).

IGPlanarQ@EdgeDelete[g, {3 <-> 4, 11 <-> 12}]
(* True *)

• Fantastic ! Thank you very much Szabolcs ! I am now reading about combinatorial embeddings. – Simon Jun 27 '18 at 13:18