Beefy Boxes and Bandwidth Generously Provided by pair Networks Joe
Perl-Sensitive Sunglasses
 
PerlMonks  

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

by hdb (Parson)
on Dec 24, 2013 at 08:39 UTC ( #1068300=note: print w/ replies, xml ) Need Help??


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

Thanks for your help. I have tried to implement 1. - 5. but I now get the following:

$ time perl tsp2_v6.pl 2 95383: 1 2 11 16 7 12 8 3 19 20 18 15 5 10 14 23 9 4 13 21 17 6 22 24 +Tue Dec 24 09:35:20 2013 95166: 1 21 17 12 7 16 11 2 6 13 4 9 23 14 10 5 15 18 20 3 19 8 22 24 +Tue Dec 24 09:35:20 2013 92839: 1 21 13 4 9 23 14 6 17 12 7 16 11 2 8 3 19 20 18 15 5 10 22 24 +Tue Dec 24 09:35:20 2013 90498: 1 21 17 12 7 16 11 2 6 13 4 9 23 14 10 5 15 18 20 3 8 19 22 24 +Tue Dec 24 09:35:20 2013 89483: 1 21 13 4 9 23 14 6 17 12 7 2 11 16 8 3 19 20 18 15 5 10 22 24 +Tue Dec 24 09:35:20 2013 88838: 1 21 13 4 9 23 14 6 17 12 7 2 11 16 8 19 3 20 18 15 5 10 22 24 +Tue Dec 24 09:35:20 2013 86867: 1 2 11 16 7 12 17 21 6 13 4 9 23 14 10 5 15 18 20 3 8 19 22 24 +Tue Dec 24 09:35:22 2013 85294: 1 2 11 16 7 8 12 17 21 6 13 4 9 23 14 10 5 15 18 20 3 19 22 24 +Tue Dec 24 09:35:24 2013 84860: 1 2 11 16 8 7 12 17 21 6 13 4 9 23 14 10 5 15 18 20 3 19 22 24 +Tue Dec 24 09:35:32 2013 Perl exited with active threads: 5 running and unjoined 194 finished and unjoined 0 running and detached real 0m32.107s user 1m18.492s sys 0m24.782s

Any idea?

Here is my updated code:

use strict; use warnings; use threads; use threads::shared; use List::Util qw( sum min ); my $glength :shared; my @dist = <DATA>; $_ = [ split /\s+/ ] and shift @$_ for @dist; $glength = 0.5 * sum map { sum @$_ } @dist; sub path_recursive { my( $bound, $len, $path, $end, $tbv, $dist ) = @_; if( !@$tbv ) { $len += $dist->[ $path->[-1] ]->[$end]; if( $len < $glength ) { lock $glength; $glength = $len; print "$len: @$path $end ",scalar(localtime),"\n"; } return; } my $last = $dist->[ $path->[-1] ]; my @nextedge = sort { $last->[$a] <=> $last->[$b] } @$tbv; my @threads; for (1..min($bound,@nextedge)){ my $next = shift @nextedge; if( scalar( threads->list(threads::running) ) < 3 ) { push @threads, threads->create( \&path_recursive, $bound, $len + + $last->[$next], [ @$path, $next ], $end, [ @nextedge ], $dist ); } else { path_recursive( $bound, $len + $last->[$next], [ @$path, $next ] +, $end, [ @nextedge ], $dist ); } push @nextedge, $next; } $_->is_joinable() and $_->join() for @threads; } path_recursive shift(), 0, [ 1 ], 24, [ 2..23 ], \@dist; $_->join() for threads->list(threads::all); __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


Comment on Re^9: Travelling problem (Anyone better 86850?)
Select or Download Code
Re^10: Travelling problem (Anyone better 86850?)
by BrowserUk (Pope) on Dec 24, 2013 at 14:08 UTC

    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.

      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:

        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.

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (8)
As of 2014-04-19 09:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (480 votes), past polls