Perl Weekly Challenge 63: Last Word and Rotate String

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (June 7, 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: Last Word Matching a Regex

Define sub last_word($string, $regexp) that returns the last word matching $regexp found in the given string, or undef if the string does not contain a word matching $regexp.

For this challenge, a “word” is defined as any character sequence consisting of non-whitespace characters (\S) only. That means punctuation and other symbols are part of the word.

The $regexp is a regular expression. Take care that the regexp can only match individual words! See the Examples for one way this can break if you are not careful.

Examples:

last_word('  hello world',                qr/[ea]l/);      # 'hello'
last_word("Don't match too much, Chet!",  qr/ch.t/i);      # 'Chet!'
last_word("spaces in regexp won't match", qr/in re/);      #  undef
last_word( join(' ', 1..1e6),             qr/^(3.*?){3}/); # '399933'

The only very slight difficulty here is that regular expressions or regexes fundamentally explore strings from left to right. It is possible to use the g modifier (in Perl) or :g adverb (in Raku) to get all the matches and then keep only the last one, but I’ve decided to use another approach which is simpler and also likely to be more efficient in most cases (when it matters): split the string into words, reverse the list and find the first match.

I’ve decided to return “Not found”, rather than undef for two reasons: first, undef does not exist in Raku and, besides, I think that printing “Not found” looks nicer.

Last Word Matching a Regex in Raku

Raku has a built-in words method that splits a string into words (the delimiter being white space) and a reverse method to reverse the items of a list. We only need to look at each item and stop when we get the first pattern match:

use v6;

sub last-word (Str $str, $regex) {
    for $str.words.reverse -> $reversed {
        return $reversed if $reversed ~~ $regex;
    }
    return "Not found";
}

say last-word "Hello Word", rx/<[ae]>l/;
say last-word("Don't match too much, Chet!",  rx:i/ch.t/);
say last-word("spaces in regexp won't match", rx:s/in re/);
my $str = join(' ', 1..1e5);
say last-word( $str, rx/^8 ** 3/);

This produces the following output:

$ perl6 last-word.p6
Hello
Chet!
Not found
88899

Last Word Matching a Regex in Perl

Besides small syntax differences, porting the Raku program to Perl only required replacing words with split on white space:

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

sub last_word {
    my ($str, $regex) = @_;
    for my $reversed (reverse split /\s+/, $str) {
        return $reversed if $reversed =~ $regex;
    }
    return "Not found";
}

say last_word('  hello world',                qr/[ea]l/); 
say last_word("Don't match too much, Chet!",  qr/ch.t/i);
say last_word("spaces in regexp won't match", qr/in re/);
say last_word( join(' ', 1..1e6),             qr/^(3.*?){3}/);

This program displays the following output:

$ perl last-word.pl
hello
Chet!
Not found
399933

Task 2: Rotate String

Given a word made up of an arbitrary number of x and y characters, that word can be rotated as follows: For the ith rotation (starting at i = 1), i % length(word) characters are moved from the front of the string to the end. Thus, for the string xyxx, the initial (i = 1) % 4 = 1 character (x) is moved to the end, forming yxxx. On the second rotation, (i = 2) % 4 = 2 characters (yx) are moved to the end, forming xxyx, and so on. See below for a complete example.

Your task is to write a function that takes a string of xs and ys and returns the minimum non-zero number of rotations required to obtain the original string. You may show the individual rotations if you wish, but that is not required.

Example:

Input: $word = 'xyxx';

Rotation 1: you get yxxx by moving x to the end.
Rotation 2: you get xxyx by moving yx to the end.
Rotation 3: you get xxxy by moving xxy to the end.
Rotation 4: you get xxxy by moving nothing as 4 % length(xyxx) == 0.
Rotation 5: you get xxyx by moving x to the end.
Rotation 6: you get yxxx by moving xx to the end.
Rotation 7: you get xyxx by moving yxx to the end which is same as the given word.

Output: 7

Rotate String in Raku

For solving this task, I decided to write a rotate-once subroutine, taking a string and a number of characters to be shifted as arguments, to perform one individual rotation. That subroutine is only one code line, so the code could very well have been in-lined in the main loop, but the main reason for writing a separate subroutine is that it makes it possible to properly unit test it (it is just too easy to make an off-by-one error on such processing), even though I won’t show these simple tests which are not part of the task. The rotate-str subroutine simply implements an infinite loop to generate the successive rotated strings and breaks out of the loop with a return statement when the new rotated string is the same as original input string.

sub rotate-once (Str $str, Int $num) {
    $str.substr($num, $str.chars - $num) ~ $str.substr(0, $num);
}
sub rotate-str (Str $origin-str) {
    my $tmp = $origin-str;
    my $len = $origin-str.chars;
    my $i = 1;
    loop {
        $tmp = rotate-once $tmp, $i % $len;
        # say $tmp;
        return $i if $tmp eq $origin-str;
        $i++;
    }
}
for <xyxx xxyyy abcdefgh> {
    say "Got original string $_ after {rotate-str($_)} rotations.";
}

Simply uncomment the say statement in the loop to display the individual rotations (that’s quite useful to check the results).

The loop control-flow statement normally takes three statements in parentheses to implement the equivalent of a C-style for statement:

loop (my $i = 0; $i < 10; $i++) {
    say $i;
}

Using loop { ... } with no such three statements (and no parentheses) is just an idiomatic way to implement an infinite loop in Raku, just like while (1) { ... } in Perl.

The above program displays the following output:

$ perl6 rotate_str.p6
Got original string xyxx after 7 rotations.
Got original string xxyyy after 4 rotations.
Got original string abcdefgh after 15 rotations.

Note that I have duly noticed that the original task description said that the input string should be made of letters x and y. One of my test examples above uses other letters because it makes it a bit easier to check the results.

Rotate Strings in Perl

The following program is simply a port to Perl of the Raku program above:

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

sub rotate_once {
    my ($str, $num) = @_;
    substr($str, $num, length($str) - $num) . substr($str, 0, $num);
}
sub rotate_str {
    my $origin_str = shift; 
    my $tmp = $origin_str;
    my $len = length $origin_str;
    my $i = 1;
    while (1) {
        $tmp = rotate_once $tmp, $i % $len;
        return $i if $tmp eq $origin_str;
        $i++;
    }
}
for (qw<xyxx xxyyy abcdefgh>) {
    say "Got original string $_ after ", rotate_str($_), " rotations.";
}

This program displays the same output as the Raku program above:

$ perl rotate_str.pl
Got original string xyxx after 7 rotations.
Got original string xxyyy after 4 rotations.
Got original string abcdefgh after 15 rotations.

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 14, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

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.