TL;DR

On with TASK #2 from The Weekly Challenge #213. Enjoy!

# The challenge

You are given a list of bidirectional routes defining a network of nodes, as well as source and destination node numbers.

Write a script to find the route from source to destination that passes through fewest nodes.

Example 1:

Input: @routes = ([1,2,6], [5,6,7])
$source = 1$destination = 7

Output: (1,2,6,7)

Source (1) is part of route [1,2,6] so the journey looks like 1 -> 2 -> 6
then jump to route [5,6,7] and takes the route 6 -> 7.
So the final route is (1,2,6,7)


Example 2:

Input: @routes = ([1,2,3], [4,5,6])
$source = 2$destination = 5

Output: -1


Example 3:

Input: @routes = ([1,2,3], [4,5,6], [3,8,9], [7,8])
$source = 1$destination = 7
Output: (1,2,3,8,7)

Source (1) is part of route [1,2,3] so the journey looks like 1 -> 2 -> 3
then jump to route [3,8,9] and takes the route 3 -> 8
then jump to route [7,8] and takes the route 8 -> 7
So the final route is (1,2,3,8,7)


# The questions

None, but maybe a curiosity â€“why are all those called routes?

# The solution

For the Perl solution, weâ€™ll leverage the venerable A*. I know, thereâ€™s no good candidate for the heuristic in this case, so itâ€™s basically Dijkstraâ€™s algorithm.

#!/usr/bin/env perl
use v5.24;
use warnings;
use experimental 'signatures';

use Data::Dumper;

my @routes = ([1,2,3], [4,5,6], [3,8,9], [7,8]);
my $source = 1; my$destination = 7;
my $route = shortest_route(\@routes,$source, $destination) // []; { local$" = ','; say $route->@* ? "($route->@*)" : -1 }

sub shortest_route ($routes,$src, $dst) { my$graph = routes_to_graph($routes); return scalar astar( start =>$src,
goal  => $dst, distance => sub { return 1 }, successors => sub ($v) { keys $graph->{$v}->%* },
identifier => sub ($v) {$v },
);
}

