These are some answers to the Week 209 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 March 26, 2023 at 23:59). 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: Special Bit Characters

You are given an array of binary bits that ends with 0.

Valid sequences in the bit string are:

[0] -decodes-to-> "a"
[1, 0] -> "b"
[1, 1] -> "c"

Write a script to print 1 if the last character is an “a” otherwise print 0.

Example 1:

Input: @bits = (1, 0, 0)
Output: 1

The given array bits can be decoded as 2-bits character (10) followed by 1-bit character (0).

Example 2:

Input: @bits = (1, 1, 1, 0)
Output: 0

Possible decode can be 2-bits character (11) followed by 2-bits character (10) i.e. the last character is not 1-bit character.

This is an example of variable-length code. In order to decode such a bit string, we need to start from the beginning of the string. If the string starts with 0, then we have an "a" and can continue decoding with the next bit. If the string starts with 1, then we need to check the next digit, to figure out whether the first letter is a "b or a "c", and we can continue decoding with the third bit. And so on. So, for example, if we have the following string:

0110100100111011100

We will effectively split it as follows:

0 11 0 10 0 10 0 11 10 11 10 0,

yielding the following decoded string: "acababacbcba."

It is easy to see that such an encoding is totally unambiguous: at any point in the process, there can be only one decoded letter.

But if we pick one bit somewhere in the middle of the bit string, we can't know how to proceed. If it is a 0, this can be an "a", or the second bit of a "b". Similarly, if it is a 1, then it can be the first bit of a "b", or the first or the second bit of a "c". So, we can be sure to always unambiguously decode the string only if we start from the beginning. There are cases, however, where it is possible to decode part of the string starting from somewhere in the middle. For example, if we find two consecutive 0, we know that the second one can only be an "a" and proceed from there. We don't need to proceed from the beginning to find that the last letter in the above bit string is an "a". But, since we cannot be sure to meet such a situation, the best is to start from the beginning as explained above. For much longer strings, looking for the last occurrence of a "00" pattern, and proceed from the second 0 (an "a"), may be an interesting performance improvement, since we're really interested in finding out whether the final 0 is an "a" or the second bit of a "b". With the small examples at hand, this optimization would be useless.

Special Bit Characters in Raku

The program goes through the bit string and consume either one or two bits, depending on whether the current digit is a 0 or a 1. If the last bit (necessarily a 0) is the start of a group, then it is an "a". Otherwise, it is the second bit of a "10" group (i.e. of a "b"). Note that a loop statement alone, without three statements in parentheses, is just an infinite loop, from which we exit with either of the return statements.

sub ends-with-a (@in) {
    my $i = 0;
    my $end = @in.end;
    loop {
        return 1 if $i == $end;
        $i += @in[$i] == 0 ?? 1 !! 2;
        return 0 if $i > $end;
    }
}

for <1 0 0>, <1 1 1 0>, <0 0 0 1 0>, <1 1 0> -> @test {
    say (~ @test).fmt("%-12s => "), ends-with-a @test;
}

This program displays the following output:

$ raku ./main.raku
1 0 0        => 1
1 1 1 0      => 0
0 0 0 1 0    => 0
1 1 0        => 1

Special Bit Characters in Perl

This is a port to Perl of the above Raku program. Please refer to the previous sections if you need additional explanations.

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

sub ends_with_a {
    my $i = 0;
    my $end = $#_;
    while (1) {
        return 1 if $i == $end;
        $i += $_[$i] == 0 ? 1 : 2;
        return 0 if $i > $end;
    }
}

for my $test ([<1 0 0>], [<1 1 1 0>], 
    [<0 0 0 1 0>], [<1 1 0>]) {
    printf "%-12s => %d\n", "@$test", ends_with_a @$test;
}

This program displays the following output:

$ perl ./special-bit-characters.pl
1 0 0        => 1
1 1 1 0      => 0
0 0 0 1 0    => 0
1 1 0        => 1

Task 2: Merge Account

You are given an array of accounts, i.e. name with list of email addresses.

