laziness, impatience, and hubris PerlMonks

### Re^2: Travelling problem (Anyone better 86850?)

by roboticus (Chancellor)
 on Dec 23, 2013 at 18:11 UTC ( #1068237=note: print w/replies, xml ) Need Help??

in reply to Re: Travelling problem (Anyone better 86850?)

Prompted by LanX's suggestion to use a genetic algorithm, I put one together (code in the readmore section below).

So far, both times I ran it, it found a path totalling 84860. I just started a longer run (100,000 generations with a larger population (300) to see if anything interesting pops up.

```#!/usr/bin/perl
#
#   trv... travelling salesman problem
#
use strict;
use warnings;
use List::Util qw( shuffle );

my %D;
my (\$R, \$C) = (0);
while (<DATA>) {
my @t = split /\s+/, \$_;
\$C=0;
shift @t; # remove row hdr
while (@t) {
my (\$dist, \$a, \$b);
\$dist = shift @t;
(\$a,\$b) = (\$R>\$C) ? (\$C, \$R) : (\$R, \$C);
if (\$a != \$b) {
if (exists \$D{\$a}{\$b}) {
die "Mismatch (\$R,\$C)=\$dist, but (\$C,\$R)=\$D{\$a}{\$b}\n"
+ if \$dist != \$D{\$a}{\$b};
}
\$D{\$a}{\$b} = \$dist;
}
++\$C;
}
++\$R;
}

sub dist {
my (\$r, \$c) = @_;
die "Eh?  \$r == \$c!\n" if \$r eq \$c;
(\$r, \$c) = (\$c, \$r) if \$c < \$r;
die "\$r,\$c entry DNE?\n" unless exists \$D{\$r}{\$c};
\$D{\$r}{\$c};
}

my @population;
my (\$sum_min, \$sum_max) = (0, 0);
goofy_naive_genetic_algorithm();
print "bounds: \$sum_min .. \$sum_max\n";

sub goofy_naive_genetic_algorithm {
# first populate the dataset
push @population, [ undef, [ generate_random_path() ] ] for 0 .. 1
+00;

# compute absolute best and worst bounds
for my \$i (1 .. 24) {
my (\$min, \$max) = (99999999, -1);
for my \$j (1 .. 24) {
next if \$j == \$i;
my \$d = dist(\$i, \$j);
\$min = \$d if \$min > \$d;
\$max = \$d if \$max < \$d;
}
\$sum_min += \$min;
\$sum_max += \$max;
}
print "bounds: \$sum_min .. \$sum_max\n";

for my \$gen (1 .. 1000) {
@population = @population[0 .. 100];

# for each generation, make "children" of the various items
for my \$i (0 .. \$#population) {
my (\$beg, \$end) = (1 + int 22*rand, 1 + int 22*rand);
redo if \$end == \$beg;
(\$beg, \$end) = (\$end, \$beg) if \$end<\$beg;
my @path = @{\$population[\$i][1]};
my @newpath;

if (0.3 > rand) {
# Randomize the middle section
@newpath = ( @path[0 .. \$beg-1], shuffle(@path[\$beg..\$
+end]), @path[\$end+1 .. \$#path] );
}
else {
# reverse the middle section
@newpath = ( @path[0 .. \$beg-1], reverse(@path[\$beg..\$
+end]), @path[\$end+1 .. \$#path] );
}

push @population, [ undef, [ @newpath ] ];
}

# Evaluate and display all the paths
my \$cnt=0;
my %dedup;
for my \$r (@population) {
# evaluate only if not already done
\$r->[0] = eval_path(@{\$r->[1]}) if ! defined \$r->[0];
++\$cnt;
my \$t = path_2_str(@{\$r->[1]});
\$dedup{\$t} = \$r;
}

@population = sort { \$a->[0] <=> \$b->[0] } values %dedup;
my \$worst = \$population[-1][0];
print "GEN \$gen best: (\$population[0][0]) : ", path_2_str(@{\$p
+opulation[0][1]}), "  (worst=\$worst)\n";
}
}

print "Final population:\n\n";
for my \$i (0 .. \$#population) {
my \$t = path_2_str(@{\$population[\$i][1]});
printf "% 4u (% 7u) : %s\n", \$i, ,\$population[\$i][0],  \$t;
}

sub path_2_str {
my @p = map { sprintf "% 2u", \$_ } @_;
return join("->",@p);
}

sub eval_path {
my \$dist = 0;
my @path = @_;
my \$cur = shift @path;
while (@path) {
my \$next = shift @path;
\$dist += dist(\$cur,\$next);
\$cur = \$next;
}
\$dist;
}

sub generate_random_path {
( 1, shuffle(2 .. 23), 24 )
}

# Matrix shows distance from pt on left to dest column
__DATA__
0     1     2     3     4     5     6     7     8     9    10
+11    12    13    14    15    16    17    18    19    20    21    22
+   23    24
1     0  3812 13902  8619 15811  5015  5230  9615 10624 13346  75
+75  6170  6812  9487 18135  8030  5409 17959 12822 17136  3267 12882
+11223 11078
2  3812     0 11527 12431 15446  8057  4519  8761 14398 12569  37
+64  6668 10603 11117 14805  5154  8276 18175  9367 14840  7056  9698
+13603  7266
3 13902 11527     0 13638 10220 18405  8675  4611 12993 11970  87
+98  8226 15087 16591  6859  6381 11223  7602  3236  3457 14535  8830
+14748  6655
4  8619 12431 13638     0  9965  5555 11256 11549  2157 10917 161
+94  9609  1926  7111 12565 14906  5737  9378 16868 11899  5402 15921
+ 5765 19675
5 15811 15446 10220  9965     0 11122 18683 14599  7873  2940 131
+19 17793 11057  6374  3517 14973 15565  3627 10307  7077 14478  6475
+ 5155 10235
6  5015  8057 18405  5555 11122     0 10109 13856  6744  9617 113
+48 10270  3811  4858 14594 12975  7186 13212 17301 17106  3881 12658
+ 6210 14138
7  5230  4519  8675 11256 18683 10109     0  4584 13284 16923  60
+18  2299 10267 14709 15205  3741  5549 15863  8377 11981  6865 12543
+16177  8600
8  9615  8761  4611 11549 14599 13856  4584     0 12503 16548  82
+40  3619 11888 18524 11444  4627  6948 11282  6102  7523  9992 12321
+16782  8550
9 10624 14398 12993  2157  7873  6744 13284 12503     0  9231 180
+70 11405  3813  6447 10427 16699  7735  7340 15982 10421  7492 14151
+ 4374 18092
10 13346 12569 11970 10917  2940  9617 16923 16548  9231     0 110
+52 19220 11199  4874  5269 14093 16358  6543 10709  9458 13488  5008
+ 5170  9146
11  7575  3764  8798 16194 13119 11348  6018  8240 18070 11052
+ 0  8220 14354 12490 11186  3614 11306 14452  5954 11533 10801  6649
+14987  3508
12  6170  6668  8226  9609 17793 10270  2299  3619 11405 19220  82
+20     0  9124 15115 15059  5330  3975 14165  9100 10994  6469 14453
+15268 10326
13  6812 10603 15087  1926 11057  3811 10267 11888  3813 11199 143
+54  9124     0  6645 14126 13999  5168 11153 17968 13808  3728 15782
+ 6168 17749
14  9487 11117 16591  7111  6374  4858 14709 18524  6447  4874 124
+90 15115  6645     0  9754 15942 11588  9288 15400 13331  8652  9157
+ 2621 12782
15 18135 14805  6859 12565  3517 14594 15205 11444 10427  5269 111
+86 15059 14126  9754     0 11725 16484  3379  6883  4250 17835  5311
+ 8643  7729
16  8030  5154  6381 14906 14973 12975  3741  4627 16699 14093  36
+14  5330 13999 15942 11725     0  9173 13841  4874  9780 10451  9122
+18555  5003
17  5409  8276 11223  5737 15565  7186  5549  6948  7735 16358 113
+06  3975  5168 11588 16484  9173     0 13413 12955 12642  3450 17931
+11293 14142
18 17959 18175  7602  9378  3627 13212 15863 11282  7340  6543 144
+52 14165 11153  9288  3379 13841 13413     0  9181  4145 14775  8581
+ 7147 10945
19 12822  9367  3236 16868 10307 17301  8377  6102 15982 10709  59
+54  9100 17968 15400  6883  4874 12955  9181     0  5593 15242  6278
+15447  3419
20 17136 14840  3457 11899  7077 17106 11981  7523 10421  9458 115
+33 10994 13808 13331  4250  9780 12642  4145  5593     0 15914  8478
+11291  8453
21  3267  7056 14535  5402 14478  3881  6865  9992  7492 13488 108
+01  6469  3728  8652 17835 10451  3450 14775 15242 15914     0 15624
+ 9326 14308
22 12882  9698  8830 15921  6475 12658 12543 12321 14151  5008  66
+49 14453 15782  9157  5311  9122 17931  8581  6278  8478 15624     0
+10157  4139
23 11223 13603 14748  5765  5155  6210 16177 16782  4374  5170 149
+87 15268  6168  2621  8643 18555 11293  7147 15447 11291  9326 10157
+    0 14265
24 11078  7266  6655 19675 10235 14138  8600  8550 18092  9146  35
+08 10326 17749 12782  7729  5003 14142 10945  3419  8453 14308  4139
+14265     0

Update: Oops! Replied to the wrong node. Also, should've refreshed the page. When I started coding, there weren't so many replies!

Update 2: I let the other run go for about 80K generations, but it never found anything better.

...roboticus

When your only tool is a hammer, all problems look like your thumb.

Replies are listed 'Best First'.
Re^3: Travelling problem (Anyone better 86850?)
by BrowserUk (Pope) on Dec 23, 2013 at 20:08 UTC

Similar methodology to mine, and the same problem.

Many times it will find the minima well within your 1000 generations; but on those occasions where it settles into a false minima; it doesn't (seem to; limited runs) matter how many more generations you run it for; it will never find it.

That's what I've been trying to find a solution to for the last couple of days. So far, without much success.

The problem appears to be that if you discard too vigorously, you settle into re-trying variations of the same paths over and over without ever introducing any "new blood".

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.

Create A New User
Node Status?
node history
Node Type: note [id://1068237]
help
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
As of 2018-02-18 08:51 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
When it is dark outside I am happiest to see ...

Results (252 votes). Check out past polls.

Notices?