Week 213 (!) of the Perl Weekly Challenge poses two problems that are good exercises in Perl programming.

Task 1: Fun Sort

This sort is fun in the sense that it's pretty easy to do.

You are given a list of positive integers.
Write a script to sort the all even integers first,
then all odds in ascending order.

There are three approaches: (1) sort the whole list with a comparison function that moves all the evens to the front of the list; (2) first separate the odds and evens, sort each group, and then combine the groups; or (3) first sort the whole list, then divide into evens and odds.

My preference is to do it in one sort, but it might be more efficient to partition the list first and do two smaller sorts. The sort efficiency is probably O(n log(n)). Sorting two lists of size n/2 will have fewer operations. For instance, if n=50, 50log(50) =~ 196, but 2*(25log(25)) =~ 161. This isn't going to be significant until n gets very large.

One sort to rule them all

In Perl, sort is builtin, and operates by applying a comparison function between pairs of elements, denoted $a and $b. The comparison function needs to return one of three values: less than 0 if $a sorts below $b; 0 if $a == $b; or greater than 0 if $a sorts above $b. Perl has a three-way comparison operator that does this for numbers, the <=> operator. A very basic numeric sort supplies the comparison function as the first argument to sort:

sort { $a <=> $b } @list

We also need to be able to determine odd and even. Mathematically, it's the modulo operator. n mod 2 is 0 for an even number and 1 for an odd number. Programmatically, it's the least significant bit of an integer. n&1 will be 0 for an even number and 1 for an odd number.

We need a comparison which has two conditions: first, any even number sorts below any odd number; otherwise, sort numerically. This is expressed with

sort { (($a&1) <=> ($b&1)) || ($a <=> $b) } @list 

The check for even and odd will push the even numbers below the odd numbers because the conditions evaluate like this:

If that is enough to determine an order, the || operator will not even evaluate its right side, but if both numbers are odd or both even, then the second comparison will determine the order.

Divide and conquer

The second approach is to partition the list into odds and evens before sorting. The easiest way to select a subset of a list is to use grep. We already know how to determine odd and even: n&1 will give us either a 0 or a 1, which are conviently equivalent to false and true.

my @odd = grep { $_ & 1 } @list; 
my @even = grep { $_ & 1) == 0 } @list;

It would be fun (and this is Fun Sort, after all) to do it with one pass. We can do that by using the 0 or 1 as index to an array of lists.

my @group = ([], []);  # [0] is evens, [1] is odds
push @{$group[$_&1]}, $_ for @list; 

It would be programmer-efficient, but somewhat less fun, to use a library module that already does list partitioning. That would be the part function from List::MoreUtils. The whole List::MoreUtils module is pretty fun, actually, full of useful functions that you didn't know you needed and won't have to write yourself.

sub funSort_partB(@list)
{
    use List::MoreUtils qw/part/;
    my @sorted;
    for my $sub ( part { $_ % 2} @list )
    {
        next unless defined $sub;
        push @sorted, sort { $a <=> $b } $sub->@*;
    }
    return \@sorted;
}

part will return a list of array references. If there are no even numbers or no odd numbers, one of the partitions may be empty, in which case part has an undef element, not an empty list. Hence, the next statement. If we pass that point, then $sub is an array reference, and $sub->@* is the de-reference; that is, the list of array elements. The result of the sort gets pushed to the end of the @sorted array -- recall that multiple elements can be pushed at once.

Conquer and divide

The final approach is to do a simple numeric sort, then partition the resulting sorted list. We've already lined up all the pieces we need from the first two approaches. We can use List::Util::part after the sort, and then the only missing piece is how to flatten lists of lists into one.
One way is by de-referencing the lists and using a loop to push the elements, as we did in the function above. The other, less fun, way is to reach for another library function. How about List::Flatten::flat?

sub funSort_part(@list)
{
    use List::MoreUtils qw/part/;
    use List::Flatten qw/flat/;

    return [ grep { defined } flat part { $_ % 2 } sort { $a <=> $b} @list ];
}

Perl is still fun, though. Here we've chained several array operations to avoid having to write loops. From right to left,

1. sort is a simple numeric sort
2. part separates into even and odd
3. flat joins the array references into one list
4. grep takes care of the problem that one of the sub-lists might be empty
5. wrapping the whole thing in square brackets creates a new array reference that can be returned

The complete code solution is on Github

Task 2: Shortest route

