# Can I solve this graph theory problem with Mathematica?

Internet browsing I came across this problem, as can be solved using Mathematica.

Edit: The image says: Place the following numbers 1,2,3,4,5,6,7 in the following diagram (all), without repeating any one in each red circle, so that two consecutive numbers can not be connected by the same line. Below says incorrect solutions. Below says: Find all solutions, if more than one. With mathematica Find a way to travel the circuit from a number "n" any integer

the question is how do I transformed this problem in terms that Mathematica can solve it?

I can not think a code to get started, I am newbie in mathematica but eager to learn

edit 2 :The translation fails, should be random numbers in the circles of the triangle, with no two consecutive numbers are together.

• I can't read the picture at all. Do you have a larger version? – Michael Stern Mar 8 '15 at 21:45
• The image is unreadable. Please include the link to the original of whatever you are trying to show. In addition, please include the code you have tried so far to accomplish your goal. – bbgodfrey Mar 8 '15 at 21:46
• What is the problem? – David G. Stork Mar 8 '15 at 21:48
• It seems like "requires the services of a professional consultant" type request. This site is not a place to ask others to do your work for you. If there is something specific about Mathematica you do not understand, the community would be glad to try to help you. – Michael E2 Mar 9 '15 at 0:06
• Since the question remains closed, take a look at this (sorry, no time to Git it). Should get you started - no need to pull out heavy GT functions for this, just check possibles. I think something got lost in the translation, and that the ";" vs ":" in the image is no accident - 4 and 5 are allowed to be consecutive, else there is no solution. As for second part of question, I'm guessing you mean a tour visiting all numbers starting from some other? Please clarify that in your OP. In any case, if question is reopened, I'll put the linked stuff as an answer. – ciao Mar 9 '15 at 3:12

A simple brute-force solution for the interpretation of this problem given in the comment by rasher:

