May 2020 Archives

Perl Weekly Challenge 62: Sort Email Addresses

These are some answers to the Week 62 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Task 1: Sort Email Addresses

Write a script that takes a list of email addresses (one per line) and sorts them first by the domain part of the email address, and then by the part to the left of the @ (known as the mailbox).

Note that the domain is case-insensitive, while the mailbox part is case sensitive. (Some email providers choose to ignore case, but that’s another matter entirely.)

If your script is invoked with arguments, it should treat them as file names and read them in order, otherwise your script should read email addresses from standard input.

Bonus

Add a -u option which only includes unique email addresses in the output, just like sort -u.

Example:

If given the following list:

name@example.org
rjt@cpan.org
Name@example.org
rjt@CPAN.org
user@alpha.example.org

Your script (without -u) would return:

user@alpha.example.org
rjt@cpan.org
rjt@CPAN.org
Name@example.org
name@example.org

With -u, the script would return:

user@alpha.example.org
rjt@CPAN.org
Name@example.org
name@example.org

Sorting Email Addresses in Raku

The first idea that came to my mind was to write the cmp-addr comparison subroutine, to be passed as a parameter to the sort built-in function, leading to something like this:

sub cmp-addr (Str $addr1, Str $addr2) {
    my ($box1, $domain1) = split /'@'/, $addr1;
    my ($box2, $domain2) = split /'@'/, $addr2;
    $domain1.uc leg $domain2.uc or $box1 leg $box2;
}
my @sorted = sort &cmp-addr, @unsorted;

This subroutine takes two email addresses as parameters, splits them into mailbox and domain components, and returns the result of the lexicographic comparison between the uppercase domains; if the domains are the same, then it returns the the result of the lexicographic comparison between the mailbox components. When the first parameter to the sort function is a subroutine taking two parameters, then sort uses that subroutine as a comparator to know which of the two parameters should come first in the sorted list.

