# House of Santa Claus

The house of Santa Claus is an old German drawing game for small children. You have to draw a house in one line.  You must not lift your pencil while drawing. $\color{red}{\text{You must not repeat a line.}}$

A possible solution for drawing such a house is:

The drawings sequence is here: 1->2->4->1->3->4->5->3->2

How can one find out all existing drawing sequences using Mathematica?

UPDATE:

Each starting position should be possible and the last line should end at the starting position.

• Just a short comment on terminology: in Germany this house is not owned by Santa Claus (Weihnachtsmann) but by another, admittedly very similar looking, man called Nikolaus, which comes in the night to the 6th of December into the home of people and fills the shoes of good kids with sweets, under the condition that the shoes have been polished to shine bright. Oct 15, 2016 at 15:48
• Michael Trott has this as an example in his "Guidebook Programming", there a rule-based approach to determine all possibilities to draw the "house" in (all) different ways Oct 15, 2016 at 21:53
• Using the standard function FindEulerianCycle[] I have now found all 44 Eulerian paths, hereby confirming my previous 12 solutions which start on the "floor" egde. See full solution. Oct 17, 2016 at 12:20
• @mrz: the sentence in your update "Each starting position should be possible and the last line should end at the starting position." contains two errors (1) the starting position must be an odd vertex (2) there is no closed path going through all edges once. See my full solution for details. Oct 18, 2016 at 11:32

Full solution

Outline of solution

The OP asks for a path which contais all vertices and all egdes but must not go through any egde twice. This kind of path is called Eulerian path (EP). It was first discussed by Leonhard Euler in his famous "Königsberger Brückenproblem".

Euler also proved that for a closed Eulerian path, called Eulerian circle (EC), to exist, all vertices must have an even number of edges (even vertex), and furthermore than an open EP exist if and only if there are exactly two vertices with an odd number of edges (odd vertex), all others must be even. The path then has to start at one of the odd vertices and end on the other.

In our house the two odd vertices are 1 and 2 on the floor of the house.

In order to find all EP we shall use the standard function FindEulerianCycle[]. But as our house has no EC we apply a trick, we add an auxiliary vertex no. 6 which is connected to 1 and 2. Then we let Mathematica calculate the ECs, and finally delete the connections {1,6} and {6,2} from the results.

We find 44 Eulerian paths.

Solution

The undirected edges of the auxiliary graph are

edges = {{1, 6}, {6, 2}, {1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}, {3,
5}, {4, 5}}; (* undirected edges *)


Nor we find all ECs

ec = FindEulerianCycle[edges, All];
Short[%] (* not displayed here *)

Length[ec]

Out[128]= 44


The removal of the two auxiliary edges is easily done here by dropping the first two entries

