HouseGraph = Graph[{
1 -> 2,
1 -> 3,
2 -> 3,
2 -> 4,
3 -> 5,
4 -> 5
}];
Besides the house drawing, here there is another picture of it.
ClearAll[allMaps];
allMaps[graph_] := With[{emb = getInitialEmb[graph]},
Map[
Function[comb,
Association[
Table[
i -> comb[[i]], {i, 1, Length@VertexList@graph}]]] ,
Distribute[
Table[
#[[1, 1]] & /@ Union@Map[
Cycles[{#}] &,
Permutations@emb[v]],
{v, VertexList@graph}], List] ]
];
We can then list all the combinatorial maps the formula is:
allMaps[HouseGraph]
{ <|1 -> {2, 3}, 2 -> {1, 3, 4}, 3 -> {1, 2, 5}, 4 -> {2, 5}, 5 -> {3, 4}|>, (* (a) *)
<|1 -> {2, 3}, 2 -> {1, 3, 4}, 3 -> {1, 5, 2}, 4 -> {2, 5}, 5 -> {3, 4}|>, (* (b) *)
<|1 -> {2, 3}, 2 -> {1, 4, 3}, 3 -> {1, 2, 5}, 4 -> {2, 5}, 5 -> {3, 4}|>, (* (c) *)
<|1 -> {2, 3}, 2 -> {1, 4, 3}, 3 -> {1, 5, 2}, 4 -> {2, 5}, 5 -> {3, 4}|> (* (d) *)
}
In the case of the house graph the total number is: (2!/2) * (3!/3) (3!/3)(2!/2) = 4
Without forgeting the direction of the edges for a moment, We have here the four embeddings: two planar y two non-planar.
Filter out the planar maps:
In[348]:= Select[allMaps[HouseGraph], IGPlanarQ]
Out[348]= {
<|1 -> {2, 3}, 2 -> {1, 3, 4}, 3 -> {1, 5, 2}, 4 -> {2, 5},
5 -> {3, 4}|>,
<|1 -> {2, 3}, 2 -> {1, 4, 3}, 3 -> {1, 2, 5},
4 -> {2, 5}, 5 -> {3, 4}|>
}
To plot nice graphs:
In[357]:= Clear[plotPlanarEmbeddings];
plotPlanarEmbeddings[g_] :=
Dataset@
Map[Function[embedding, {embedding,
draw[g, embedding]}],
Select[ allMaps[g], IGPlanarQ]
];
In[359]:= plotPlanarEmbeddings@HouseGraph
outergraph2Squares = Graph[{
1 -> 2,
2 -> 3,
1 -> 4,
4 -> 3,
4 -> 5,
5 -> 6,
3 -> 6
}
];
allMaps[outergraph2Squares] // TableForm
All the possible combinatorial maps:
{<|1 -> {2, 4}, 2 -> {1, 3}, 3 -> {2, 4, 6}, 4 -> {1, 3, 5},
5 -> {4, 6}, 6 -> {3, 5}|>,
<|1 -> {2, 4}, 2 -> {1, 3},
3 -> {2, 4, 6}, 4 -> {1, 5, 3}, 5 -> {4, 6},
6 -> {3, 5}|>,
<|1 -> {2, 4}, 2 -> {1, 3}, 3 -> {2, 6, 4},
4 -> {1, 3, 5}, 5 -> {4, 6}, 6 -> {3, 5}|>,
<|1 -> {2, 4},
2 -> {1, 3}, 3 -> {2, 6, 4}, 4 -> {1, 5, 3}, 5 -> {4, 6},
6 -> {3, 5}|>}
For the directed bouquet with two loops, as in the PDF, let us refer to the edges at the star (xin, xout, yin, yout) as 1,2,3,4 for simplicity.
name[1] = xin;
name[2] = xout;
name[3] = yin;
name[4] = yout;
We can then generate all the different cyclic permutations on this 4-element set (the only star of B2).
CP = Union[Cycles[{#}] & /@ Permutations@Range[4]];
CP /. x_Integer :> name[x]
And the result is:
{
Cycles[{{xin, xout, yin, yout}}], (* (a) *)
Cycles[{{xin, xout, yout, yin}}], (* (b) *)
Cycles[{{xin, yin, xout, yout}}], (* (c) *)
Cycles[{{xin, yin, yout, xout}}], (* (d) *)
Cycles[{{xin, yout, xout, yin}}], (* (e) *)
Cycles[{{xin, yout, yin, xout}}] (* (f) *)
}
The number of embeddings is then six in total, the correct pictures:
One thing to notice is that if I apply the Lemma which states the charactherisation of the identity type of cyclic sets, I get that all are embeddings are equal, proving by brute forcing, if there is an isomor of the star that makes the diagram commuting.
To replace in the lemma: (A,B := Star(B2, x)) and
isoStar = Permutations@Range[4];
testEquality[f_, g_] := AnyTrue[
isoStar
, Function[e,
PermutationProduct[f, e] == PermutationProduct[e, g]]];
Union[CP, SameTest -> testEquality] /. x_Integer -> name[x]
The result is:
{Cycles[{{xin, xout, yin, yout}}]}
Same embedding different outer face: