# Finding face vertices from the face adjacency graph

Suppose that I have an adjacency matrix

M = {{0, 1, 0, 0, 1, 1, 0, 0},
{1, 0, 1, 0, 0, 0, 0, 1},
{0, 1, 0, 1, 0, 0, 1, 0},
{0, 0, 1, 0, 1, 0, 1, 0},
{1, 0, 0, 1, 0, 1, 0, 0},
{1, 0, 0, 0, 1, 0, 0, 1},
{0, 0, 1, 1, 0, 0, 0, 1},
{0, 1, 0, 0, 0, 1, 1, 0}}


that is known to be a planar graph. So I use the command GraphPlot[M] and give vertex labeling. The result is

There are 5 faces in the figure (exclude the outer face). The set of vertices of the faces is {{1,6,8,2}, {1,6,5},{4,5,6,8,7},{3,4,7},{2,3,7,8}}.

I don't know how to find this list of vertices automatically if I enter any adjacency matrix (I'm sure that all picked matrices are planar graphs due to PlanarGraph[M])

-
Define "face", please – Dr. belisarius Jan 26 '13 at 18:37
@belisarius think of the faces of a cube. – Sjoerd C. de Vries Jan 26 '13 at 18:53
Are you sure that you are on the right site? This site is dedicated to the program MathematicA, not to MathematicS. – Sjoerd C. de Vries Jan 26 '13 at 18:55
Do you already have the a layout of the graph (the vertex coordinates for each vertex)? If not, there probably isn't any already implemented simple existing way in Mathematica to lay out the graph without crossing edges. – Szabolcs Jan 27 '13 at 3:41
The difficulty here is that before you can talk about faces, you need to find an actual embedding of the graph in the plane, without crossing edges. None of Mathematica's built-in layout algorithms will guarantee you this. – Szabolcs Jan 27 '13 at 4:03

As Szaboics mentioned, you could use ordering (PlanarEmbedding) to find faces.

g = AdjacencyGraph[M, GraphLayout -> "PlanarEmbedding",
VertexLabels -> "Name", ImagePadding -> 5]


The following function will find next vertex of the face based on the given planar embedding:

nextCandidate[s_, t_, adj_] :=
Block[{ length, pos},
pos = Mod[Position[adj, s][[1, 1]] + 1, length, 1];
];


The main function to get all faces:

FindFace[g_?PlanarGraphQ] :=
Block[{emb},
emb = GraphEmbedding[g, "PlanarEmbedding"];
FindFace[g, emb]
];