Our problem states:

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.

and it offers as an example:

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

Because of the way the problem is presented, I thought first of intersection of sets, but that's a red herring. If we put all the nodes together and draw edges between them, we'll see that the routes are just subsets of a bigger graph.

And if that's what we have, then this is a classic computer science algorithm problem: shortest path in an undirected graph. There's an intuitive solution for it, breadth-first search. It involves going one step out from the start node to all of its neighbers, and then going one step to each of their neighbors, and so on until the destination node is found (or not).

It's not a terribly hard algorithm, but not one I can trivially construct from scratch. Although Google is your friend here, I took the opportunity for nostalgia. There's still a copy of Sedgewick's "Algorithms" on my shelf. It's the 2nd edition from 1988, helpfully presenting the algorithms in Pascal, which was probably a good idea at the time.

procedure listbfs;
  var id, k: integer;
    val: array[1..maxV] of integer;
  procedure visit(k: integer);
    var t: link;
    begin
    put(k);
    repeat
      k := get;
      id := id + 1;
      val[k] := id;
      t := adj[k];
      while t <> z do
        begin
        if val[t^.v] = 0 then
          begin put(t^.v); val[t^.v] := -1; end;
        t := t^.next;
        end
      until queueempty;
      end;
  begin
    id := 0; queueinitialize;
    for k := 1 to V do val[k] := 0;
    for k := 1 to V do
      if val[k] = 0 then visit(k)
    end;

Well, that was amusing, but we have Perl.

The trick to graph algorithms is finding the right data structure to represent the graph. I decided to make a little Moo class for the graph, where the graph is represented as a collection of nodes in a hash. Each node has an associated list (array reference) of nearest neighbors. The graph is built up from methods that add nodes and edges.

    sub addNode($self, $n)
    {
        $self->{adj}{$n} //= [];
    }

    sub addEdge($self, $v1, $v2)
    {
        $self->addNode($v1);
        my $neighbors = $self->{adj}{$v1};
        push @{$neighbors}, $v2 unless grep { $_ == $v2 } $neighbors->@*;
        return $self;
    }

For the graph from the example, we're going to end up with an adjacency list that looks like:

adj = { 1 => [2],
        2 => [1,3],
        3 => [2,8],
        4 => [5],
        5 => [4,6],
        6 => [5],
        7 => [8],
        8 => [3,7,9],
        9 => [8], };

Iterating over the routes in the input will build up the graph using the object methods:

my $g = Graph->new;
for my $route ( $segments->@* )
{
    my $v1 = shift @$route;
    $g->addNode($v1);
    while ( @$route )
    {
        my $v2 = shift @$route;
        $g->addEdge($v1,$v2)->addEdge($v2,$v1);
        $v1 = $v2;
    }
}

To move across pairs of nodes in a route, I used an idiom to shift the the first element ($v1), and then continue to shift a second element ($v2) until the array is used up. There's a function slide in the List::MoreUtils module that embodies this algorithm that I could have used.

Notice also that the addEdge method returns a reference to the object, which allows me to chain method calls. Since the graph is bi-directional, I want to add an edge from $v1 to $v2 and vice versa. The chaining idiom makes it (in my opinion) readable to express that.

Once the nodes and edges are available in the graph, we can use the breadth-first search algorithm as the function to find a route. The algorithm uses an array as a queue (which Perl makes easy to do with its push and shift functions). As each node is encountered, its neighbors are put on the queue for checking later. Once we stumble over the destination node, we're done.

The main complication in the breadth-first algorithm is that we don't want to get stuck in a loop, so we keep a list of nodes that have already been processed. I use a hash, %seen, for this purpose because it has fast look-up for node names.

sub route($self, $source, $destination)
{
    return [ $source] if ( $source == $destination );

    # Breadth-first search
    my @path;
    my @queue = ( $source );
    my %seen;

    while ( @queue )
    {
        my $node = shift @queue;
        push @path, $node;

        my $neighbors = $self->{adj}{$node};
        for my $neighbor ( grep { !$seen{$_} } $neighbors->@* )
        {
            if ( $neighbor == $destination )
            {
                return [ @path, $neighbor ];
            }
            push @queue, $neighbor;
        }

        $seen{$node} = true;
    }
    return [];
}

I return an empty list to indicate "not found". The challenge asks us to report -1 for that, but that's easily done in the calling code. Consistently returning a list simplifies the testing code. The complete code solution is on Github