RabbitFarm
2021-07-18
A Genetic Algorithm solution to the Travelling Salesman Problem
The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.
Part 1
You are given integers 0 <= $m <= 255 and 1 <= $n <= 8. Write a script to invert $n bit from the end of the binary representation of $m and print the decimal representation of the new binary number.
Solution
use strict;
use warnings;
sub flip_bit_n{
my($x, $n) = @_;
my $bits = substr(unpack("B32", pack("N", $x)), 24, 8);
my @bits = split(//, $bits);
$bits[@bits - $n] ^= 1;
my $flipped_decimal = unpack("N", pack("B32", substr("0" x 32 . join("", @bits), -32)));
return $flipped_decimal;
}
MAIN:{
my($M, $N);
$M = 12;
$N = 3;
print flip_bit_n($M, $N) . "\n";
$M = 18;
$N = 4;
print flip_bit_n($M, $N) . "\n";
}
Sample Run
$ perl perl/ch-1.pl
8
26
Notes
This code re-uses much of the code from last week's challenge solution.
The only difference is that this week we flip the specified nth bit using the XOR
operator. I think that this may be the first time I have ever used a ^=
operation!
Part 2
You are given a NxN matrix containing the distances between N cities. Write a script to find a round trip of minimum length visiting all N cities exactly once and returning to the start.
Solution
use strict;
use warnings;
use boolean;
use AI::Genetic;
use constant N => 7;
my @matrix= ([0, 5, 2, 7],
[5, 0, 5, 3],
[3, 1, 0, 6],
[4, 5, 4, 0]);
sub fitness{
my($genes) = @_;
my $cost = 0;
return -1 if $genes->[0] != $genes->[@{$genes} - 1];
my @path = sort {$a <=> $b} @{$genes}[0 .. @{$genes} - 2];
for my $i (0 .. (@path - 2)){
return -1 if $path[$i] == $path[$i + 1];
}
for my $i (0 .. @{$genes} - 2){
$cost += $matrix[$genes->[$i]][$genes->[$i + 1]];
}
return 1/$cost;
}
sub terminate{
return true;
}
MAIN:{
srand(121);
my $aig = new AI::Genetic(
-fitness => \&fitness,
-type => "rangevector",
-population => 500,
-crossover => 0.9,
-mutation => 0.1,
);
my $genes = [];
for (0 .. N + 1){
push @{$genes}, [0, N];
}
@matrix = ();
for (0 .. N){
my $row = [];
for my $i (0 .. N){
push @{$row}, int(rand(N * 2 + 1));
}
push @matrix, $row;
}
$aig->init(
$genes
);
$aig->evolve("tournamentUniform", 100000);
my $path = $aig->getFittest()->genes();
print join(",", @{$path}) . "\n";
my $cost;
for my $i (0 .. @{$path} - 2){
$cost += $matrix[$path->[$i]][$path->[$i + 1]];
}
print "cost: $cost\n";
}
Sample Run
$ perl perl/ch-2.pl
3,0,1,2,3
cost: 10
$ perl perl/ch-2.pl
3,1,7,5,4,6,0,2,3
cost: 24
Notes
I have used Genetic Algorithm (GA) approaches to a bunch of these challenge problems in the past. I will admit that in some cases the GA approach is more for fun than as a good example of the sorts of problems GA is good for. This time, however, we have a somewhat classic use case!
The Travelling Salesman Problem is well known to be NP-Hard and Genetic Algorithms are a well studied approach to tackling these beasts.
I first tested this solution with the example in the original problem statement, hardcoded
here in @matrix
and obtained a result which matched the known correct one. Then, testing
with increasingly larger values of N
to generate random matrices I continued to get
seemingly correct results. I did not verify these by hand. Instead I set a random seed
with srand
and verified that I got the same cost results over several runs. As needed
I would adjust the number of generations in the evolve()
method call upwards until again
getting results which converged on the same cost value.
For a 20 x 20 matrix I seem to be getting correct results, but runtimes are quite lengthy and I ran out of time to test this further. However, I am very confident that a correct path is obtainable this way although perhaps some additional slight adjustment of parameters is necessary.
(Hopefully nobody is too terribly confused by this, but please do notice that the size of the matrix is actually N + 1. That is, in order to obtain a matrix like the one given in the problem statement you specify an N of 3, although obviously this is a 4 x 4 matrix. This is just in keeping with the city labels starting with 0.)
References
posted at: 23:36 by: Adam Russell | path: /perl | permanent link to this entry