note
Limbic~Region
[neversaint],
<br />
Per our conversation, here is an example of finding all paths using a [wp://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.
<readmore>
<c>
#!/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;
}
</c>
</readmore>
<p>
<b>Update:</b> 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.
<readmore>
<c>
#!/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;
}
</c>
</readmore>
</p>
<p>
<b>Update 2:</b> 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.
<readmore>
<c>
#!/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_completed($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;
}
</c>
</readmore>
</p>
<div class="pmsig"><div class="pmsig-180961">
<p>
Cheers - [Limbic~Region|L~R]
</p>
</div></div>
868031
868031