Write a script to merge the accounts where possible.

Example 1:

Input: 
    @accounts = [ ["A", "a1@a.com", "a2@a.com"],
                  ["B", "b1@b.com"],
                  ["A", "a3@a.com", "a1@a.com"] ]
                ]

Output: [ ["A", "a1@a.com", "a2@a.com", "a3@a.com"],
          ["B", "b1@b.com"] ]

Example 2:

Input: 
    @accounts = [ ["A", "a1@a.com", "a2@a.com"],
                  ["B", "b1@b.com"],
                  ["A", "a3@a.com"],
                  ["B"m "b2@b.com", "b1@b.com"] ]

Output: [ ["A", "a1@a.com", "a2@a.com"],
          ["A", "a3@a.com"],
          ["B", "b1@b.com", "b2@b.com"] ]

Merge Account in Raku

We use a hash of hashes to merge items belonging to the same name and remove possible duplicates.

sub merge-account (@in) {
    my %merged;
    for @in -> @part {
        my ($key, @values) = @part;
        %merged{$key}{$_} = True for @values;
    }
    return %merged;
}

my @tests = ( <A a1@a.com a2@a.com>, 
              <B b1@b.com>,
              <A a3@a.com a1@a.com> ),
            ( <A a1@a.com a2@a.com>,
              <B b1@b.com>,
              <A a3@a.com>,
              <B b2@b.com b1@b.com> );
for @tests -> @test {
    say @test, " => ";
    my %merged = merge-account @test;
    for %merged.keys.sort -> $k {
        say "\t[", (join " ", $k, |%merged{$k}.keys.sort), "]";
    };
    say "";
}

This program displays the following output:

$ raku ./merge-account.raku
((A a1@a.com a2@a.com) (B b1@b.com) (A a3@a.com a1@a.com)) => 
    [A a1@a.com a2@a.com a3@a.com]
    [B b1@b.com]

((A a1@a.com a2@a.com) (B b1@b.com) (A a3@a.com) (B b2@b.com b1@b.com)) => 
    [A a1@a.com a2@a.com a3@a.com]
    [B b1@b.com b2@b.com]

Merge Account in Perl

This is a port to Perl of the previous Raku program. We use a hash of hashes to merge items belonging to the same name and remove possible duplicates.

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

sub merge_account {
    my %merged;
    for my $part (@_) {
        # say   Dumper $part;
        my ($key, @values) = @$part;
        $merged{$key}{$_} = 1 for @values;
    }
    # say %merged;
    return \%merged;
}

my @tests = ( [ [<A a1\@a.com a2\@a.com>], 
                [<B b1\@b.com>],
                [<A a3\@a.com a1\@a.com>] ],

              [ [<A a1\@a.com a2\@a.com>],
                [<B b1\@b.com>],
                [<A a3\@a.com>],
                [<B b2\@b.com b1\@b.com>] ] );

for my $test (@tests) {
    # say Dumper $test, " => ";
    for my $part (@$test) {
        print join " ", @$part;
        print " - ";
    }
    say " =>";
    my %merged = %{merge_account @$test};
    for my $k (sort keys %merged) {
        say "\t[", (join " ", $k, sort keys %{$merged{$k}}), "]";
    };
    say "";
}

This program displays the following output:

$ perl  ./merge-account.pl
A a1@a.com a2@a.com - B b1@b.com - A a3@a.com a1@a.com -  =>
        [A a1@a.com a2@a.com a3@a.com]
        [B b1@b.com]

A a1@a.com a2@a.com - B b1@b.com - A a3@a.com - B b2@b.com b1@b.com -  =>
        [A a1@a.com a2@a.com a3@a.com]
        [B b1@b.com b2@b.com]

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

These are some answers to the Week 208 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 March 19, 2023 at 23:59). 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: Minimum Index Sum

You are given two arrays of strings.

Write a script to find out all common strings in the given two arrays with minimum index sum. If no common strings found returns an empty list.

Example 1:

Input: @list1 = ("Perl", "Raku", "Love")
       @list2 = ("Raku", "Perl", "Hate")

