Simulated Annealing

<< Anneal.m

?Anneal

We illustrate with the traveling salesman, who has to return to his starting point after visiting all customers. Note that
Anneal has not been designed with this particular application in mind. Indeed for a traveling salesman problem one would not just try
interchanging vertices in pairs. One would also try reversing the order in which some part of the circuit is traversed.

n = 25;

g = 
      Graph[Join[Table[{{i, i + 1}}, {i, n - 1}], {{{1, n}}}], 
        Table[{{Random[], Random[]}}, {n}]]

ShowGraph[g, VertexNumber -> On]

h =  Anneal[g];
SelectionMove[SelectedNotebook[], All, EvaluationCell];
FrontEndExecute[FrontEndToken["OpenCloseGroup"]];

ShowGraph[h, VertexNumber -> On]

Map[Show, $Film]; 
    SelectionMove[SelectedNotebook[], All, GeneratedCell];
FrontEndExecute[FrontEndToken["OpenCloseGroup"]];

Double click to animate!

m = 3; n = 4;
g = 
      Graph[Join[Table[{{i, i + 1}}, {i, n m - 1}], {{{1, n m}}}], 
        Flatten[Table[Table[{{i, j}}, {i, m}, {j, n}]], 1]]

ShowGraph[g, VertexNumber -> On]

h =  Anneal[g];
SelectionMove[SelectedNotebook[], All, EvaluationCell];
FrontEndExecute[FrontEndToken["OpenCloseGroup"]];

ShowGraph[h, VertexNumber -> On]

Map[Show, $Film]; 
    SelectionMove[SelectedNotebook[], All, GeneratedCell];
FrontEndExecute[FrontEndToken["OpenCloseGroup"]];

One can also use simulated annealing to find a Hamiltonian circuit.

n = 8

g = RandomGraph[n,  .5]

g = ChangeVertices[g, Table[{{Random[], Random[]}}, {n}]]

ShowGraph[g, VertexNumber -> On]

There is a deterministic way to find to find a Hamiltonian circuit. Such a circuit visits all vertices once.

?HamiltonianCycle

cyc = HamiltonianCycle[g]

Now we are going to do it with annealing. We impose a penalty on the circuit aux for every edge in the circuit that is not in the graph.

n = V[g]; 
    aux = ChangeEdges[g, 
        Join[Table[{{i, i + 1}}, {i, n - 1}], {{{1, n}}}]]

ShowGraph[aux, VertexNumber -> On]

penaltyTable = Table[1, {n}, {n}];
Do[v = Edges[g][[i]]; 
      penaltyTable[[v[[1]], 
            v[[2]]]] = penaltyTable[[v[[2]], v[[1]]]] = 
          0;, {i, Length[Edges[g]]}]

MatrixForm[penaltyTable]

cycle =  Anneal[aux, penaltyTable, 40];
SelectionMove[SelectedNotebook[], All, EvaluationCell];
FrontEndExecute[FrontEndToken["OpenCloseGroup"]];

cyclePlot = 
      ShowGraph[cycle, VertexNumber -> On, 
        EdgeColor -> RGBColor[1, 0, 0]]

gPlot = 
      ShowGraph[g, VertexNumber -> On, 
        EdgeColor -> RGBColor[0, 1, 0]]

Show[gPlot /. Thickness[_] -> Thickness[ .02], cyclePlot]

What happens when we try the above with the Petersen graph or the Tutte Graph?

g = PetersenGraph