FindFace[g_?PlanarGraphQ, emb_] :=
Block[{m, orderings, pAdj, rightF, s, t, initial, face},
SortBy[Pick[VertexList[g], m[[v]], 1],
ArcTan @@ (emb[[v]] - emb[[#]]) &], {v, VertexList[g]}];
rightF[_] := False;
Reap[
Table[
If[! rightF[e],
s = e[[1]];
t = e[[2]];
initial = s;
face = {s};
While[t =!= initial,
rightF[UndirectedEdge[s, t]] = True;
{s, t} = nextCandidate[s, t, pAdj[t]];
face = Join[face, {s}];
];
Sow[face];
],
{e, EdgeList[g]}]][[2, 1]]
]


For example,

In[162]:= faces = FindFace[g]
Out[162]= {{1, 2, 8, 6}, {1, 5, 4, 3, 2}, {1, 6, 5}, {2, 3, 7, 8}, {3,
4, 7}, {4, 5, 6, 8, 7}}

coord = GraphEmbedding[g];
Graphics[{EdgeForm[Directive[Black, Thick]],
Polygon[coord[[#]]] & /@ faces}]}]


You could use the precomputed coordinates if you want like:

g = GridGraph[{3, 3}]


In[166]:= FindFace[g, GraphEmbedding[g]]
Out[166]= {{1, 2, 5, 4}, {1, 4, 7, 8, 9, 6, 3, 2}, {2, 3, 6, 5}, {4,
5, 8, 7}, {5, 6, 9, 8}}


Note that this function will find all faces including the external face.

-
"... will find all faces including the external face" Should be easy to filter that out, if the OP chooses to, since it has the max area. Nice answer :) – R. M. Jan 29 '13 at 16:03
Your code seem to not work in 10.4 any more.And at this problem I have a same thinking in this post – yode Apr 8 at 14:14
@yode I just checked on 10.4 and it works fine. What is not working? – halmir Apr 8 at 16:27
Sorry.In my dormitory pc it work well,but the office not.I'll check it again tomorrow. – yode Apr 8 at 16:59

As Sjoerd noted, version 9 includes a layout algorithm that will avoid edge crossings if the graph is planar. This is the most difficult part of the task, but once you have the planar embedding, it is relatively easy to find the faces.

You can start by finding counterclockwise orderings of vertices around any vertex. Let g be the planar graph, then

emb = GraphEmbedding[g, "PlanarEmbedding"]

orderings = Table[
SortBy[
Pick[VertexList[g], m[[v]], 1],     (* all neigbours of v *)
ArcTan @@ (emb[[v]] - emb[[#]]) &
],
{v, VertexList[g]}
]


Based on this information you can walk the vertices belonging to each face, you just need to make sure you never make a turn greater than 180 degrees.

I don't have time to finish implementing this. I hope this information was helpful and you'll be able to program it.

-

The answer proposed by halmir is very efficient and will give a list featuring all the internal faces along with one face that represents the outer perimeter, but the outer face is not always at the same point in the list, and plotting the polygons sometimes results in obscuring some internal faces.

Consider the following graph,

g1 = AdjacencyGraph[{{0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0}, {1, 0, 1,
0, 0, 0, 0, 1, 0, 0, 0, 0}, {0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0,
0}, {1, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0}, {1, 0, 0, 0, 0, 1, 0, 1,
0, 0, 0, 0}, {0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 1, 0}, {0, 0, 0, 1,
0, 1, 0, 0, 0, 0, 0, 1}, {0, 1, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0}, {0,
0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0}, {0, 0, 1, 1, 0, 0, 0, 0, 0, 0,
0, 0}, {0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1}, {0, 0, 0, 0, 0, 0, 1,
0, 0, 0, 1, 0}},
GraphLayout -> "PlanarEmbedding",
VertexCoordinates -> {{0.68, 0.88}, {0.84, 0.85}, {1.12,
0.89}, {0.33, 1.13}, {0.81, 0.33}, {0.43, 0.33}, {0.15,
1.13}, {0.96, 0.33}, {1.12, 0.33}, {1.12, 1.13}, {-0.12,
0.33}, {-0.12, 1.13}}]


The above algorithm will give

faces = FindFace[g1,GraphEmbedding[g1]];
coord = GraphEmbedding[g1];
Graphics[{EdgeForm[Directive[Black, Thick]],
Polygon[coord[[#]]] & /@ faces}]}]


which has the polygons in such an order that you can't see all internal faces. The obvious solution (obvious after halmir pointed it out to me) is to remove the element with the largest area. But, as often happens to me, I had spent some time writing a code that does the same thing but much slower (because I didn't think halmir's code worked on the above graph).

The algorithm I propose should output the list of non-overlapping polygons from the input graph. The idea is to use FindCycles to get a full list of cycles from the graph, then sort this list in terms of the resulting polygon area. We know that the smallest polygon is one we want to keep. Then we look at the rest of the polygons, keeping only those with zero overlap with the current list of faces. This is the slow step, because it uses RegionIntersection to determine whether two polygons overlap.

I use a While loop to make sure that we stop looking at the cycles once we have enough for a complete basis.

graphToFaces[graph_?PlanarGraphQ] := Module[{graphpoints, cycles, polygons, n},
graphpoints = GraphEmbedding[graph];
cycles =
Polygon[graphpoints[[#]]] & /@
FindCycle[graph,  Max[Length /@ FindFundamentalCycles[graph]], All][[All, All, 2]];
cycles = SortBy[cycles, Area];
polygons = {cycles[[1]]};
n = 2;
While[Length@polygons < Length@FindFundamentalCycles@graph &&
n <= Length@cycles,
If[
And @@ (Area[Rationalize@cycles[[n]], Rationalize@ #]] === 0 & /@
polygons),
AppendTo[polygons, cycles[[n]]]
];
n++
];
First /@ (polygons /.
]


Applied to the problem above,

faces = graphToFaces[g1]
coord = GraphEmbedding[g1];
Graphics[{EdgeForm[Directive[Black, Thick]],

@halmir - but it won't always be the largest one by number of vertices, right? It would always be the largest one by Area though, so a foolproof method might be Most[SortBy[FindFace[g1, GraphEmbedding[g1]], Area[Polygon[coord[[#]]]] &]] – JasonB Apr 11 at 13:54