This works fine, but when thinking about the -u option, I figured that I would need to do more or less the same thing again do remove duplicate addresses from the list. So, I wanted to see if I could try to use the same subroutine to take care of the comparison for the ordering and the duplicate removal. The great thing with Raku is that, when you’re looking for something like that, there is usually a solution. When the first parameter to the sort function is a subroutine that accepts only one argument, then sort uses that subroutine to canonicalize or normalize the parameters before performing a standard comparison (using implicitly the cmp smart comparison operator between the normalized parameters. In addition, the normalized values are cached, so that normalization occurs only once per item in the input list. In addition, the unique built-in can also use a subroutine as a parameter to perform input normalization in order to find duplicates. As a result, our normalize subroutine in the code below can be used both for sorting and for removing duplicates.

use v6;

sub normalize (Str $addr) {
    my ($box, $domain) = split /'@'/, $addr;
    $domain.uc ~ '@' ~ $box;
}
sub process-addresses( @addresses, Bool $unique) {
    @addresses = @addresses.unique(:as(&normalize)) if $unique;
    my @sorted = sort &normalize, @addresses;
    .say for @sorted;
}
multi sub MAIN (Bool :u(:$unique) = False, *@files) {
    my @addresses = @files.IO.lines;
    process-addresses @addresses, $unique;
}
multi sub MAIN (Bool :u(:$unique) = False) {
    my @addresses = $*IN.lines;
    process-addresses @addresses, $unique;
}

Using the following addresses.txt input file:

name@example.org
rjt@cpan.org
Name@example.org
rjt@CPAN.org
rjt@cpan.org
user@alpha.example.org
rjt@cpan.org

we get the following results:

$  perl6 sort_addresses.p6  addresses.txt
user@alpha.example.org
rjt@cpan.org
rjt@CPAN.org
rjt@cpan.org
rjt@cpan.org
Name@example.org
name@example.org

$  perl6 sort_addresses.p6 -u addresses.txt
user@alpha.example.org
rjt@cpan.org
Name@example.org
name@example.org

The same tests using the content of the addresses.txt input file as standard input:

$ cat addresses.txt | perl6 sort_addresses.p6
user@alpha.example.org
rjt@cpan.org
rjt@CPAN.org
rjt@cpan.org
rjt@cpan.org
Name@example.org
name@example.org

$ cat addresses.txt | perl6 sort_addresses.p6 -u
user@alpha.example.org
rjt@cpan.org
Name@example.org
name@example.org

Note that, since we’re sorting the addresses anyway, we could use the squish built-in method instead of unique. squish only removes adjacent duplicates, but is equivalent to unique with sorted input. The process-addresses subroutine would be rewritten as follows:

sub process-addresses( @addresses, Bool $unique) {
    my @sorted = sort &normalize, @addresses;
    @sorted = @sorted.squish(:as(&normalize)) if $unique;
    .say for @sorted;
}

This produces the same output as earlier. With large input, squish should presumably be faster than unique, but I haven’t bothered to run benchmarks with large input files.

Sorting Email Addresses in Perl

In Perl, the sort built-in function is slightly less expressive than in Raku, so we will use a technique known as the Schwartzian Transform to do the sort:

my @sorted = map { $_->[0] }
    sort { $a->[1] cmp $b->[1] }
    map { [$_, normalize $_] } @addresses;

This code is a data pipeline and has to be read from right to left and from bottom up. It starts with the input data at the bottom right, @addresses. The map on the bottom line transforms the array items into array references containing the original data item and a normalized version of it. Those array references are fed into the sort function on the previous line, which uses the second item (i.e. the normalized form) of each array reference as the sort key. The output of the sort is fed to another map, whose role is simply to extract back the original values from the sorted array references. It may be argued that the technique used here is a variation of the Schwartzian transform known as the Guttman Rosler transform, but it is really a kind of combination of the Schwartian and Guttman-Rosler transforms.

Removing duplicates (when unique is required) is done with a grep after the sort.

use strict;
use warnings;
use feature qw /say/;

sub normalize {
    my $addr = shift;
    my ($box, $domain) = split /@/, $addr;
    return (uc $domain . "@" . $box);
}
my ($unique, @files);
my $first_param = shift;
if ($first_param eq "-u") {
    $unique = 1;
    @files = @ARGV;
} else { 
    $unique = 0;
    @files = ($first_param, @ARGV);
}
my @addresses;
for my $file(@files) {
    open my $IN, "<", $file or die "Unable to open $file";
    push @addresses, <$IN>;
}
chomp @addresses;
my @sorted = map { $_->[0] }
    sort { $a->[1] cmp $b->[1] }
    map { [$_, normalize $_] } @addresses;
if ($unique) {
    my $last = "";
    @sorted = grep { my $bool = $last ne normalize $_; $last = normalize $_; $bool} @sorted;
}
say for @sorted;

Running this program (with the same input file as in Raku) displays the following output:

$ perl sort_addresses.pl -u addresses.txt
user@alpha.example.org
rjt@cpan.org
name@example.org

$ perl sort_addresses.pl  addresses.txt
user@alpha.example.org
rjt@cpan.org
rjt@CPAN.org
rjt@cpan.org
rjt@cpan.org
name@example.org
Name@example.org

Note that I was running late, so I don’t have time to implement a version using standard input. For the same reason, I wasn’t able to perform task 2 (N-queens).

Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, June 7, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 61: Max Subarray Product and IP Address Partition

These are some answers to the Week 61 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (May 24, 2020). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Max Sub-Array Product

Given a list of 4 or more numbers, write a script to find the contiguous sublist that has the maximum product.

Example:

Input: [ 2, 5, -1, 3 ]

Output: [ 2, 5 ] which gives maximum product 10.

Max Sub-Array Product in Raku

Let’s start with a simple loop over a list of indices, as we would do in most procedural programming languages. We loop over the existing indices of the input array, compute the product of each item with the next one, and store in the @max array the max product so far, as well as the two items that led to it:

use v6;

my @input = @*ARGS;
my @max = @input[0] * @input[1], @input[0], @input[1];
for 1..^@input.end -> $i {
    @max = @input[$i] * @input[$i+1], @input[$i], @input[$i+1]
        if @max[0] < @input[$i] * @input[$i+1];
}
say "Max product is @max[0] for values @max[1] and @max[2]";

This is an example run of this program:

$ perl6 max-product.p6 3 5 7 9 3 6 12 4
Max product is 72 for values 6 and 12

But, Raku being what it is, we can use its expressive power to design a much better (or, at least, much shorter) solution:

use v6;

say @*ARGS.rotor(2 => -1).max({$_[0] * $_[1]});

We use the rotor built-in method to generate a list of overlapping 2-item seqs. For example, with an input of 3 5 7 9, rotor(2 => -1) generates the following list: ((3 5) (5 7) (7 9)). Then we use the max built-in method to find the 2-item seq having the largest product.

These are two sample runs of this one-liner program:

$ perl6 max-product2.p6 3 5 7 9 3 6 12 4
(6 12)

$ perl6 max-product2.p6 3 5 7 9 3 6 12 4 85 3
(4 85)

Max Sub-Array Product in Perl

Perl doesn’t have the built-ins used in our second Raku solution. So we will simply port to Perl the first Raku solution:

use strict;
use warnings;
use feature qw /say/;

my @input = @ARGV;
die "please supply at least two integers" if @input < 2;
my @max = ($input[0] * $input[1], $input[0], $input[1]);
for my $i (1..$#input) {
    @max = ($input[$i] * $input[$i+1], $input[$i], $input[$i+1])
        if $max[0] < $input[$i] * $input[$i+1];
}
say "Max product is $max[0] for values $max[1] and $max[2]";

Example runs:

$ perl max-product.pl 3 5 7 9 3 6 12 4
Max product is 72 for values 6 and 12

$ perl max-product.pl 3 5 7 9 3 6 12 4 85 3
Max product is 340 for values 4 and 85

Task 2: IPv4 Address Partitions

You are given a string containing only digits (0..9). The string should have between 4 and 12 digits.

Write a script to print every possible valid IPv4 address that can be made by partitioning the input string.

For the purpose of this challenge, a valid IPv4 address consists of four “octets” i.e. A, B, C and D, separated by dots (.).

Each octet must be between 0 and 255, and must not have any leading zeroes. (e.g., 0 is OK, but 01 is not.)

Example:

Input: 25525511135,

Output:

255.255.11.135
255.255.111.35

IPv4 Address Partitions in Raku

Here again, we could build a procedural solution as we would probably do in most programming languages (and as we will do in Perl below).

But we can again use Raku’s expressive power to design a simpler solution. In this case, we’ll use regexes.

Using the :exhaustive (or :ex) adverb makes it possible to generate all possible matches of a pattern.

To start with, we will define a regex subpattern to match an octet. I would normally write a subpattern looking like this:

my $octet = rx{(\d ** 1..3) <?{0 <= $0 <= 255}>};

This basically says Raku to match a number of 1 to 3 digits comprised between 0 and 255. The <?{0 <= $0 <= 255}> is a code assertion within the pattern to limit the value of an octet to the 0..255 range. But, for some reason, the task specification says that an octet should not start with 0 (unless the octet is 0 itself). So, our subpattern will be a little bit more complicated (see below). In the rest of the code, we use the :ex adverb to generate all partitions matching four times the $octet subppattern:

use v6;

my $octet = rx {( || 0
                  || <[ 1..9 ]> \d ** 0..2 
                ) <?{0 <= $0 <= 255}>
               };
sub MAIN (Int $in = 122202128) {
    for $in ~~ m:ex/^ (<$octet>) ** 4 $/ -> $match {
        say join ".", $match[0];
    }
}

These are a few sample runs:

$ perl6 ip.p6
122.202.12.8
122.202.1.28
122.20.212.8
122.20.21.28
122.20.2.128
12.220.212.8
12.220.21.28
12.220.2.128
12.2.202.128
1.22.202.128

$ perl6 ip.p6 2765645
27.65.64.5
27.65.6.45
27.6.56.45
2.76.56.45

$ perl6 ip.p6 12345678
123.45.67.8
123.45.6.78
123.4.56.78
12.34.56.78
1.234.56.78

$ perl6 ip.p6 122022128
122.0.221.28
122.0.22.128
12.202.212.8
12.202.21.28
12.202.2.128
12.20.221.28
12.20.22.128
1.220.221.28
1.220.22.128

IPv4 Address Partitions in Perl

We use the recursive partition subroutine to generate all possible partitions of the input numeric string that match the octet specification:

use strict;
use warnings;
use feature qw /say/;

sub partition {
    my ($out, @in) = @_;
    for my $nb_digits (0..2) {
        return if $nb_digits > $#in;
        my $num = join "", @in[0..$nb_digits];
        return if $num > 255;
        return if $num =~ /^0\d/;
        my @left_digits = @in[$nb_digits+1..$#in];
        my $new_out = $out eq "" ? $num : ($out . ".$num");
        if (@left_digits == 0) {
            say $new_out if $new_out =~ /^\d+\.\d+\.\d+\.\d+$/;
            return;
        }
        partition ($new_out, @left_digits);
    }
}

my $in = shift // 25525511135;
my @digits = split //, $in;
partition "", @digits;

Here are a few example runs of this program:

$ perl ip.pl
255.255.11.135
255.255.111.35

$ perl ip.pl 2765645
2.76.56.45
27.6.56.45
27.65.6.45
27.65.64.5

$ perl ip.pl 122202128
1.22.202.128
12.2.202.128
12.220.2.128
12.220.21.28
12.220.212.8
122.20.2.128
122.20.21.28
122.20.212.8
122.202.1.28
122.202.12.8

$ perl ip.pl 12345678
1.234.56.78
12.34.56.78
123.4.56.78
123.45.6.78
123.45.67.8

Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, May 31, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 60: Excel Columns and Find Numbers

These are some answers to the Week 60 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Please note that this blog post will be shorter than usual, since I’m a bit short of time to prepare it.

Task 1: Excel Columns

Write a script that accepts a number and returns the Excel Column Name it represents and vice-versa.

Excel columns start at A and increase lexicographically using the 26 letters of the English alphabet, A..Z. After Z, the columns pick up an extra “digit”, going from AA, AB, etc., which could (in theory) continue to an arbitrary number of digits. In practice, Excel sheets are limited to 16,384 columns.

Example:

Input Number: 28
Output: AB

Input Column Name: AD
Output: 30

Excel Columns in Raku

We first create a lazy infinite list, @cols, of Excel column names. Note that we start with an empty string to avoid an off-by-one issue (as Excel column numbers starts at 1, not 0). We then create a hash mapping column names to column numbers.

We use two multi MAIN subroutines, one to convert number to names, and one to convert names to number.

use v6;

constant \MAX = 16_384;
my @cols = '', 'A', 'B' ... *;
my %nums = map { @cols[$_] => $_}, 1..MAX;

multi sub MAIN (Int $n = 28) {
    say "Column $n = @cols[$n]";
}

multi sub MAIN (Str $col-name where * ~~ /^<[A..Z]>+$/) {
    say "Column $col-name = %nums{$col-name}";
}

These are a few sample runs:

$ perl6 excel-cols.p6
Column 28 = AB

$ perl6 excel-cols.p6 44
Column 44 = AR

$ perl6 excel-cols.p6 431
Column 431 = PO

$ perl6 excel-cols.p6 AB
Column AB = 28

$ perl6 excel-cols.p6 AR
Column AR = 44

$ perl6 excel-cols.p6 PO
Column PO = 431

Excel Columns in Perl

This is essentially a port to Perl of the Raku program. Since we cannot have lazy infinite lists in Perl, we define a MAXLET constant (equal to “XFD”, corresponding to 16384 in numeric notation). Similarly, since we cannot have multiple MAIN subroutines in Perl, we analyze whether the input value is an integer or a string of letters between A and Z to decide in which direction to perform the conversion:

use strict;
use warnings;
use feature qw /say/;
use constant MAXNUM => 16_384;
use constant MAXLET => 'XFD';

my @cols = ('', 'A'..MAXLET);
my %nums = map { $cols[$_] => $_ } 1..MAXNUM;
my $in = shift // 28;
if ($in =~ /^\d+$/) {
    say "Column $in = $cols[$in]";
} elsif ( $in =~ /^[A-Z]+$/ ) {
    say "Column $in = $nums{$in}";
} else {
    say "$in is invalid input.";
}

Example output:

$ perl excel-cols.pl AA
Column AA = 27

$ perl excel-cols.pl ZZ
Column ZZ = 702

$ perl excel-cols.pl 16000
Column 16000 = WQJ

$ perl excel-cols.pl 16384
Column 16384 = XFD

Task 2: Finding Numbers

Write a script that accepts list of positive numbers (@L) and two positive numbers $X and $Y.

The script should print all possible numbers made by concatenating the numbers from @L, whose length is exactly $X but value is less than $Y.

Example input:

@L = (0, 1, 2, 5);
$X = 2;
$Y = 21;

With this input, the output should be:

10, 11, 12, 15, 20

Finding Numbers in Raku

We use the combinations to generate digit combinations, and the permutations method on these combinations, concatenate the permutations generated into numbers and then print out numbers whose length and value match the input criteria.

sub MAIN (Int $length, Int $max-val, Str $list) {
    my @L = | $list.split(" ") xx $length;
    my @out;
    for @L.combinations: 1..$length -> $seq {
        for $seq.permutations>>.join('') -> $num {
            push @out, +$num if $num < $max-val 
                and $num.Int.chars == $length;
        }    
    }
    .say for @out.sort.squish;
}

Sample runs:

$ perl6 find-numbers.p6 2 50 "3 4 5"
33
34
35
43
44
45


$ perl6 find-numbers.p6 2 21 "0 1 2 5"
10
11
12
15
20


$ perl6 find-numbers.p6 3 145 "0 1 2 5 12 31"
100
101
102
105
110
111
112
115
120
121
122
125
131

Finding Numbers in Perl

Here, we write a recursive permute subroutine to generate all possible numbers from the input list, and then print out the numbers whose length and value match the input criteria.

use strict;
use warnings;
use feature qw /say/;

my $length = shift;
my $max_val = shift;
my @L = @ARGV;

sub permute {
    my ($seed, @list) = @_;
    return if length $seed > $length;
    for my $val (@list) {
        next if $seed eq "" and $val == 0;
        my $new_seed = 0 + ($seed . $val);
        say $new_seed if length $new_seed == $length 
            and $new_seed < $max_val;
        permute($new_seed, @list);
    }
}

permute "", @L;

Sample runs:

$ perl find-numbers.pl 2 41 3 1 2 5
33
31
32
35
13
11
12
15
23
21
22
25

$ perl find-numbers.pl 2 21 0 1 2 5
10
11
12
15
20

Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, May 24, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 59: Linked Lists and Bit Sums

These are some answers to the Week 59 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few hours. This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Linked List Partition

You are given a linked list and a value k. Write a script to partition the linked list such that all nodes less than k come before nodes greater than or equal to k. Make sure you preserve the original relative order of the nodes in each of the two partitions.

For example:

Linked List: 1 → 4 → 3 → 2 → 5 → 2

k = 3

Expected Output: 1 → 2 → 2 → 4 → 3 → 5.

A linked list is a linear collection of data items, which are often called nodes, in which each data item holds a value (or several values) and a link to the next item of the collection. Each node points to the next. It is a data structure consisting of a collection of nodes which together represent a sequence. Usually, each node contains some data and a reference (in other words, a link) to the next node in the sequence. This structure is very useful in low-level languages such as C, since it allows for easy insertion or removal of elements at any position in the sequence.

Now, both Perl and Raku make it possible to easily add or remove data items at any position in an array. Therefore, I do not see any reason to implement a low-level linked list in these languages. In the course of the two last Perl Weekly Challenges, I showed how a binary tree could be implemented as a simple flat array with an implicit data structure. It would be a regression to bend over backward and implement a linked-list in Perl or Raku. And it would be a case of over-engineering. In brief, I’ll use simple arrays for this task.

However, for the sake of completeness, I’ll show a brief implementation of actual linked lists in Perl. But I do not recommend using it.

Linked List Partition in Raku

The partition subroutine simply feeds two arrays with values less than k or values greater than or equal to k, and returns merged data in the proper order.

use v6;

sub partition ($k, @list) {
    my @before = grep {$_ < $k}, @list;
    my @after = grep {$_ >= $k}, @list;
    return |@before, |@after;
}

sub MAIN ($k, Str $list-str = "1 4 3 2 5 2") {
    my @list = $list-str.comb(/\d+/);
    my @result = partition $k, @list;
    say @result.join(" → ");
}

This displays the following output:

$ perl6 linked1.p6 3
1 → 2 → 2 → 4 → 3 → 5

$ perl6 linked1.p6  4 "3 5 4 5 8 7 9 2"
3 → 2 → 5 → 4 → 5 → 8 → 7 → 9

However, it can be made simpler and possibly slightly more efficient using the classify built-in function of Raku as shown in this very simple example:

use v6;

my $k = 3;
my @vals = <1 4 3 2 5 2>;
my %out = classify { $_ < $k ?? 'before' !! 'after'}, @vals;
say join " → ", |%out<before>, |%out<after>;

This duly prints the correct result:

$ perl6 linked2.p6
1 → 2 → 2 → 4 → 3 → 5

We could even reduce it to a Raku one-liner:

$ perl6 -e 'say join " ", (classify { $_ < 3 ?? "b" !! "a" }, <1 4 3 2 5 2>)<b a>'
1 2 2 4 3 5

Similarly, we could use the categorize method and an method-invocation syntax:

$ perl6 -e '<1 4 3 2 5 2>.categorize({ $_ < 3 ?? "b" !! "a" })<b a>.join(" ").say'
1 2 2 4 3 5

Linked List Partition in Perl

This is a Perl port of the first Raku solution above, with a partition subroutine to split the input into two arrays:

use strict;
use warnings;
use feature "say";

sub partition {
    my $k = shift;
    my @before = grep {$_ < $k} @_;
    my @after = grep {$_ >= $k} @_;
    return @before, @after;
}

my $k = shift;
my $list_str = shift // "1 4 3 2 5 2";
my @list = $list_str =~ /\d+/g;
my @result = partition $k, @list;
say join " → ", @result;

Two execution examples:

$ perl linked1.pl 3
1 → 2 → 2 → 4 → 3 → 5

$ perl linked1.pl 3 "1 4 3 4 5 6 7 2 1"
1 → 2 → 1 → 4 → 3 → 4 → 5 → 6 → 7

An Actual Linked List

As I said before, I really do not recommend the implementation of an actual linked list to solve this problem.

But, just in case you think that I balk at doing it because I don’t know how to do it, or more generally in the event that you would like to see how this could be implemented, this is one possible way to do it, using nested hashes:

use strict;
use warnings;
use feature qw/say/;
use Data::Dumper;

sub create_linked_list {
    my $input = shift;
    my $L;
    for my $val (reverse split / /, $input) {
        my $pt = { value => $val, next => $L };
        $L = $pt;
    }
    return $L;
}        

my $k = shift;
my $list_str = shift // "1 4 3 2 5 2";
my $list = create_linked_list $list_str; 
# say Dumper $list; 
my (@before, @after);
while (1) {
    last unless defined $list->{value};
    my $temp = $list->{value};
    if ($temp < $k) {
        push @before, $temp;
    } else {
        push @after, $temp;
    }
    $list = $list->{next}
}
say join " → ", @before, @after;

And this is a sample run:

$ perl  linked2.pl 3
1 → 2 → 2 → 4 → 3 → 5

But again, creating an actual linked list for the problem is, in my humble view, technological overkill.

Task 2: Bit Sum

Helper Function: for this task, you will most likely need a function f(a,b) which returns the count of different bits of binary representation of a and b.

For example, f(1,3) = 1, since:

Binary representation of 1 = 01

Binary representation of 3 = 11

There is only 1 different bit. Therefore the subroutine should return 1. Note that if one number is longer than the other in binary, the most significant bits of the smaller number are padded (i.e., they are assumed to be zeroes).

Script Output: your script should accept n positive numbers. Your script should sum the result of f(a,b) for every pair of numbers given.

For example, given 2, 3, 4, the output would be 6, since f(2,3) + f(2,4) + f(3,4) = 1 + 2 + 3 = 6

Bit Sum in Raku

In the compare subroutine, we just produce a binary string (eight digits) for each input number, split the binary string into arrays, loop through both arrays at the same time to compare the individual bits. And we use the combinations built-in method to build every pair of numbers:

use v6;

sub compare (UInt $m, UInt $n) {
    my @a = $m.fmt('%08b').comb;
    my @b = $n.fmt('%08b').comb;
    my $cnt = 0;
    for 0..7 -> $i {
        $cnt++ if @a[$i] != @b[$i];
    }
    return $cnt;
}
my $diff = 0;
for @*ARGS.combinations(2) -> $seq {
    $diff += compare +$seq[0], +$seq[1];
}

say $diff;

This program displays the following output:

$ perl6 bit_sum.p6 2 3 4
6
$ perl6 bit_sum.p6 32 64 137
10

Using the Raku built-in Z or zip operator can make the compare subroutine more compact:

sub compare (UInt $m, UInt $n) {
    my $cnt = 0;
    for $m.fmt('%08b').comb Z $n.fmt('%08b').comb -> [$l, $r] {
        $cnt++ if $l != $r;
    }
    return $cnt;
}

Bit Sum in Perl

This is a port to Perl of the first Raku solution above, with a compare subroutine to find out the number of different bits between two numbers. Since Perl doesn’t have a built-in combinations function, we just use two nested for loops to generate every pair of numbers:

use strict;
use warnings;
use feature "say";

sub compare {
    my ($m, $n) = @_;
    my @a = split //, sprintf "%08b", $m;
    my @b = split //, sprintf "%08b", $n;
    my $cnt = 0;
    for my $i (0..7) {
        $cnt++ if $a[$i] != $b[$i];
    }
    return $cnt;
}
my $diff = 0;
my @nums = @ARGV;
for my $i (0..$#nums) {
    for my $j (($i+1) .. $#nums) {
        $diff += compare $nums[$i], $nums[$j];
    }
}
say $diff;

Sample output:

$ perl bit_sum.pl 2 3 4
6

$ perl bit_sum.pl 32 64 137
10

Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, May 17, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

# Perl Weekly Challenge 58: Compare Versions and Ordered Lineup

These are some answers to the Week 58 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a couple of days (May 3, 2020). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Compare Versions

Compare two given version number strings v1 and v2 such that:

- If v1 > v2 return 1 - If v1 < v2 return -1 - Otherwise, return 0

The version numbers are non-empty strings containing only digits, and the dot (“.”) and underscore (“_”) characters. (“_” denotes an alpha/development version, and has a lower precedence than a dot, “.”). Here are some examples:

   v1   v2    Result
------ ------ ------
  0.1 < 1.1     -1
  2.0 > 1.2      1
  1.2 < 1.2_5   -1
1.2.1 > 1.2_1    1
1.2.1 = 1.2.1    0

Version numbers may also contain leading zeros. You may handle these how you wish, as long as it’s consistent.

Compare Versions in Perl

Perl has two binary data comparison operators, cmp and <=>, which do exactly what is required. For example, cmp returns -1, 0, or 1 depending on whether the left argument is stringwise less than, equal to, or greater than the right argument. Similarly, <=> returns -1, 0, or 1 depending on whether the left argument is numerically less than, equal to, or greater than the right. In other words, they do exactly what we want, except of course that we have to deal with version number strings.

In my solution, the idea is to split the version string and sort the resulting arrays in such a way that if the major (first) version number makes the difference, then we are done; if not, then we compare the second version number and rank the versions accordingly; if not, we compare the third version number. We assume that versions always have at most three digits. We also assume that version “2.1” can be converted internally into “2.1.0” without any change in the ranking order.

With these assumptions, we can use the following program:

use strict;
use warnings;
use feature "say";
use Test::More tests => 5;

sub cmp_versions {
    my ($v1, $v2) = @_;
    s/_/.00/g for ($v1, $v2);
    my @a1 = split /[._]/, $v1;
    my @a2 = split /[._]/, $v2;
    $a1[2] = 0 unless defined $a1[2];
    $a2[2] = 0 unless defined $a2[2];
    $a1[0] <=> $a2[0] || $a1[1] cmp $a2[1] || $a1[2] cmp $a2[2];
}

is cmp_versions('0.1', '1.1'), -1, "Two-part version numbers";
is cmp_versions('2.0', '1.2'), 1, "Two-part version numbers";
is cmp_versions('1.2', '1.2.5'), -1, "Two-part and three-part version numbers";
is cmp_versions('1.2.1', '1.2_1'), 1, "With underscore";
is cmp_versions('1.2.1', '1.2.1'), 0, "Three-part version numbers";

This program returns correct results for the five test cases:

$ perl cmp_versions.pl
1..5
ok 1 - Two-part version numbers
ok 2 - Two-part version numbers
ok 3 - Two-part and three-part version numbers
ok 4 - With underscore
ok 5 - Three-part version numbers

Compare Versions in Raku

Raku has a built-in Version class and type. In principle, we could just declare the version number strings as Version objects and use the cmp operators on them. But that wouldn’t work with version numbers with an underscore in it specified in the task description, such as 1.2_1, as the Raku Version class doesn’t use underscores as separators. We could probably subclass the Version class, but that’s a bit too much work in my view for the scope of this task.

We can use the same idea as in Perl, except that in Raku, the cmp and <=> operators do not return -1, 0 or 1, but the values of the less, same or more objects. At the same time, less, same or more are just enum values for -1, 0 or 1, as shown in this definition of Order values:

enum Order (:Less(-1), :Same(0), :More(1));

In brief, compared to the Perl solution, we need to convert the Order values back to their numerical equivalent. This is our solution:

use v6
use Test;
plan 5;

sub cmp-versions ($v1 is copy, $v2 is copy) {
    constant %order = reverse Order.enums;
    s:g/_/.00/ for $v1, $v2;
    my @a1 = split /<[._]>/, $v1;
    my @a2 = split /<[._]>/, $v2;
    $_[2] = 0 unless defined $_[2] for @a1, @a2;
    return %order{@a1[0] <=> @a2[0] || @a1[1] <=> @a2[1] 
        || @a1[2] cmp @a2[2]};
}

is cmp-versions('0.1', '1.1'), -1, "Two-part version numbers";
is cmp-versions('2.0', '1.2'), 1, "Two-part version numbers";
is cmp-versions('1.2', '1.2.5'), -1, "Two-part and three-part version numbers";
is cmp-versions('1.2.1', '1.2_1'), 1, "With underscore";
is cmp-versions('1.2.1', '1.2.1'), 0, "Three-part version numbers";

The result is satisfactory:

$ perl6 cmp_versions.p6
1..5
ok 1 - Two-part version numbers
ok 2 - Two-part version numbers
ok 3 - Two-part and three-part version numbers
ok 4 - With underscore
ok 5 - Three-part version numbers

Task 2: Ordered Lineup

Write a script to arrange people in a lineup according to how many taller people are in front of each person in line. You are given two arrays. @H is a list of unique heights, in any order. @T is a list of how many taller people are to be put in front of the corresponding person in @H. The output is the final ordering of people’s heights, or an error if there is no solution.

Here is a small example:

@H = (2, 6, 4, 5, 1, 3) # Heights
@T = (1, 0, 2, 0, 1, 2) # Number of taller people in front

The ordering of both arrays lines up, so H[i] and T[i] refer to the same person. For example, there are 2 taller people in front of the person with height 4, and there is 1 person in front of the person with height 1.

Here is a diagram of the input arrays @H and @T:

orderedline1.svg

Finally, here is one possible solution that satisfies @H and @T:

orderedline2.svg

As per the last diagram, your script would then output the ordering (5, 1, 2, 6, 3, 4) in this case. (The leftmost element is the “front” of the array.)

Here’s a 64-person example, with answer provided:

# Heights
@H = (27, 21, 37,  4, 19, 52, 23, 64,  1,  7, 51, 17, 24, 50,  3,  2,
      34, 40, 47, 20,  8, 56, 14, 16, 42, 38, 62, 53, 31, 41, 55, 59,
      48, 12, 32, 61,  9, 60, 46, 26, 58, 25, 15, 36, 11, 44, 63, 28,
       5, 54, 10, 49, 57, 30, 29, 22, 35, 39, 45, 43, 18,  6, 13, 33);

# Number taller people in front
@T = ( 6, 41,  1, 49, 38, 12,  1,  0, 58, 47,  4, 17, 26,  1, 61, 12,
      29,  3,  4, 11, 45,  1, 32,  5,  9, 19,  1,  4, 28, 12,  2,  2,
      13, 18, 19,  3,  4,  1, 10, 16,  4,  3, 29,  5, 49,  1,  1, 24,
       2,  1, 38,  7,  7, 14, 35, 25,  0,  5,  4, 19, 10, 13,  4, 12);

# Expected answer
@A = (35, 23,  5, 64, 37,  9, 13, 25, 16, 44, 50, 40,  2, 27, 36,  6,
      18, 54, 20, 39, 56, 45, 12, 47, 17, 33, 55, 30, 26, 51, 42, 53,
      49, 41, 32, 15, 22, 60, 14, 46, 24, 59, 10, 28, 62, 38, 58, 63,
       8, 48,  4,  7, 31, 19, 61, 43, 57, 11,  1, 34, 21, 52, 29,  3);

You’re free to come up with your own inputs. Here is a 1000-person list, if you like!

At first, it took me a while to really understand the task. Once I understood the requirement, my first reaction was that this was going to be a quite complicated problem, with a large brute force program and a lot of backtracking.

Designing the Algorithm by Hand

To get a better idea of the task, I settled to solve the small example by hand. I found out relatively quickly that the solution can be constructed iteratively quite easily.

We have this:

@H = (2, 6, 4, 5, 1, 3) # Heights
@T = (1, 0, 2, 0, 1, 2) # Number of taller people in front

Let’s pick up the smallest height, 1. We know that there is one taller person before and, since it is the smallest one, there cannot be a smaller before. So the person with heigth 1 can only be in the second position (with index 1 in an array). So our resulting array would be, at this point:

(undef, 1)

Next, we take the second smallest, 2, which also has one taller person before. The starting idea would be to put that person in the second position, but it is already occupied by 1. We can just put that person in the next free slot, the third position. There will be a taller item in the first position and there is also a smaller item, 1, before it. So, it’s fine for now:

(undef, 1, 2)

The next smallest person is 3, and has two taller ones before. We can initially try to put in in the third position, but it’s occupied by the 2. If we try to put it in the next position (the fourth one), it would still not work, because there would be only one slot available for a taller person (the first version of the program I wrote had this mistake, because I made it too quickly). But we can place this person in the fifth position, so that we have two slots available for taller persons, and we know there cannot be any other smaller person, since all smaller persons have already been placed. So, for now, we have:

(undef, 1, 2, undef, 3)

Using the same reasoning iteratively, we can place each person so:

(undef, 1, 2, undef, 3, 4)
(5, 1, 2, undef, 3, 4)
(5, 1, 2, 6, 3, 4)

It clearly appears that there is only one solution, since each time through the process there was only one way to place a person. Assuming all heights are unique, we can conclude that for any such problem, there can be only one or zero solution.

Ordered Lineup in Perl

Once we have the algorithm, implementing it is fairly easy. The first thing we want to do is to make the link between the height and the number of taller people before in the line more robust than two parallel arrays. This is what we do with the %mapping hash. Then we pick each height in ascending order and place it in the @result array in accordance with the rules described above. At the end of the process, each slot of the array should be populated if there was a solution to the problem. If the problem had no solution, then some of the values in the array should be undefined. So we can just check that: if all values are defined, we just display the array; if there is one or more undefined values, then we print that the problem has no solution.

use strict;
use warnings;
use feature qw /say/;

# Heights
my @H = qw/27 21 37 4 19 52 23 64 1 7 51 17 24 50 3 2
        34 40 47 20 8 56 14 16 42 38 62 53 31 41 55 59
        48 12 32 61 9 60 46 26 58 25 15 36 11 44 63 28
        5 54 10 49 57 30 29 22 35 39 45 43 18 6 13 33/;

# Number taller people in front
my @T = qw/6 41 1 49 38 12 1 0 58 47 4 17 26 1 61 12
        29 3 4 11 45 1 32 5 9 19 1 4 28 12 2 2
        13 18 19 3 4 1 10 16 4 3 29 5 49 1 1 24
        2 1 38 7 7 14 35 25 0 5 4 19 10 13 4 12/;

# mapping sizes to number of taller people before
my %mapping;
@mapping{@H} = @T;

my @result;
for my $height (sort { $a <=> $b } @H) {
    my $rank = $mapping{$height};
    # Looking for the right slot: we start with the
    # number of taller people, and add 1 for each 
    # defined value before the place where we will 
    # end up placing the current item
    my $i = 0;
    while ($i <= $rank) {
        $rank++ if defined $result[$i++];
    }
    $result[$rank] = $height;
}
if (0 == grep { not defined $_ } @result) {
    say "@result";
} else { 
    say "No solution!";
}

This produces the following output with the above input values:

$ perl ordered_line.pl
35 23 5 64 37 9 13 25 16 44 50 40 2 27 36 6 18 54 20 39 56 45 12 47 17 33 55 30 26 51 42 53 49 41 32 15 22 60 14 46 24 59 10 28 62 38 58 63 8 48 4 7 31 19 61 43 57 11 1 34 21 52 29 3

Changing some values to make the problem unsolvable:

$ perl ordered_line.pl
No solution

Ordered Lineup in Raku

We essentially port the Perl program to Raku:

use v6;

# Heights
my @H = < 27 21 37 4 19 52 23 64 1 7 51 17 24 50 3 2
        34 40 47 20 8 56 14 16 42 38 62 53 31 41 55 59
        48 12 32 61 9 60 46 26 58 25 15 36 11 44 63 28
        5 54 10 49 57 30 29 22 35 39 45 43 18 6 13 33 >;

# Number taller people in front
my @T = < 6 41 1 49 38 12 1 0 58 47 4 17 26 1 61 12
        29 3 4 11 45 1 32 5 9 19 1 4 28 12 2 2
        13 18 19 3 4 1 10 16 4 3 29 5 49 1 1 24
        2 1 38 7 7 14 35 25 0 5 4 19 10 13 4 12 >;

# mapping sizes to number of taller people before
my %mapping;
%mapping{@H} = @T;

my @result;
for @H.sort -> $height {
    my $rank = %mapping{$height};
    my $i = 0;
    $rank++ if defined @result[$i++] while $i <= $rank;
    @result[$rank] = $height;
}
say 0 == (grep { ! defined $_ }, @result).elems ?? "@result[]" !! "No solution!";

We obtain the following output:

$ perl6 ordered_line.p6
35 23 5 64 37 9 13 25 16 44 50 40 2 27 36 6 18 54 20 39 56 45 12 47 17 33 55 30 26 51 42 53 49 41 32 15 22 60 14 46 24 59 10 28 62 38 58 63 8 48 4 7 31 19 61 43 57 11 1 34 21 52 29 3

Wrapping up

The next week Perl Weekly Challenge is due to 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 Sunday, May 10, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

About laurent_r

user-pic I am the author of the "Think Perl 6" book (O'Reilly, 2017) and I blog about the Perl 5 and Raku programming languages.