Output: ("Perl", "Raku")

There are two common strings "Perl" and "Raku".
Index sum of "Perl": 0 + 1 = 1
Index sum of "Raku": 1 + 0 = 1

Example 2:

Input: @list1 = ("A", "B", "C")
       @list2 = ("D", "E", "F")

Output: ()

No common string found, so no result.

Example 3:

Input: @list1 = ("A", "B", "C")
       @list2 = ("C", "A", "B")

Output: ("A")

There are three common strings "A", "B" and "C".
Index sum of "A": 0 + 1 = 1
Index sum of "B": 1 + 2 = 3
Index sum of "C": 2 + 0 = 2

Minimum Index Sum in Raku

We need to find the intersection between two arrays of strings. Once we’ve found the intersection, we need to keep the intersection items that have the smallest sum of indexes in the original array. So, it looked like it would be nice to use Bags for the input (with the index as weight integer for each item), and the ∩ or (&) infix intersection operator,infix%E2%88%AA) to generate the result. It turns out that this might not be the best choice, because the integer weight associated with a bag item is signifying how many copies of that element are considered “in the bag”. So, if the weight is 0, it means the item is not in the bag and is lost during bag construction. Since array indexes start at 0, we’d be losing the first item of each array. The problem is solved by assigning the index incremented by 1 to the weight. This easily solves the problem, but makes the solution slightly less elegant than I originally hoped it to be.

sub min-sum-idx (@s1, @s2) {
    my $b1 = (map {@s1[$_] => $_ + 1}, 0..@s1.end).Bag;
    my $b2 = (map {@s2[$_] => $_ + 1}, 0..@s2.end).Bag;
    my $result = (map { $_ =>  $b1{$_} + $b2{$_}},  
        ($b1 ∩ $b2).keys).Bag;
    my $min = $result.values.min;
    return grep {$result{$_} == $min}, $result.keys;
}

for (<Perl Raku Love>, <Raku Perl Hate>), 
    (<A B C>, <D E F>), (<A B C>, <C A B>) 
        -> @test {
            say "@test[0] - @test[1]".fmt("%-35s => "), 
                min-sum-idx |@test;
}

This program displays the following output:

$ raku ./min-sum_idx.raku
Perl Raku Love - Raku Perl Hate    => (Perl Raku)
A B C - D E F                      => ()
A B C - C A B                      => (A)

Minimum Index Sum in Perl

For porting the above Raku program to Perl, we replace Bags with hashes. We use a grep to construct the @result intersection of the two input arrays, and a loop to compute the minimum array index sum.

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

sub min_sum_idx {
    my @s1 = @{$_[0]};
    my @s2 = @{$_[1]};

    my %h1 = map {$s1[$_] => $_ } 0..$#s1;
    my %h2 = map {$s2[$_] => $_ } 0..$#s2;
    my @result = grep { exists $h1{$_} } @s2;
    return "()" unless @result;
    my %res = map { $_ => $h1{$_} + $h2{$_} } @result;
    my $min = $res{$result[0]};
    for my $k (keys %res) { 
        $min = $res{$k} if $res{$k} < $min;
    }
    return grep {$res{$_} == $min} @result;
}

for my $test ( [[<Perl Raku Love>], [<Raku Perl Hate>]], 
    [[<A B C>], [<D E F>]], [[<A B C>], [<C A B>]] ) {

    printf "%-14s - %-16s => ", 
        "@{$test->[0]}", "@{$test->[1]}";
    say join " ", min_sum_idx @$test;
}

This program displays the following output:

$ perl  ./min-sum-idx.pl
Perl Raku Love - Raku Perl Hate   => Raku Perl
A B C          - D E F            => ()
A B C          - C A B            => A

Task 2: Duplicate and Missing

You are given an array of integers in sequence with one missing and one duplicate.

Write a script to find the duplicate and missing integer in the given array. Return -1 if none found.

For the sake of this task, let us assume the array contains no more than one duplicate and missing.

Example 1:

