Re^10: Travelling problem (Anyone better 86850?)

[BrowserUk]

One problem is that this:

  for (1..min($bound,@nextedge)){

Isn't doing what you think. (I believe) It should be:

  for( 1 .. min( $bound, scalar( @nextedge ) ) ){

(That kept me guessing for an inordinate amount of time :)

Threading recursive routines is difficult. My usual process is to break the routine into two parts; one which starts threads and the other that does simple recursion within those threads. Your routine wasn't written with that in mind, so the result is that the simplest refactoring is to duplicate the subroutine like this:

#! perl -slw
use strict;
use threads;
use threads::shared;
use List::Util qw( sum min );

my $running :shared = 0;
my $glength :shared;

sub _path_recursive {
    my( $bound, $len, $path, $end, $tbv, $dist ) = @_;

    if( !@$tbv ) {
        $len += $dist->[ $path->[-1] ][$end];
        lock $glength;
        if( $len < $glength ) {
            $glength = $len;
            print "$len: @$path $end ",scalar(localtime);
        }
        return;
    }

    my $last = $dist->[ $path->[-1] ];
    my @sorted = sort { $last->[$a] <=> $last->[$b] } @$tbv;

    for( 1 .. min( $bound, scalar( @sorted ) ) ){
        my $next = shift @sorted;
        _path_recursive( $bound, $len + $last->[$next], [ @$path, $nex
+t ], $end, [ @sorted ], $dist );
        push @sorted, $next;
    }
}

sub path_recursive {
    my( $bound, $len, $path, $end, $tbv, $dist ) = @_;

    if( !@$tbv ) {
        $len += $dist->[ $path->[-1] ][$end];
        if( $len < $glength ) {
            $glength = $len;
            print "$len: @$path $end ",scalar(localtime);
        }
        return;
    }

    my $last = $dist->[ $path->[-1] ];
    my @sorted = sort { $last->[$a] <=> $last->[$b] } @$tbv;

    for( 1 .. min( $bound, scalar( @sorted ) ) ){
        my $next = shift @sorted;
        sleep 1 while $running > 3;
        async {
            { lock $running; ++$running; }
            my $tid = threads->tid;
            print "[$tid] started";
            _path_recursive( $bound, $len + $last->[$next], [ @$path, 
+$next ], $end, [ @sorted ], $dist );
            { lock $running; --$running; }
            print "[$tid] ended";
        }->detach;
        sleep 1; ## give the thread a timeslice to get going.
        push @sorted, $next;
    }
    sleep 1 while $running;
}

my @dist = <DATA>;
$_ = [ split /\s+/ ] and shift @$_ for @dist;
$glength = 0.5 * sum map { sum @$_ } @dist;
path_recursive shift(), 0, [ 1 ], 24, [ 2..23 ], \@dist;

__DATA__
...

I'll try and do a better job of it after xmas.

[hdb]

Thanks for your good advice. I have adapted your approach in a slight modification where I introduce an indicator whether or not the recursive function is called from itself or from the outside. In the latter case, it starts threads otherwise it just calls itself within the same thread. This is at the cost of an additional if which I hope is not material (I have not run any benchmarks).

As a consequence, the script has successfully completed the restricted branching based on the shortest two or three next available edges (the latter took 12hrs), but it has not found any better solution than 84860.

[BrowserUk]

Here's my second attempt at a threaded version. Running it with -T=24 won't be fastest unless you have 24 cores, but it has the interesting side effect of running all first picks in parallel.

Ignore this! (I was forgetting to add the last distance :( )which yields several better than 84860 scores in just a few minutes:

<Reveal this spoiler or all spoilers in this node or all in this thread>

Source:

#! perl -slw
use strict;
use threads;
use threads::shared;

my @dists = map[ split ' ' ], <DATA>;

sub totalEm {
    my $aref = shift;
    my $total = 0;
    $total += $dists[ $aref->[ $_ - 1] ][ $aref->[ $_ ] ] for 1 .. $#{
+ $aref };
    return $total;
}

my $best :shared = 1e9;
sub rPath {
    my( $soFar, $path, $toAdd, $tid ) = @_;
    return if $soFar > $best;

    unless( @$toAdd ) {
        $soFar += $dists[ $path->[ -1 ] ][ 23 ];
        if( $soFar < $best ) {
            printf "[%2u] %u: @$path 23\n", $tid, $soFar,;
            $best = $soFar;
        }
        return;
    }

    my $last = $dists[ $path->[-1] ];
    my @ordered = sort { $last->[$a] <=> $last->[$b] } @$toAdd;

    for( 1 .. @ordered ) {
        my $next = shift @ordered;
        rPath( $soFar + $dists[ $path->[-1] ][ $next ], [ @$path, $nex
+t ], \@ordered, $tid );
        push @ordered, $next;
    }
}

our $T //= 4;
my $running :shared = 0;
for( 1 .. 22 ) {
    {lock $running; ++$running }
    async{
        my $tid = threads->tid;
        rPath( $dists[ 0 ][ $_ ], [ 0, $_ ], [ 1..$_-1, $_+1 .. 22 ], 
+$tid );
        { lock $running; --$running; }
    }->detach;
    sleep 1 while $running > $T-1
}

sleep 1 while $running;

__DATA__

I've also recoded the algorithm into C which runs very quickly, but so far I haven't threaded it.

[BrowserUk]

successfully completed the restricted branching based on the shortest two or three next available edges

My threaded C version has now completed restricted branching at shortest 2,3,4,5,6,7 available edges and the best it found are:

2 - 134842    1s  14e5 perms.
3 - 114847    23s 30e6 perms.
4 - 102428    4m  .5e9 perms. 
5 -  99505    15m  5e9 perms.
6 -  99056 1h 53m 30e9 perms.
7 -  92705 4h  7m 69e9 perms.

Note: The numbers are provisional in as much as I have repeated them to check they are repeatable; given the possibility of non-determinacy due to threading.

I'll leave it running overnight on 8.

[hdb]

My Perl code does find 84860 when restricting to the 2 or 3 shortest edges, so something seems to be wrong with your code...

[LanX]

Something seems wrong, plz compare hdb's results taking 2 shortest edges:

Re^5: Travelling problem (Anyone better 86850?)

edit

And keep in mind that the result for one shortest edge can't be better then yours for 6 ...

Re: Travelling problem

[LanX]

> but it has not found any better solution than 84860.

Did you also try the reverse way from 23 to 0?