ep1 = Drop[#, 2] & /@ ec;
Short[%] (* not displayed here *)


In List form this becomes

ep2 = (# /. UndirectedEdge -> List & /@ #) & /@ ep1;
Short[%] (* not displayed here *)


In vertex form the paths are

ep3 = Join[(#[[1]] &) /@ #, {#[[-1, 2]]}] & /@ ep2;
Short[%] (* not displayed here *)


Hence we have found

{Length[ep3], Length[Union[ep3]]}

(* Out[149]= {44, 44} *)


different Eulerian paths.

These can be attributed to one of the the three starting sequences {2->1},{2->3}, and {2->4}:

ep21 = Select[ep3, #[[2]] == 1 &]

(* Out[151]= {
{2, 1, 4, 5, 3, 4, 2, 3, 1}, {2, 1, 4, 5, 3, 2, 4, 3, 1},
{2, 1, 4, 3, 5, 4, 2, 3, 1}, {2, 1, 4, 3, 2, 4, 5, 3, 1},
{2, 1, 4, 2, 3, 5, 4, 3, 1}, {2, 1, 4, 2, 3, 4, 5, 3, 1},
{2, 1, 3, 5, 4, 3, 2, 4, 1}, {2, 1, 3, 5, 4, 2, 3, 4, 1},
{2, 1, 3, 4, 5, 3, 2, 4, 1}, {2, 1, 3, 4, 2, 3, 5, 4, 1},
{2, 1, 3, 2, 4, 5, 3, 4, 1}, {2, 1, 3, 2, 4, 3, 5, 4, 1}}
*)

Length[ep21]

(* Out[156]= 12 *)


This confirms my previous manual finding.

ep23 = Select[ep3, #[[2]] == 3 &]

(* Out[153]= {
{2, 3, 5, 4, 3, 1, 4, 2, 1}, {2, 3, 5, 4, 3, 1, 2, 4, 1},
{2, 3, 5, 4, 2, 1, 4, 3, 1}, {2, 3, 5, 4, 2, 1, 3, 4, 1},
{2, 3, 5, 4, 1, 3, 4, 2, 1}, {2, 3, 5, 4, 1, 2, 4, 3, 1},
{2, 3, 4, 5, 3, 1, 4, 2, 1}, {2, 3, 4, 5, 3, 1, 2, 4, 1},
{2, 3, 4, 2, 1, 4, 5, 3, 1}, {2, 3, 4, 2, 1, 3, 5, 4, 1},
{2, 3, 4, 1, 3, 5, 4, 2, 1}, {2, 3, 4, 1, 2, 4, 5, 3, 1},
{2, 3, 1, 4, 5, 3, 4, 2, 1}, {2, 3, 1, 4, 3, 5, 4, 2, 1},
{2, 3, 1, 2, 4, 5, 3, 4, 1}, {2, 3, 1, 2, 4, 3, 5, 4, 1}}
*)

Length[ep23]

(* Out[154]= 16 *)

ep24 = Select[ep3, #[[2]] == 4 &]

(* Out[152]= {
{2, 4, 5, 3, 4, 1, 3, 2, 1}, {2, 4, 5, 3, 4, 1, 2, 3, 1},
{2, 4, 5, 3, 2, 1, 4, 3, 1}, {2, 4, 5, 3, 2, 1, 3, 4, 1},
{2, 4, 5, 3, 1, 4, 3, 2, 1}, {2, 4, 5, 3, 1, 2, 3, 4, 1},
{2, 4, 3, 5, 4, 1, 3, 2, 1}, {2, 4, 3, 5, 4, 1, 2, 3, 1},
{2, 4, 3, 2, 1, 4, 5, 3, 1}, {2, 4, 3, 2, 1, 3, 5, 4, 1},
{2, 4, 3, 1, 4, 5, 3, 2, 1}, {2, 4, 3, 1, 2, 3, 5, 4, 1},
{2, 4, 1, 3, 5, 4, 3, 2, 1}, {2, 4, 1, 3, 4, 5, 3, 2, 1},
{2, 4, 1, 2, 3, 5, 4, 3, 1}, {2, 4, 1, 2, 3, 4, 5, 3, 1}}
*)

Length[ep24]

(* Out[155]= 16 *)


Graphically these are

pnts = {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {1/2, 1 + Sqrt[3]/2}};

GraphicsGrid[
Partition[Table[
Show[Graphics[
Line[Table[{Random[]/5, Random[]/5} + pnts[[ep21[[k, i]]]], {i, 1,
9}]]]], {k, 1, Length[ep21]}], 6], ImageSize -> 800]


GraphicsGrid[
Partition[
Table[Show[
Graphics[
Line[Table[{Random[]/5, Random[]/5} + pnts[[ep23[[k, i]]]], {i,
1, 9}]]]], {k, 1, Length[ep23]}], 8], ImageSize -> 800]


GraphicsGrid[
Partition[
Table[Show[
Graphics[
Line[Table[{Random[]/5, Random[]/5} + pnts[[ep24[[k, i]]]], {i,
1, 9}]]]], {k, 1, Length[ep24]}], 8], ImageSize -> 800]


Original solution

I found manually that there are the following 12 tours (sequences of vertices) beginning with 1->2

tv = {{1, 2, 3, 1, 4, 3, 5, 4, 2}, {1, 2, 3, 1, 4, 5, 3, 4, 2}, {1, 2, 3, 4,
1, 3, 5, 4, 2}, {1, 2, 3, 4, 5, 3, 1, 4, 2}, {1, 2, 3, 5, 4, 1, 3, 4,
2}, {1, 2, 3, 5, 4, 3, 1, 4, 2}, {1, 2, 4, 1, 3, 4, 5, 3, 2}, {1, 2, 4, 1,
3, 5, 4, 3, 2}, {1, 2, 4, 3, 1, 4, 5, 3, 2}, {1, 2, 4, 3, 5, 4, 1, 3,
2}, {1, 2, 4, 5, 3, 1, 4, 3, 2}, {1, 2, 4, 5, 3, 4, 1, 3, 2}};


The evoluton of the drawings can be followed in this picture

pnts = {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {1/2, 1 + Sqrt[3]/2}};
GraphicsGrid[
Partition[Table[
Show[Graphics[
Line[Table[{Random[]/5, Random[]/5} + pnts[[tv[[k, i]]]], {i, 1,
9}]]]], {k, 1, 12}], 6], ImageSize -> 800]


• Funny way of visualizing the paths :)
– DPF
Oct 17, 2016 at 8:20
• This is very nice ...
– mrz
Oct 17, 2016 at 20:56

This is of course the Chinese postman problem, which is solved by the function FindPostmanTour[]. First, represent the edges of the directed graph:

edges = {1 -> 2, 1 -> 3, 2 -> 4, 3 -> 2, 3 -> 4, 4 -> 1, 4 -> 5, 5 -> 3};
house = Graph[edges,
VertexCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {1/2, 1 + Sqrt[3]/2}},
EdgeStyle -> Directive[Thick, Black],
VertexLabels -> Placed["Name", Center], VertexSize -> Small,
VertexStyle -> Directive[FaceForm[None], EdgeForm[Black]]];


Find all tours:

tours = FindPostmanTour[edges, All]
{{1 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 4, 4 -> 1, 1 -> 3, 3 -> 2, 2 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 4, 4 -> 1, 1 -> 3, 3 -> 2, 2 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 4, 4 -> 5, 5 -> 3, 3 -> 2, 2 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 4, 4 -> 5, 5 -> 3, 3 -> 2, 2 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 4, 4 -> 1, 1 -> 3, 3 -> 2, 2 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 4, 4 -> 1, 1 -> 3, 3 -> 2, 2 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 4, 4 -> 5, 5 -> 3, 3 -> 2, 2 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 4, 4 -> 5, 5 -> 3, 3 -> 2, 2 -> 4, 4 -> 1},
{1 -> 2, 2 -> 4, 4 -> 1, 1 -> 3, 3 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 4, 4 -> 1}}

Length[tours]
16


The tour in the OP corresponds to the fifteenth entry:

Partition[Table[HighlightGraph[house, Take[tours[[15]], k]], {k, 8}], 4] // GraphicsGrid


• Neat! I spent a lot of time looking for the FindPostmanTour function and couldn't seem to in my naive documentation search. Great reply.
– ktm
Oct 15, 2016 at 2:03
• @user6014, thanks. Remembering the name of the problem surprisingly took more effort than coding it up. :D (Aside: please consider changing your username.) Oct 15, 2016 at 2:08
• @J.M. I'm not sure anymore that this solution is correct. The first tour is {{1 -> 2, 2 -> 4, 4 -> 5, 5 -> 3, 3 -> 4, 4 -> 1, 1 -> 3, 3 -> 2, 2 -> 4, 4 -> 1},. It containes the edges 2->4 and 4->1 twice. Generally, we should have only 8 items in a tour, rather than 10. Oct 15, 2016 at 18:20
• As this article,I think we should use FindEulerianCycle but not FindPostmanTour?
– yode
Oct 16, 2016 at 10:10
• @J.M. I believe FindPostmanTour gives tours that traverse each edge at least once. It seems to me the OP wants tours that traverse each edge exactly once. Does it suffice to select from the tours you found those that have no duplicates? Oct 18, 2016 at 20:08

As this article,I think we want to find all of the Eulerian path.But Mathematica have no such function to do this directly.So I will delete the edge 1 <-> 2 first,then use FindEulerianCycle like follow:

• ### Make a intermediate graph without edge 1 <-> 2:

pts = {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {1/2, 1 + Sqrt[3]/2}};
g = EdgeDelete[
g1=Graph[{1 <-> 2, 2 <-> 3, 3 <-> 4, 1 <-> 3, 1 <-> 4, 2 <-> 4,
4 <-> 5, 3 <-> 5}, VertexCoordinates -> pts,
VertexLabels -> "Name"], 1 <-> 2]


• ### Find all of the Eulerian path:

paths=Prepend[#, 1 <-> 2] & /@ FindEulerianCycle[g, All]


MapIndexed[
Export[ToString@First[#2] <> ".gif", #, "DisplayDurations" -> 0.5] &,
FoldList[HighlightGraph[#1, #2, GraphHighlightStyle -> "Thick"] &,
g1, #] & /@ paths]


PS: I found the vertex $3$,$4$,$1$ and $2$ is completely equivalent.I think this is a bug of FindEulerianCycle which cannot find another $18$ path at least.(I have reported it to W.R. as CASE:3741151.If I get any useful response,I will update it to here.)

• (at) yode : I have solved the problem the other way round, i.e. adding a vertex and two edges. I have found no indications for a bug in FindEulerianCircles. See my full solution. Oct 18, 2016 at 11:39
• @Dr.WolfgangHintze Have you seen my PS in the end of post?
– yode
Oct 18, 2016 at 11:53
• Sorry for responding so late. Did you check if there's an error in my solution stemming from your general observation of a bug? Feb 17, 2017 at 13:42