sub routes_to_graph ($routes) { my %adjacents_for; for my$route ($routes->@*) { my$prev = $route->[0]; for my$i (1 .. $route->$#*) {
my $curr =$route->[$i];$adjacents_for{$prev}{$curr} = $adjacents_for{$curr}{$prev} = 1;$prev = $curr; } } return \%adjacents_for; } sub astar { my %args = (@_ && ref($_[0])) ? %{$_[0]} : @_; my @reqs = qw< start goal distance successors >; exists($args{$_}) || die "missing parameter '$_'" for @reqs;
my ($start,$goal, $dist,$succs) = @args{@reqs};
my $h =$args{heuristic}  || $dist; my$id_of = $args{identifier} || sub { return "$_[0]" };

my ($id,$gid) = ($id_of->($start), $id_of->($goal));
my %node_for = ($id => {value =>$start, g => 0});
my $queue = bless ['-', {id =>$id, f => 0}], __PACKAGE__;

while (!$queue->_is_empty) { my$cid = $queue->_dequeue->{id}; my$cx  = $node_for{$cid};
next if $cx->{visited}++; my$cv = $cx->{value}; return __unroll($cx, \%node_for) if $cid eq$gid;

for my $sv ($succs->($cv)) { my$sid = $id_of->($sv);
my $sx =$node_for{$sid} ||= {value =>$sv};
next if $sx->{visited}; my$g = $cx->{g} +$dist->($cv,$sv);
next if defined($sx->{g}) && ($g >= $sx->{g}); @{$sx}{qw< p g >} = ($cid,$g);    # p: id of best "previous"
$queue->_enqueue({id =>$sid, f => $g +$h->($sv,$goal)});
} ## end for my $sv ($succs->($cv...)) } ## end while (!$queue->_is_empty)

return;
} ## end sub astar

sub _dequeue {                              # includes "sink"
my ($k,$self) = (1, @_);
my $r = ($#$self > 1) ? (splice @$self, 1, 1, pop @$self) : pop @$self;
while ((my $j =$k * 2) <= $#$self) {
++$j if ($j < $#$self) && ($self->[$j + 1]{f} < $self->[$j]{f});
last if $self->[$k]{f} < $self->[$j]{f};
(@{$self}[$j, $k],$k) = (@{$self}[$k, $j],$j);
}
return $r; } ## end sub _dequeue sub _enqueue { # includes "swim" my ($self, $node) = @_; push @$self, $node; my$k = $#$self;
(@{$self}[$k / 2, $k],$k) = (@{$self}[$k, $k / 2], int($k / 2))
while ($k > 1) && ($self->[$k]{f} <$self->[$k / 2]{f}); } ## end sub _enqueue sub _is_empty { return !$#{$_[0]} } sub __unroll { # unroll the path from start to goal my ($node, $node_for, @path) = ($_[0], $_[1],$_[0]{value});
while (defined(my $p =$node->{p})) {
$node =$node_for->{$p}; unshift @path,$node->{value};
}
return wantarray ? @path : \@path;
} ## end sub __unroll


For the Raku solution, then, weâ€™re using Dijkstraâ€™s algorithm:

#!/usr/bin/env raku
use v6;

sub MAIN {
my @routes = [1,2,3], [4,5,6], [3,8,9], [7,8];
my $source = 1; my$destination = 6;
my $route = shortest-route(@routes,$source, $destination) // -1; say$route;
}

class Dijkstra { ... }
class PriorityQueue { ... }

sub shortest-route (@routes, $src,$dst) {
my $graph = routes-to-graph(@routes); my$d = Dijkstra.new(
distance => { $graph{$^a}{$^b} }, successors => {$graph{$^a}.keys }, start =>$src,
goals => [ $dst ], ); return$d.path-to($dst); } sub routes-to-graph (@routes) { my %adjacents_for; for @routes ->$route {
my $prev =$route[0];
for (1 ..^ @$route) ->$i {
my $curr =$route[$i]; %adjacents_for{$prev}{$curr} = %adjacents_for{$curr}{$prev} = 1;$prev = $curr; } } return %adjacents_for; } class Dijkstra { has %!thread-to is built; # thread to a destination has$!start     is built;     # starting node
has &!id-of     is built;     # turn a node into an identifier

method new (:&distance!, :&successors!, :$start!, :@goals, :$more-goals is copy, :&id-of = -> $n {$n.Str }) {
my %is-goal = @goals.map: { &id-of($_) => 1 };$more-goals //= (sub ($id) { %is-goal{$id}:delete; %is-goal.elems })
if %is-goal.elems;
my $id = &id-of($start);
my $queue = PriorityQueue.new( before => sub ($a, $b) {$a<d> < $b<d> }, id-of => sub ($n) { $n<id> }, items => [{v =>$start, id => $id, d => 0},], ); my %thr-to =$id => {d => 0, p => Nil, pid => $id}; while !$queue.is-empty {
my ($ug,$uid, $ud) =$queue.dequeue<v id d>;
for &successors($ug) ->$vg {
my ($vid,$alt) = &id-of($vg),$ud + &distance($ug,$vg);
next if ($queue.contains-id($vid)
?? ($alt >= (%thr-to{$vid}<d> //= $alt + 1)) !! (%thr-to{$vid}:exists));
$queue.enqueue({v =>$vg, id => $vid, d =>$alt});
%thr-to{$vid} = {d =>$alt, p => $ug, pid =>$uid};
}
}
self.bless(thread-to => %thr-to, :&id-of, :$start); } method path-to ($v is copy) {
my $vid = &!id-of($v);
my $thr = %!thread-to{$vid} or return;
my @retval;
while defined $v { @retval.unshift:$v;
($v,$vid) = $thr<p pid>;$thr = %!thread-to{$vid}; } return @retval; } method distance-to ($v) { (%!thread-to{&!id-of($v)} // {})<d> } } class PriorityQueue { has @!items; has %!pos-of; has %!item-of; has &!before; has &!id-of; submethod BUILD ( :&!before = {$^a < $^b}, :&!id-of = {~$^a},
:@items
) {
@!items = '-';
self.enqueue($_) for @items; } method contains ($obj --> Bool) { self.contains-id(&!id-of($obj)) } method contains-id ($id --> Bool) { %!item-of{$id}:exists } method dequeue { self!remove-kth(1) } method elems { @!items.end } # method enqueue ($obj) <-- see below
method is-empty { @!items.elems == 1 }
method item-of ($id) { %!item-of{$id}:exists ?? %!item-of{$id} !! Any } method remove ($obj) { self.remove-id(&!id-of($obj)) } method remove-id ($id) { self!remove-kth(%!pos-of{$id}) } method size { @!items.end } method top { @!items.end ?? @!items[1] !! Any } method top-id { @!items.end ?? &!id-of(@!items[1]) !! Any } method enqueue ($obj) {
my $id = &!id-of($obj);
%!item-of{$id} =$obj; # keep track of this item
@!items[my $k = %!pos-of{$id} ||= @!items.end + 1] = $obj; self!adjust($k);
return $id; } method !adjust ($k is copy) { # assumption: $k <= @!items.end$k = self!swap(($k / 2).Int,$k)
while ($k > 1) && &!before(@!items[$k], @!items[$k / 2]); while (my$j = $k * 2) <= @!items.end { ++$j if ($j < @!items.end) && &!before(@!items[$j+1], @!items[$j]); last if &!before(@!items[$k], @!items[$j]); # parent is OK$k = self!swap($j,$k);
}
return self;
}
method !remove-kth (Int:D $k where 0 <$k <= @!items.end) {
self!swap($k, @!items.end); my$r = @!items.pop;
self!adjust($k) if$k <= @!items.end; # no adjust for last element
my $id = &!id-of($r);
%!item-of{$id}:delete; %!pos-of{$id}:delete;
return $r; } method !swap ($i, $j) { my ($I, $J) = @!items[$i, $j] = @!items[$j, $i]; %!pos-of{&!id-of($I)} = $i; %!pos-of{&!id-of($J)} = $j; return$i;
}
}


Stay safe and minimal!

Comments? Octodon, , GitHub, Reddit, or drop me a line!