Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Re: Finding All Paths From a Graph From a Given Source and End Node

by Limbic~Region (Chancellor)
on Oct 28, 2010 at 18:38 UTC ( #868113=note: print w/replies, xml ) Need Help??


in reply to Finding All Paths From a Graph From a Given Source and End Node

neversaint,
Per our conversation, here is an example of finding all paths using a depth-first search. It is unoptimized and with all the copying of arrays and hashes - I wouldn't expect it to be a top performer as is. I am thinking about the self-pruning approach I alluded to earlier as I have to convince myself it will still work with a directed graph (which I now realize this is). If it works, I will post it as well.
#!/usr/bin/perl use constant LAST => -1; use constant PATH => 0; use constant SEEN => 1; use strict; use warnings; my %graph = ( F => [qw/B C E/], A => [qw/B C/], D => [qw/B/], C => [qw/A E F/], E => [qw/C F/], B => [qw/A E F/] ); my $routes = find_paths('B', 'E', \%graph); print "@$_\n" for @$routes; sub find_paths { my ($beg, $end, $graph) = @_; my @solution; my @work; for (@{$graph->{$beg}}) { push @solution, [$beg, $end] if $_ eq $end; push @work, [[$beg, $_], {$beg => undef, $_ => undef}]; } while (@work) { my $item = pop @work; my ($path, $seen) = @{$item}[PATH, SEEN]; for my $node (@{$graph->{$path->[LAST]}}) { next if exists $seen->{$node}; my @new_path = (@$path, $node); if ($node eq $end) { push @solution, \@new_path; next; } my %new_seen = (%$seen, $node => undef); push @work, [\@new_path, \%new_seen]; } } return \@solution; }

Update: Assuming you can create a function to convert your node name to an integer (preferrably 0 based) then the following should be a lot faster assuming copying strings is faster than arrays and hashes.

#!/usr/bin/perl use strict; use warnings; my %graph = ( F => [qw/B C E/], A => [qw/B C/], D => [qw/B/], C => [qw/A E F/], E => [qw/C F/], B => [qw/A E F/] ); my $routes = find_paths('B', 'E', \%graph); print "$_\n" for @$routes; sub find_paths { my ($beg, $end, $graph) = @_; my (@work, @solution); for (@{$graph->{$beg}}) { if ($_ eq $end) { push @solution, "$beg->$end"; next; } my $seen = ''; vec($seen, node_to_int($_), 1) = 1; vec($seen, node_to_int($beg), 1) = 1; push @work, ["$beg->$_", $_, $seen]; } while (@work) { my $item = pop @work; my ($path, $curr, $seen) = @$item; for my $node (@{$graph->{$curr}}) { my $bit = node_to_int($node); next if vec($seen, $bit, 1); if ($node eq $end) { push @solution, "$path->$end"; next; } my $new_seen = $seen; vec($new_seen, $bit, 1) = 1; push @work, ["$path->$node", $node, $new_seen]; } } return \@solution; } sub node_to_int { my ($node) = @_; return ord($node) - 65; }

Update 2: Here is a version using short-circuiting. I am not happy with it since you need to enumerate over an array of bitstrings to determine if the path can be pruned rather than doing a lookup. I may post my own SoPW to see if anyone can come up with a better way. I have tried this on a very limited test set so it could very well be flawed. I would be interested to know how it fairs performance wise on real data as well as if it can be found to be flawed.

#!/usr/bin/perl use strict; use warnings; my %graph = ( R => [qw/L J Z/], L => [qw/R J X/], J => [qw/R L X Z/], Z => [qw/R J X/], X => [qw/L J Z F D/], F => [qw/X D/], D => [qw/Q F X/], Q => [qw/B U D/], B => [qw/Q P M/], P => [qw/B U/], U => [qw/Q P S/], M => [qw/B S/], S => [qw/U M/], ); my $routes = find_paths('D', 'M', \%graph); print "$_\n" for @$routes; sub find_paths { my ($beg, $end, $graph) = @_; my (@work, @solution, %done); for (@{$graph->{$beg}}) { if ($_ eq $end) { push @solution, "$beg->$end"; next; } my $seen = ''; vec($seen, node_to_int($_), 1) = 1; vec($seen, node_to_int($beg), 1) = 1; push @work, ["$beg->$_", $_, $seen]; } while (@work) { my $item = pop @work; my ($path, $curr, $seen) = @$item; my $ok; for my $node (@{$graph->{$curr}}) { my $bit = node_to_int($node); next if vec($seen, $bit, 1) || ($done{$node} && path_compl +eted($seen, $done{$node})); $ok = 1; if ($node eq $end) { push @solution, "$path->$end"; next; } my $new_seen = $seen; vec($new_seen, $bit, 1) = 1; push @work, ["$path->$node", $node, $new_seen]; } update_completed_paths($path, $seen, \%done) if ! $ok; } return \@solution; } sub node_to_int { my ($node) = @_; return ord($node) - 65; } sub update_completed_paths { my ($path, $seen, $done) = @_; my @order = split /->/, $path; for my $idx (reverse 0 .. $#order - 1) { local $_ = $order[$idx]; vec($seen, node_to_int($_), 1) = 0; push @{$done->{$_}}, $seen; } } sub path_completed { my ($path, $completed) = @_; for (@$completed) { my $and = $_ & $path; return 1 if $and eq $_; } return; }

Cheers - L~R

Replies are listed 'Best First'.
Re^2: Finding All Paths From a Graph From a Given Source and End Node
by choroba (Archbishop) on Oct 28, 2010 at 21:06 UTC
    I tried to benchmark your subs (together with my ones - Update: that turned out to be slower). The short circuiting approach is slower than the previous one.
      choroba,
      The short circuiting approach is slower than the previous one

      I suspect this will heavily depend on the test data which neversaint hasn't supplied. In a nutshell, I am recording path information on the basis that it will pay off down the road. If there is no short circuit possibilities then the overhead of tracking will not be paid for and it becomes slower.

      This is why I said I was unhappy with it. I am going to let this sit in my feeble brain for a while and if I can't come up with a better approach I will post a new thread for other monks to weigh in on.

      Update: The following is the basically the same algorithm with some optimizations. I would be interested in your test data and/or your benchmark.

      Cheers - L~R

        Here is my code as it is (your subs removed):
        Using your graph and R=>P as the path, the short circuit is the best:
        Rate breadth limbic depth limbic_sc breadth 158/s -- -34% -42% -60% limbic 238/s 51% -- -13% -39% depth 274/s 73% 15% -- -30% limbic_sc 392/s 148% 65% 43% --

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (5)
As of 2020-03-29 06:57 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    To "Disagree to disagree" means to:









    Results (169 votes). Check out past polls.

    Notices?