16

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.

mrz
  • 11,686
  • 2
  • 25
  • 81
  • 3
    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. – Dr. Wolfgang Hintze Oct 15 '16 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 – mgamer Oct 15 '16 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. – Dr. Wolfgang Hintze Oct 17 '16 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. – Dr. Wolfgang Hintze Oct 18 '16 at 11:32

3 Answers3

20

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

Mr.Wizard
  • 271,378
  • 34
  • 587
  • 1,371
J. M.'s missing motivation
  • 124,525
  • 11
  • 401
  • 574
  • 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 '16 at 02:03
  • @user6014, thanks. Remembering the name of the problem surprisingly took more effort than coding it up. :D (Aside: please consider changing your username.) – J. M.'s missing motivation Oct 15 '16 at 02:08
  • Thank you ... this is very elegant. You show the possible solutions over 1->2->4->... . How do you find all solutions from all 5 starting points? – mrz Oct 15 '16 at 08:34
  • @mrz, you can rename the vertices so that 1 corresponds to your desired starting point. That, I'll leave for you as an exercise. – J. M.'s missing motivation Oct 15 '16 at 09:01
  • So it is wrong when I would define edges = {1 -> 2, 1 -> 3, 1 -> 4, 2 -> 4, 2 -> 3, 2 -> 1, 3 -> 2, 3 -> 4, 3 -> 1, 3 -> 5, 4 -> 1, 4 -> 2, 4 -> 3, 4 -> 5, 5 -> 3, 5 -> 4}; and then use FindPostmanTour? – mrz Oct 15 '16 at 09:25
  • @mrz, 1 -> 4 means a directed path going from node 1 to node 4, which seems to be the reverse of what's in your diagram. – J. M.'s missing motivation Oct 15 '16 at 09:27
  • @J.M. Beautiful. But in version 8 the code does not run. Here's the correction. The line after house = ... should read Show[house], and as FindPostmanTour requires a graph object as the first parameter, the tours are calculated by FindPostmanTour[house,All]. – Dr. Wolfgang Hintze Oct 15 '16 at 15:40
  • @Dr. Hintze, unfortunately I did not have version 8 to check. The code as presented is working in 11, tho. – J. M.'s missing motivation Oct 15 '16 at 15:45
  • @J.M. No problem. Unfortunately this type of changes from version to version are not uncommon in Mathematica. But, again, very nice code the results of which I showed to my litle granddaughter who had the ambition of solving the puzzle by herself. – Dr. Wolfgang Hintze Oct 15 '16 at 16:00
  • @J. M. see my update ... – mrz Oct 15 '16 at 16:58
  • @mrz, as I said, you can try relabeling the vertices so that 1 is some other vertex. Have you tried it already? – J. M.'s missing motivation Oct 15 '16 at 17:44
  • 1
    @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. – Dr. Wolfgang Hintze Oct 15 '16 at 18:20
  • @mrz IMHO the solution of J.M. is not correct as it draws some edges more than once. Please see my solution. – Dr. Wolfgang Hintze Oct 15 '16 at 21:13
  • @Dr. Hintze, apparently so; let me think about it. – J. M.'s missing motivation Oct 16 '16 at 05:34
  • 1
    As this article,I think we should use FindEulerianCycle but not FindPostmanTour? – yode Oct 16 '16 at 10:10
  • @yode, were you able to make FindEulerianCycle[] work in this case? – J. M.'s missing motivation Oct 16 '16 at 10:39
  • Yes,I can't.As the of the state of You must not repeat a line. Maybe this answer have some problem or maybe I miss something.I think this post want find a eulerian path from 1 to 2.I mean this is half eulerian graph – yode Oct 16 '16 at 10:58
  • @J.M. To be honest, the valuations of the contributions to this problem look a bit strange to me. What do they measure? – Dr. Wolfgang Hintze Oct 17 '16 at 09:51
  • @Dr.WolfgangHintze I have given a vote. :) – yode Oct 18 '16 at 12:04
  • 1
    @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? – nadlr Oct 18 '16 at 20:08
11

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

mrz
  • 11,686
  • 2
  • 25
  • 81
Dr. Wolfgang Hintze
  • 13,039
  • 17
  • 47
7

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

yode
  • 26,686
  • 4
  • 62
  • 167