# Graph Creation in Mathematica: TSP

I'm trying to create the following graph in Mathematica Where do I start? I'm specifically trying to make a graph so that I can use it in TravelingSalesman[g], for g a graph. This is what I have:

g := Graph[{1 \[UndirectedEdge] 2, 1 \[UndirectedEdge] 3,
1 \[UndirectedEdge] 5, 1 \[UndirectedEdge] 4,
4 \[UndirectedEdge] 5, 4 \[UndirectedEdge] 3,
4 \[UndirectedEdge] 2, 3 \[UndirectedEdge] 5,
3 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 5},
EdgeWeight -> {4, 5, 6, 3, 4, 5, 6, 7, 2, 7}]


Calling

TravelingSalesman[g]


I get the following result:

Table::iterb: Iterator {CombinatoricaPrivatei\$828,V[Graph[{1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]5,1\[UndirectedEdge]4,4\[UndirectedEdge]5,4\[UndirectedEdge]3,4\[UndirectedEdge]2,3\[UndirectedEdge]5,3\[UndirectedEdge]2,2\[UndirectedEdge]5},EdgeWeight->{4,5,6,3,4,5,6,7,2,7}]]} does not have appropriate bounds. >>

Join::heads: Heads CombinatoricaPrivateDouble and Table at positions 1 and 2 are expected to be the same. >>

Join::heads: Heads CombinatoricaPrivateDouble and Table at positions 1 and 2 are expected to be the same. >>

Join::heads: Heads CombinatoricaPrivateDouble and List at positions 1 and 2 are expected to be the same. >>

General::stop: Further output of Join::heads will be suppressed during this calculation. >>

Table::iterb: Iterator {V[Graph[{1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]5,1\[UndirectedEdge]4,4\[UndirectedEdge]5,4\[UndirectedEdge]3,4\[UndirectedEdge]2,3\[UndirectedEdge]5,3\[UndirectedEdge]2,2\[UndirectedEdge]5},EdgeWeight->{4,5,6,3,4,5,6,7,2,7}]]} does not have appropriate bounds. >>

Table::iterb: Iterator {V[Graph[{1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]5,1\[UndirectedEdge]4,4\[UndirectedEdge]5,4\[UndirectedEdge]3,4\[UndirectedEdge]2,3\[UndirectedEdge]5,3\[UndirectedEdge]2,2\[UndirectedEdge]5},EdgeWeight->{4,5,6,3,4,5,6,7,2,7}]]} does not have appropriate bounds. >>

General::stop: Further output of Table::iterb will be suppressed during this calculation. >>

Range::range: Range specification in Range[V[Graph[{1\[UndirectedEdge]2,1\[UndirectedEdge]3,1\[UndirectedEdge]5,1\[UndirectedEdge]4,4\[UndirectedEdge]5,4\[UndirectedEdge]3,4\[UndirectedEdge]2,3\[UndirectedEdge]5,3\[UndirectedEdge]2,2\[UndirectedEdge]5},EdgeWeight->{4,5,6,3,4,5,6,7,2,7}]]] does not have appropriate bounds. >>

TravelingSalesman::ham: The graph must contain a Hamiltonian cycle for a traveling salesman tour to be found. >>

• Graph[{1 [UndirectedEdge] 2, 2 [UndirectedEdge] 3, 3 [UndirectedEdge] 1}] – Loie Benedicte Aug 3 '13 at 5:51
• "To use TravelingSalesman, you first need to load the Combinatorica Package using Needs["Combinatorica"]." But this is now deprecated in favour of the built-in graph functions. – cormullion Aug 3 '13 at 6:51
• Possible duplicate of this Q&A. – cormullion Aug 3 '13 at 6:55

Mathematica's graphing features are very powerful, but I find them confusing - there seems to be two separate types of graphing function (not including the deprecated "Combinatorica" system), and not all of the documentation has been written or updated that needs to be. But here's some more ideas for you to play with, to supplement the existing answers.

Some basic data:

data = {{"a" \[UndirectedEdge] "b" -> 3},
{"a" \[UndirectedEdge] "e" -> 5},
{"a" \[UndirectedEdge] "c" -> 6},
{"a" \[UndirectedEdge] "d" -> 4},
{"b" \[UndirectedEdge] "c" -> 4},
{"b" \[UndirectedEdge] "e" -> 5},
{"b" \[UndirectedEdge] "d" -> 6},
{"c" \[UndirectedEdge] "e" -> 7},
{"c" \[UndirectedEdge] "d" -> 8}}


