Shortest route

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.

Analysis

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:

1. 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.
2. 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!

Nice demo of the complicated task as well as detailed analysis. Keep it up great work.

Try it 

#!/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;
}

67 lines of code

Output from script

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)