laurent_r

These are some answers to the Week 284, Task 2, of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on September 1, 2024, at 23:59). This blog post provides some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 2: Relative Sort

You are given two list of integers, @list1 and @list2. The elements in the @list2 are distinct and also in the @list1.

Write a script to sort the elements in the @list1 such that the relative order of items in @list1 is same as in the @list2. Elements that is missing in @list2 should be placed at the end of @list1 in ascending order.

Example 1

Input: @list1 = (2, 3, 9, 3, 1, 4, 6, 7, 2, 8, 5)
       @list2 = (2, 1, 4, 3, 5, 6)
Ouput: (2, 2, 1, 4, 3, 3, 5, 6, 7, 8, 9)

Example 2

Input: @list1 = (3, 3, 4, 6, 2, 4, 2, 1, 3)
       @list2 = (1, 3, 2)
Ouput: (1, 3, 3, 3, 2, 2, 4, 4, 6)

Example 3

Input: @list1 = (3, 0, 5, 0, 2, 1, 4, 1, 1)
       @list2 = (1, 0, 3, 2)
Ouput: (1, 1, 1, 0, 0, 3, 2, 4, 5)

Relative Sort in Raku

Instead of sorting @list1 in accordance with the order of @list2, we will duplicate @list2 with each item of @list2 being repeated the number of times it occurs un @list1. At the end, we append to the resulting list the items (sorted in ascending order) of @list1 not used previously.

We first need to create an histogram of frequencies of @list1, which can be easily done with Bag, as we've done previously (for example in the lucky number task of this week's challenge. The only slight problem is that we also want to use this histogram data structure to track the items that we have already used and know which items are left. A Bag is immutable, so we will use its mutable variant, a BagHash instead. So, once we use an item, we set its frequency to 0 and the item is automatically removed from the BagHash.

Note that, although we are told that the elements of @list2 are all in @list1, we nonetheless check to avoid an exception, but don't do anything about it (we don't know what should be done) and let the program run to its end. Also note that we print out only @list2 with the results, for space reasons.

sub relative-sort (@in1, @in2) {
    my @result;
    my $to-be-sorted = @in1.BagHash;
    for @in2 -> $i {
        if $to-be-sorted{$i}:exists {
            append @result, $i xx $to-be-sorted{$i};
            $to-be-sorted{$i} = 0;
        }
    }
    append @result, (map { $_ xx $to-be-sorted{$_}}, $to-be-sorted.keys).sort;
    return "@result[]";
}

my @tests = ((2, 3, 9, 3, 1, 4, 6, 7, 2, 8, 5), (2, 1, 4, 3, 5, 6)),
            ((3, 3, 4, 6, 2, 4, 2, 1, 3), (1, 3, 2)),
            ((3, 0, 5, 0, 2, 1, 4, 1, 1), (1, 0, 3, 2));
for @tests -> @test {
    printf "%-15s => ", "@test[1]";
    say relative-sort @test[0], @test[1];
}

This program displays the following output:

$ raku ./relative-sort.raku
2 1 4 3 5 6     => 2 2 1 4 3 3 5 6 7 8 9
1 3 2           => 1 3 3 3 2 2 4 4 6
1 0 3 2         => 1 1 1 0 0 3 2 4 5

Relative Sort in Perl

This is a port to Perl of the above Raku program. Please refer to the previous section if you need explanations. Instead of a BagHash, we use in Perl a regular hash.

use strict;
use warnings;
use feature 'say';

sub relative_sort {
    my ($in1, $in2) = @_;
    my @result;
    my %unsorted;
    $unsorted{$_}++ for @$in1;
    for my $i (@$in2) {
        if (exists $unsorted{$i}) {
            push @result, ($i) x $unsorted{$i};
            $unsorted{$i} = 0;
        }
    }
    push @result, sort map { ($_) x $unsorted{$_}} 
        grep { $unsorted{$_} > 0 } keys %unsorted;
    return "@result";
}

my @tests = ( [[2, 3, 9, 3, 1, 4, 6, 7, 2, 8, 5], [2, 1, 4, 3, 5, 6]],
              [[3, 3, 4, 6, 2, 4, 2, 1, 3], [1, 3, 2]],
              [[3, 0, 5, 0, 2, 1, 4, 1, 1], [1, 0, 3, 2]] );
for my $test (@tests) {
    printf "%-15s => ", "@{$test->[1]}";
    say relative_sort @$test[0], @$test[1];
}

This program displays the following output:

$ perl  ./relative-sort.pl
2 1 4 3 5 6     => 2 2 1 4 3 3 5 6 7 8 9
1 3 2           => 1 3 3 3 2 2 4 4 6
1 0 3 2         => 1 1 1 0 0 3 2 4 5

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on September 9, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.