Input: @nums = (1,2,2,4)
Output: (2,3)

Duplicate is 2 and Missing is 3.

Example 2:

Input: @nums = (1,2,3,4)
Output: -1

No duplicate and missing found.

Example 3:

Input: @nums = (1,2,3,3)
Output: (3,4)

Duplicate is 3 and Missing is 4.

First, we are told that the integers are in sequence. This presumably means that they are sorted in ascending order. If not, we could just add a call to the built-in sort routine at the beginning of our code.

Second, the task specification tells us what to do when there is no missing item and no duplicate, but not what to do when only one of these two values is missing. I’ve decided to report something like (3, -) when 3 is a duplicate and there is no missing item, and (-, 3) when 3 is a missing value and there is no duplicate.

Duplicate and Missing in Raku

We simply loop over the input array values and

1. Report a duplicate if one value is equal to the previous one, and

2. Report a missing item if the current item is not one more than the previous one.

   sub dupe-and-missing (@nums) { my ($dupe, $missing); for 1..@nums.end -> $i { if @nums[$i] == @nums[$i-1] { $dupe = @nums[$i]; } elsif @nums[$i] - @nums[$i-1] != 1 { $missing = @nums[$i-1] + 1; } } return “($dupe, $missing)” if $dupe and $missing; return “-1” unless $dupe or $missing; return “($dupe, -)” if $dupe; # no missing item return “(-, $missing)”; # no dupe }

   for <1 2 2 4>, <1 2 3 4>, <1 2 3 3>, <1 2 4 5>, <1 1 3 4>, <1 3 4 5>, <1 2 2 3 5> -> @test { say “@test[]”.fmt(“%-12s => “), dupe-and-missing @test; }

This program displays the following output:

$ raku ./dupe_missing.raku
1 2 2 4      => (2, 3)
1 2 3 4      => -1
1 2 3 3      => (3, -)
1 2 4 5      => (-, 3)
1 1 3 4      => (1, 2)
1 3 4 5      => (-, 2)
1 2 2 3 5    => (2, 4)

Duplicate and Missing in Perl

This is a straight port to Perl of the Raku program above:

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

sub dupe_and_missing {
    my @nums = @_;
    my ($dupe, $missing);
    for my $i (1..$#nums) {
        if ($nums[$i] == $nums[$i-1]) {
            $dupe = $nums[$i];
        } elsif ($nums[$i] - $nums[$i-1] != 1) {
            $missing = $nums[$i-1] + 1;
        }
    }
    return "($dupe, $missing)" if $dupe and $missing;
    return "-1" unless $dupe or $missing;
    return "($dupe, -)" if $dupe;
    return "(-, $missing)";
}

for my $test ([<1 2 2 4>], [<1 2 3 4>], [<1 2 3 3>], 
    [<1 2 4 5>], [<1 1 3 4>], [<1 3 4 5>], [<1 2 2 3 5>]) {
    printf "%-12s => ", "@$test";
    say dupe_and_missing @$test;
}

This program displays the following output:

$ perl  ./dupe-missing.pl
1 2 2 4      => (2, 3)
1 2 3 4      => -1
1 2 3 3      => (3, -)
1 2 4 5      => (-, 3)
1 1 3 4      => (1, 2)
1 3 4 5      => (-, 2)
1 2 2 3 5    => (2, 4)

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

These are some answers to the Week 207 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 March 12, 2023 at 23:59). 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: Keyboard Word

You are given an array of words.

Write a script to print all the words in the given array that can be types using alphabet on only one row of the keyboard.

Let us assume the keys are arranged as below:

Row 1: qwertyuiop
Row 2: asdfghjkl
Row 3: zxcvbnm

Example 1

Input: @words = ("Hello","Alaska","Dad","Peace")
Output: ("Alaska","Dad")

Example 2

Input: @array = ("OMG","Bye")
Output: ()

Note that in the examples above, the input words are in title case (initial upper case letter), so we will need to perform a case conversion somewhere If we want to obtain any match.

Keyboard Word in Raku

