16
$\begingroup$

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:

enter image description here

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.

Improve this question
$\endgroup$
4
  • 3
    $\begingroup$ 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. $\endgroup$
    – Dr. Wolfgang Hintze
    Commented Oct 15, 2016 at 15:48
  • $\begingroup$ 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 $\endgroup$
    – mgamer
    Commented Oct 15, 2016 at 21:53
  • $\begingroup$ 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. $\endgroup$
    – Dr. Wolfgang Hintze
    Commented Oct 17, 2016 at 12:20
  • $\begingroup$ @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. $\endgroup$
    – Dr. Wolfgang Hintze
    Commented Oct 18, 2016 at 11:32

3 Answers 3

Reset to default
11
$\begingroup$

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]

enter image description here

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]

enter image description here

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]

enter image description here

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]

enter image description here

Improve this answer
$\endgroup$
2
  • 4
    $\begingroup$ Funny way of visualizing the paths :) $\endgroup$
    – DPF
    Commented Oct 17, 2016 at 8:20
  • $\begingroup$ This is very nice ... $\endgroup$
    – mrz
    Commented Oct 17, 2016 at 20:56
20
$\begingroup$

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]]];

house

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

OP's path

Improve this answer
$\endgroup$
20
  • $\begingroup$ Neat! I spent a lot of time looking for the FindPostmanTour function and couldn't seem to in my naive documentation search. Great reply. $\endgroup$
    – ktm
    Commented Oct 15, 2016 at 2:03
  • $\begingroup$ @user6014, thanks. Remembering the name of the problem surprisingly took more effort than coding it up. :D (Aside: please consider changing your username.) $\endgroup$
    – J. M.'s missing motivation ♦
    Commented Oct 15, 2016 at 2:08
  • 1
    $\begingroup$ @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. $\endgroup$
    – Dr. Wolfgang Hintze
    Commented Oct 15, 2016 at 18:20
  • 1
    $\begingroup$ As this article,I think we should use FindEulerianCycle but not FindPostmanTour? $\endgroup$
    – yode
    Commented Oct 16, 2016 at 10:10
  • 1
    $\begingroup$ @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? $\endgroup$
    – nadlr
    Commented Oct 18, 2016 at 20:08
7
$\begingroup$

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]

enter image description here

  • Find all of the Eulerian path:

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

enter image description here

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.)

Improve this answer
$\endgroup$
3
  • $\begingroup$ (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. $\endgroup$
    – Dr. Wolfgang Hintze
    Commented Oct 18, 2016 at 11:39
  • $\begingroup$ @Dr.WolfgangHintze Have you seen my PS in the end of post? $\endgroup$
    – yode
    Commented Oct 18, 2016 at 11:53
  • $\begingroup$ Sorry for responding so late. Did you check if there's an error in my solution stemming from your general observation of a bug? $\endgroup$
    – Dr. Wolfgang Hintze
    Commented Feb 17, 2017 at 13:42

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.