from which you can extract the edges and the edge weights:

edges = data[[All, 1, 1]];
edgeweights = data[[All, 1, 2]];


So here's the basic graph:

g = Graph[edges,
EdgeWeight -> edgeweights,
EdgeLabels -> "EdgeWeight",
VertexLabels -> "Name",
DirectedEdges -> False] You can use GraphDistance to find the distance between vertices:

GraphDistance[g, #] & /@ VertexList[g]

{{0, 3., 5., 6., 4.},
{3., 0, 5., 4., 6.},
{5., 5., 0, 7., 9.},
{6., 4., 7., 0, 8.},
{4., 6., 9., 8., 0}}


Then you apply a similar process to a list of all the cycles:

cycles = Table[
{
Total[GraphDistance[g, First[#], Last[#]] & /@ cycle],
cycle
},
{cycle, FindHamiltonianCycle[g, All]}]


This adds the distances up for each Hamiltonian cycle.

{{29., {"a" <-> "e", "e" <-> "c", "c" <-> "d", "d" <-> "b", "b" <-> "a"}},
{27., {"a" <-> "b", "b" <-> "e", "e" <-> "c", "c" <-> "d", "d" <-> "a"}},
{26., {"a" <-> "d", "d" <-> "c", "c" <-> "b", "b" <-> "e", "e" <-> "a"}},
{30., {"a" <-> "c", "c" <-> "d", "d" <-> "b", "b" <-> "e", "e" <-> "a"}},
{26., {"a" <-> "e", "e" <-> "c", "c" <-> "b", "b" <-> "d", "d" <-> "a"}},
{28., {"a" <-> "c", "c" <-> "e", "e" <-> "b", "b" <-> "d", "d" <-> "a"}}}


Sort this:

sortedCycles = Sort[cycles, First[#1] < First[#2] &];


and you can show them using HighlightGraph:

HighlightGraph[g, #, GraphHighlightStyle -> "Thick",
ImageSize -> 200] & /@ sortedCycles[[All, 2]] Getting the graphs to look like your original is the next step. Create a layered graph using LayeredGraphPlot, and extract the vertices from it:

vc = VertexCoordinateRules /.


(LayeredGraphPlot is one of the "old" graphing functions, producing graphics and graphics complexes rather than Graph objects.)

Now apply these vertex coordinates to a new graph, defined as before:

h = Graph[edges,
EdgeWeight -> edgeweights,
EdgeStyle -> LightGray,
EdgeLabelStyle -> Directive[{FontFamily -> "Zapfino", 16, Red}],
EdgeLabels -> Flatten[data, 1],
VertexLabels -> "Name",
VertexLabelStyle -> Directive[{FontFamily -> "Futura", 16, Purple}],
DirectedEdges -> False,
VertexCoordinates -> vc] which is starting to move close to your original.

I don't know how to create the curved edges. But when I start to play with the fonts and colors, it's an indication that it's time to stop.

• I enjoyed your solution and your humour (last phrase). I think my coding of graph matches handwritten, edge 3 -4 weight as 7 and I get a unique solution. Your graph coding matches the graph prepared by Nasser with 3-4 weight 8 and there are two cycles with minimum 26. This is of no particular interest, I just like to understand. If I am wrong let me know. – ubpdqn Aug 3 '13 at 12:58
• I am getting used to commenting. Forgot to reference you in previous comment then locked out. Oh well. – ubpdqn Aug 3 '13 at 13:06
• @ubpdqn :) I didn't refer to the sketch - Nasser did the hard work and I shamelessly copied his data ... I like your blog, by the way! – cormullion Aug 3 '13 at 13:17
• very kind. Look forward to learning more from you and this environment. – ubpdqn Aug 5 '13 at 10:26

You could create weighted adjacency matrix to use as distance matrix in FindShortestTour:

g = Graph[{1 \[UndirectedEdge] 2, 1 \[UndirectedEdge] 3,
1 \[UndirectedEdge] 5, 1 \[UndirectedEdge] 4,
4 \[UndirectedEdge] 5, 4 \[UndirectedEdge] 3,
4 \[UndirectedEdge] 2, 3 \[UndirectedEdge] 5,
3 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 5},
EdgeWeight -> {4, 5, 6, 3, 4, 5, 6, 7, 2, 7},
VertexLabels -> Placed["Name", Center],
VertexSize -> .3, EdgeLabels -> "EdgeWeight",
GraphLayout -> "LayeredDigraphEmbedding", ImagePadding -> 5];

d = ((WeightedAdjacencyMatrix[g] // Normal) /. {0 -> Infinity});

{len, tour} = FindShortestTour[Range[VertexCount[g]],
DistanceFunction ->   (d[[#1, #2]] &)]

HighlightGraph[g, UndirectedEdge @@@ Partition[VertexList[g][[tour]], 2, 1, 1],
GraphHighlightStyle -> "Thick"] • very nice. FindShortestTour ideal. – ubpdqn Aug 5 '13 at 10:25
• +1 Very nice! I presume the shortest tour doesn't return to base - so it's 1->2->3->4->5 (despite the red path from 5 to 1)? - whereas the Hamiltonian cycles return home... – cormullion Aug 5 '13 at 15:34
• I missed the point that tour is based on vertex index. I edited to fix that. @cormullion FindShortestTour indeed return to base. You can check it by looking at length of tour which include the final trip to 1. – halmir Aug 5 '13 at 17:15
• Yes that now kind of agrees with the result I got (allowing for the fact that the OP's drawing and graph disagree with each other...:) – cormullion Aug 5 '13 at 17:23
SetDirectory[NotebookDirectory[]];
img = Import["a.png"];

g = LayeredGraphPlot[{{"a" -> "b", 3}, {"a" -> "e", 5}, {"a" -> "c", 6}, {"a" -> "d",
4}, {"b" -> "c", 4}, { "b" -> "e", 5}, {"b" -> "d",
6}, {"c" -> "e", 7}, { "c" -> "d", 8}},
PlotStyle -> {Opacity[.5], Gray},
BaseStyle -> {Bold, FontSize -> 24}, VertexLabeling -> True,
VertexRenderingFunction -> (Inset[Framed[Style[#2, 22], Background -> White,
FrameStyle -> Gray], #1, {Center, Top}] &), DirectedEdges -> False,

Grid[{{img, g}}, Frame -> All] This is a small graph and the unweighted graph has a number of Hamiltonian cycles. I assume the aim is to find the one with minimum cost/weight. This is an approach. I have changed the vertices a,b,c,d,e to 1,2,3,4,5.

g = Graph[{1 \[UndirectedEdge] 2, 2 \[UndirectedEdge] 3,
3 \[UndirectedEdge] 4, 4 \[UndirectedEdge] 1,
1 \[UndirectedEdge] 3, 3 \[UndirectedEdge] 5,
4 \[UndirectedEdge] 5, 2 \[UndirectedEdge] 5,
1 \[UndirectedEdge] 5, 2 \[UndirectedEdge] 4},
EdgeWeight -> {3, 4, 7, 4, 6, 7, 2, 5, 5, 6},
VertexLabels -> "Name", EdgeLabels -> "EdgeWeight"];
h = FindHamiltonianCycle[g, All];
ans = Total /@ (Extract[norm, #] & /@ (# /.
a_ \[UndirectedEdge] b_ :> {a, b}) & /@ h);
min = Extract[h, Position[ans, Min[ans]]]
HighlightGraph[g, min, GraphHighlightStyle -> "Thick"]


If I have coded your graph in error I apologise. It would be helpful to code the graph (vertices, edges and edgeweights). • I ran your code in my .nb` file, but it wont run. What must I do to make this work? – Loie Benedicte Aug 3 '13 at 7:17
• Oh, and by the way, thank you. – Loie Benedicte Aug 3 '13 at 7:18
• Could you explain what your code does? – Loie Benedicte Aug 3 '13 at 7:33
• @loie It works fine. You probably need to clear out your current work first. Helpful post here – cormullion Aug 3 '13 at 7:39
• What version of Mathematica are you using? I wrote this in version 9. I have rerun on my machine (old). It works ok. (i) g just codes the weighted graph (ii) h finds all the Hamiltonian cycles in g (achievable for small graph) (iii) norm just creates the weighted (symmetric) adjacency graph from which to extract weights (iv)ans just total the weights for the found cycles (v) min extracts the one with minimum weight (vi) the last command just highlights the cycle on the original graph. You could do with older versions but I have lost familiarity. I hope this helps. – ubpdqn Aug 3 '13 at 7:44