First, we create an array of three hashes to store the letters of each keyboard row.

Then, the find-kb-word subroutine has two nested loops to loop over the input words and the keyboard rows. It then uses an all junction for each word/row combination to check whether letters of a word all belong to the same key row.

my @rows;
push @rows, %(map { $_ => True }, $_.comb) 
    for "qwertyuiop", "asdfghjkl", "zxcvbnm";

sub find-kb-word (@in) {
    my @out;
    for @in -> $word {
        for @rows -> %row {
            push @out, $word and next 
                if %row{all $word.lc.comb}:exists;
        }
    }
    return @out;
}
for <Hello Alaska Dad Peace>, <OMG Bye>, 
    <Power Fad Finish Tower Quit True Omit> -> @test {
    say find-kb-word @test;
}

This program displays the following output:

$ raku ./keyboard-words.raku
[Alaska Dad]
[]
[Power Fad Tower Quit True]

Keyboard Word in Perl

This is a port to Perl of the above Raku program. The only significant difference is that, since Perl doesn’t have junctions, the find_kb_word subroutine uses a grep to find whether all letters of a word belong to the same key row.

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

my @rows;
push @rows, {map {$_ => 1} split //, $_} 
    for "qwertyuiop", "asdfghjkl", "zxcvbnm";

for my $test ([<Hello Alaska Dad Peace>], [<OMG Bye>], 
    [<Power Fad Finish Tower Quit True Omit>]) {
    say join " ", find_kb_word(@$test);
}

sub find_kb_word {
    my @out;
    for my $word (@_) {
        for my $row (@rows) {
            my $eligible = 1;
            push @out, $word and last 
                unless grep {not exists $row->{$_}} 
                split //, lc $word;
        }
    }
    return @out ? @out : "()";
}

This program displays the following output:

$ perl ./keyboard-words.pl
Alaska Dad
()
Power Fad Tower Quit True

Task 2: H-Index

You are given an array of integers containing citations a researcher has received for each paper.

Write a script to compute the researcher’s H-Index. For more information please checkout the Wikipedia page.

The H-Index is the largest number h such that h articles have at least h citations each. For example, if an author has five publications, with 9, 7, 6, 2, and 1 citations (ordered from greatest to least), then the author’s h-index is 3, because the author has three publications with 3 or more citations. However, the author does not have four publications with 4 or more citations.

Example 1

Input: @citations = (10,8,5,4,3)
Output: 4

Because the 4th publication has 4 citations and the 5th has only 3.

Example 2

Input: @citations = (25,8,5,3,3)
Output: 3

The H-Index is 3 because the fourth paper has only 3 citations.

H-Index in Raku

The h-index subroutine first sorts the input data in descending order. It then looks for the first item whole value is less that its index + 1 and returns it.

sub h-index (@citations) {
    my @ordered = @citations.sort.reverse;
    for 0..@ordered.end -> $i {
        return $i if $i+1 > @ordered[$i];
    }
    # If we get here, then all papers qualify
    return @ordered.elems;
}
for <10 8 5 4 3>, <25 8 5 3 3>, <12 10 9 5 11> -> @test {
  say "@test[]".fmt("%-15s => "), h-index @test;
}

This program displays the following output:

$ raku ./h-index.raku
10 8 5 4 3      => 4
25 8 5 3 3      => 3
12 10 9 5 11    => 5

H-Index in Perl

This is a port to Perl of the above Raku program.

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

sub h_index {
    my @ordered = sort { $b <=> $a } @_;
    for my $i (0..$#ordered) {
        return $i if $i+1 > $ordered[$i];
    }
    # If we get here, then all papers qualify
    return scalar @ordered;
}
for my $test ([<10 8 5 4 3>], [<25 8 5 3 3>], [<12 10 9 5 11>]) {
    printf "%-15s => %d\n", "@$test", h_index @$test;
}

This program displays the following output:

$ perl h-index.pl
10 8 5 4 3      => 4
25 8 5 3 3      => 3
12 10 9 5 11    => 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 March 19, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.