Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

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

by BrowserUk (Pope)
on Dec 24, 2013 at 14:08 UTC ( #1068312=note: print w/ replies, xml ) Need Help??


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

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.


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.


Comment on Re^10: Travelling problem (Anyone better 86850?)
Select or Download Code
Re^11: Travelling problem (Anyone better 86850?)
by hdb (Prior) 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.

      > 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)

      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:

      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.


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


      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.

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

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://1068312]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (10)
As of 2014-11-28 07:31 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My preferred Perl binaries come from:














    Results (193 votes), past polls