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

One problem is that this:

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

[download]

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

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

[download]

(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__
...

[download]

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

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.

Replies are listed 'Best First'.
Re^11: Travelling problem (Anyone better 86850?)
by hdb (Monsignor) on Dec 27, 2013 at 08:29 UTC

    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.

[reply]
[d/l]

      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:

      <Reveal this spoiler>

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

      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.
[reply]
[d/l]
[select]
      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.

      [download]

      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.

      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.
[reply]
[d/l]

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

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

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

      Cheers Rolf

      ( addicted to the Perl Programming Language)

[reply]

In Section Seekers of Perl Wisdom