fun := Abs@Flatten@
Differences[{{#1, #2}, {#1, #3}, {#2, #3}, {#2, #4}, {#2, #6},{#2, #5}, {#3, #4}, {#3, #6},
{#3, #7}, {#6, #5}, {#6, #7}, {#4, #6}} /. {{4, 5} -> {0, 2}, {5, 4} -> {0, 2}}, {0, 1}] &

Select[Permutations[Range@7], FreeQ[fun @@ #, 1] &]

{{2, 4, 5, 7, 6, 1, 3}, {2, 4, 7, 5, 6, 1, 3}, {2, 5, 4, 7, 3, 1, 6},
{2, 7, 4, 5, 3, 1, 6}, {3, 1, 5, 7, 6, 4, 2}, {3, 1, 7, 5, 6, 4, 2},
{3, 5, 1, 7, 2, 4, 6}, {3, 7, 1, 5, 2, 4, 6}, {6, 1, 4, 5, 3, 7, 2},
{6, 1, 4, 7, 3, 5, 2}, {6, 4, 1, 5, 2, 7, 3}, {6, 4, 1, 7, 2, 5, 3}}


Visualizing these solutions with

Grid[Partition[
Graph[{1 <-> 2, 1 <-> 3, 2 <-> 3, 2 <-> 4, 3 <-> 4, 2 <-> 5,
2 <-> 6, 3 <-> 6, 3 <-> 7, 5 <-> 6, 6 <-> 7, 4 <-> 6},
VertexSize -> 0.5, VertexStyle -> Red, EdgeStyle -> Black,
VertexCoordinates -> {{5, 10}, {4, 8}, {6, 8}, {5, 7.2}, {3, 6}, {5, 6}, {7, 6}},
VertexLabels -> Thread[Range@7 -> (Placed[#, {0.55, 0.45}] & /@ #)],
VertexLabelStyle -> Directive[15, Bold]] & /@ %, 4]]


and a visualization of the slots

## Explanation:

First let's give every position a symbol:

To solve this puzzle we only have to concentrate on the connections, making sure the difference between the two numbers at the end of each line is bigger than 1 (non-consecutive number), except for {4,5} and {5,4}. The following list contains all connections represented as sublists:

{{a, b}, {a, c}, {b, c}, {b, d}, {b, f}, {b, e}, {c, d}, {c, f}, {c, g}, {f, e},
{f, g}, {d, f}}


Mapping Differences over this list calculates the difference between each pair of connected numbers

Differences /@ {{a, b}, {a, c}, {b, c}, {b, d}, {b, f}, {b, e}, {c, d}, {c, f}, {c, g}, {f, e}, {f, g}, {d, f}}

{{-a+b},{-a+c},{-b+c},{-b+d},{-b+f},{-b+e},{-c+d},{-c+f},{-c+g},{e-f},{-f+g},{-d+f}}


We'll take care of the exception for 4 and 5 (not being considered as consecutive numbers) by replacing {4,5} and {5,4} with {0, 2} before the differences are calculated. To simplify things the absolute value of the differences is taken. Abs automatically threads over list, e.g.,

Abs[{{a}, {b}, {c}}]

{{Abs[a]}, {Abs[b]}, {Abs[c]}}


Such a nested list can be flattened using

% // Flatten

{Abs[a], Abs[b], Abs[c]}


Putting it all together into one function:

fun2[{a_, b_, c_, d_, e_, f_, g_}] := Abs[
Differences /@ ({{a, b}, {a, c}, {b, c}, {b, d}, {b, f}, {b, e}, {c, d}, {c, f},
{c, g}, {f, e}, {f, g}, {d, f}} /. {{4, 5} -> {0, 2}, {5, 4} -> {0, 2}})
] // Flatten


One can find all possible permutations of the numbers {1, 2, 3, 4, 5, 6, 7} with

perms = Permutations[Range@7]


Finally, Select is used to select all permutation which will result in a list without any 1 after fun2 is applied to them

Select[perms, FreeQ[fun2@#, 1] &]

{{2, 4, 5, 7, 6, 1, 3}, {2, 4, 7, 5, 6, 1, 3}, {2, 5, 4, 7, 3, 1, 6},
{2, 7, 4, 5, 3, 1, 6}, {3, 1, 5, 7, 6, 4, 2}, {3, 1, 7, 5, 6, 4, 2},
{3, 5, 1, 7, 2, 4, 6}, {3, 7, 1, 5, 2, 4, 6}, {6, 1, 4, 5, 3, 7, 2},
{6, 1, 4, 7, 3, 5, 2}, {6, 4, 1, 5, 2, 7, 3}, {6, 4, 1, 7, 2, 5, 3}}

• Which number is which? Could you maybe draw one of them in a graph? I thought they were top-to-bottom, left-to-right, but then 4,5 in the first example would be neighbors. – Niki Estner Mar 9 '15 at 9:40
• @nikie They are top-to-bottom, left-to-right, and you are right 4 & 5 are neighbors in all solutions. As rasher interprets this puzzle, 4 & 5 are allowed to be neighbors. Otherwise there is no solution. – Karsten 7. Mar 9 '15 at 9:45
• I see. The solution got lost in translation... – Niki Estner Mar 9 '15 at 9:47
• @Karsten7. Neat+1 :) – ubpdqn Mar 9 '15 at 10:30
• @Karsten 7 Can you explain or comment your code a bit to understand it more – Francisco Mar 9 '15 at 20:56

Just for fun, I have just used brute force but not as elegantly as Karsten 7 and I am too time poor to cull labeling that are just reflections etc. The graph layout just for visualization out of laziness but isomorphic to graph.

g = {1 <-> 2, 1 <-> 3, 2 <-> 3, 4 <-> 2, 4 <-> 3, 2 <-> 5, 5 <-> 6,
4 <-> 6, 6 <-> 7, 3 <-> 7, 3 <-> 6, 2 <-> 6};
perm = Thread[Range[7] -> #] & /@ Permutations[Range[7]];
can = (g /. #) & /@ perm;
fun[u_] := Min[Abs[Subtract @@@ (List @@@ u)]] > 1
func[u_] := Count[Abs[Subtract @@@ (List @@@ u)], 1] == 1


Now,

ans = Pick[can, fun /@ can, True];


yields {}-> no solution.

However, if one edge allowed:

ans = Pick[can, func /@ can, True];


Visualizing:

Grid[Partition[
Graph[#, VertexSize -> 0.7, VertexLabels -> Placed["Name", Center],