Evens go first and

untangling the route

Weekly challenge 213 — 17 April 2023

Week 213 - 17 Apr 2023

Task 2

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.

This task is a variant on the 'travelling salesman problem', for which there is a wealth of literature. The Christophides algorithm is the basis of the generally accepted best solutions, amd someone in the team will probably come up with a solution based on that.

That person is not me. My solution simply explores all the possible routes, turning back as soon as the route under investigation proves to be a dead end. It works well for the example solutions and ones a bit more complicated, but will be rather slow for longer routes.

The important function is

dist_to_target
($from, $to, \[\@route1, \@route2 ...]])

This starts from the point having the value $from and does two things:

- Checks along $route to see if it finds $route->[$from]->[$point] having the value $to; if so it has a solution. If that solution is the best (ie shortest) found so far, it stores the length and the route it took to get there in global variables.
- Checks along $route to find any nodes, and if so jumps to the (or each) crossing route and calls itself recursively.

There are a number of pitfalls to be avoided. For example, to avoid infinite recursion it keeps track of the nodes already visited and avoid journeys which re-use such any nodes.

There are also some tricky cases to take care of, such as:

- The best journey using two stretches of the same route (see my 2nd example).
- There being more than possible one starting or finishing point (my 6th example).

All in all, a deceptively tricky challenge!

#!/usr/bin/perl use v5.16; # The Weekly Challenge - 2023-04-17 use utf8; # Week 213 task 2 - Shortest route use strict; # Peter Campbell Smith use warnings; # Blog: http://ccgi.campbellsmiths.force9.co.uk/challenge my ($shortest, $from_value, $to_value, $routes, @nodes, $best, $best_journey); shortest_route(1, 9, [[1, 2, 3, 4], [4, 5, 6, 7, 8, 9]]); shortest_route(1, 3, [[1, 2, 7, 7, 7, 3, 4],[2, 4]]); shortest_route(1, 9, [[1, 2, 3],[3, 4, 5],[5, 6, 9]]); shortest_route(1, 9, [[9, 8, 7], [5, 6, 7], [1, 2, 5]]); shortest_route(1, 9, [[1, 2, 3, 9], [1, 5, 9]]); shortest_route(1, 9, [[1, 2, 3, 6], [1, 2, 3, 4, 7], [1, 2, 3, 4, 5, 9]]); sub shortest_route { my ($r, $p, $o, $distance, $j, $v, $s, @starts, $rubric, $journey); # initialise $from_value = $_[0]; $to_value = $_[1]; $routes = $_[2]; $best = 1e6; @nodes = (); # show input print qq[\nInput: \@routes = (]; for $r (0 .. scalar @$routes - 1) { $rubric .= qq{[} . join(', ', @{$routes->[$r]}) . q{], }; } say substr($rubric, 0, -2) . ')'; say qq[ \$source = $from_value]; say qq[ \$destination = $to_value]; # index all points by value and identifiy possible starts $j = 0; for $r (0 .. scalar @$routes - 1) { for $p (0 .. scalar @{$routes->[$r]} - 1) { $v = $routes->[$r]->[$p]; $nodes[$v] .= qq[$r,$p!]; $starts[$j ++] = qq[$r,$p] if $v == $from_value; } } # discard values not on >1 route, thus leaving only nodes for $v (0 .. scalar @nodes - 1) { if (defined $nodes[$v]) { if ($nodes[$v] !~ m|!.+!|) { undef $nodes[$v]; } } } # loop over all starting points $best_journey = ''; for $s (@starts) { ($r, $p) = split(',', $s); $journey = dist_to_target($r, $p, '', 0, qq[$from_value, ]); } if ($best < 1e6) { say qq[Output: \$distance = $best]; say qq[ \@journey = (] . substr($best_journey, 0, -2) . ')'; } else { say qq[Output: -1]; } } sub dist_to_target { my ($route, $point, $p, $nodes, $distance, $avoid, $journey, $v, $r, $n, $distance2, $in_journey); ($route, $point, $avoid, $distance, $journey) = @_; $in_journey = $journey; # check along route for target for $p (0 .. scalar @{$routes->[$route]} - 1) { # found target value if ($routes->[$route]->[$p] == $to_value) { $distance2 = $distance + abs($p - $point); # new best distance if ($distance2 < $best) { # add last step to journey if ($p > $point) { for ($n = $point + 1; $n <= $p; $n ++) { $journey .= qq[$routes->[$route]->[$n], ]; } } elsif ($p < $point) { for ($n = $point - 1; $n >= $p; $n --) { $journey .= qq[$routes->[$route]->[$n], ]; } } # save result $best = $distance2; $best_journey = $journey; } } } # no target on this route so check along route for nodes for $n (0 .. scalar @{$routes->[$route]} - 1) { next if $n == $point; # check for unvisited nodes on this route $nodes = defined $nodes[$routes->[$route]->[$n]] ? $nodes[$routes->[$route]->[$n]] : ''; next unless $nodes; while ($nodes =~ m|(\d+),(\d+)|g) { # get journey so far, avoid nodes already visited $journey = $in_journey; ($r, $p) = ($1, $2); next unless $r != $route; next if $avoid =~ m|!$r,$p|; $avoid .= qq[!$r,$p!]; # add points to journey if ($n > $point) { $in_journey = qq[${in_journey}$routes->[$route]->[$_], ] for ($point + 1 .. $n); } elsif ($n < $point) { for ($v = $point - 1; $v > $n; $v --) { $in_journey = qq[$in_journey$routes->[$route]->[$v], ]; } } # and recurse $journey = dist_to_target($1, $2, $avoid, $distance + abs($n - $point), $in_journey); } } return $journey; }

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

The content of
this website
is licensed by
Peter
Campbell Smith under a
Creative Commons Attribution 4.0 International Licence