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

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

Task 1: Count Asterisks

You are given a string, $str, where every two consecutive vertical bars are grouped into a pair.

Write a script to return the number of asterisks, *, excluding any between each pair of vertical bars.

Example 1

Input: $str = "p|*e*rl|w**e|*ekly|"
Ouput: 2

The characters we are looking here are "p" and "w**e".

Example 2

Input: $str = "perl"
Ouput: 0

Example 3

Input: $str = "th|ewe|e**|k|l***ych|alleng|e"
Ouput: 5

The characters we are looking here are "th", "e**", "l***ych" and "e".

We'll use a regex substitution to remove the parts of the input strings to be excluded from the count (parts between pairs of vertical bars or pipe characters). There are many ways of counting the asterisks in the remaining parts of the input string, including various types of loops, but, it is simpler to use the tr/// transliteration operator, which returns essentially the number of changes performed. And, at least in Perl, the transliteration operator is reputed to be the fastest way of counting the occurrences of a character in a string.

Count Asterisks in Raku

For our substitution, we need our regex to match a vertical bar, followed by any number of characters other than the pipe, followed by a pipe. This is easily achieved with a frugal (or non-greedy) quantifier, which will match as much as it has to for the overall regex to succeed, but not more than that. This leads to the following possible regex: s:g/'|'.*?'|'//. The *? part is the frugal quantifier.

As mentioned above, we can use the tr/// transliteration operator to count the asterisks. In Raku, the transliteration operator returns not exactly the number of changes performed as informally stated above, but more precisely a StrDistance object, which will numify to the distance (or number of edits) between the original and resulting strings. Numification is performed here with a + sign before the overall expression.

This leads to the following program:

sub count-asterisks ($in is copy) {
    $in ~~ s:g/'|'.*?'|'//;
    return +($in ~~ tr/*//);
}

my @tests = "p|*e*rl|w**e|*ekly|", "perl", 
            "th|ewe|e**|k|l***ych|alleng|e";
for @tests -> $test {
    printf "%-30s => ", $test;
    say count-asterisks $test;
}

This program displays the following output:

$ raku ./count-asterisks.raku
p|*e*rl|w**e|*ekly|            => 2
perl                           => 0
th|ewe|e**|k|l***ych|alleng|e  => 5

Count Asterisks in Perl

This is a port to Perl of the above Raku program. The regex syntax is slightly different, but it uses a similar frugal quantifier and leads to the same matches.

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

sub count_asterisks {
    my $in = shift;
    $in =~ s/\|.*?\|//g;
    return +($in =~ tr/*//);
}

my @tests = ("p|*e*rl|w**e|*ekly|", "perl", 
          "th|ewe|e**|k|l***ych|alleng|e");
for my $test (@tests) {
    printf "%-30s => ", $test;
    say count_asterisks $test;
}

This program displays the following output:

$ perl ./count-asterisks.pl
p|*e*rl|w**e|*ekly|            => 2
perl                           => 0
th|ewe|e**|k|l***ych|alleng|e  => 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 August 11, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 280, Task 1, 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 August 4, 2024, at 23:59). This blog post provides some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Twice Appearance

You are given a string, $str, containing lowercase English letters only.

Write a script to print the first letter that appears twice.

Example 1

Input: $str = "acbddbca"
Output: "d"

Example 2

Input: $str = "abccd"
Output: "c"

Example 3

Input: $str = "abcdabbb"
Output: "a"

Twice Appearance in Raku

I first thought about using a regex, but I feared it might be inefficient (for some input strings, there may be a lot of beacktracking). So I decided it would be better to linearly loop over the letters of the input string and return from the subroutine as soon as we've found a repeated letter. We use the %seen hash to store the letter that we have already visited and return when the visited letter is already in the hash.

sub twice ($in) {
    my %seen;
    for $in.comb -> $let {
        return $let if %seen{$let}:exists;
        %seen{$let} = 1;
    }
}

my @tests = "acbddbca", "abccd", "abcdabbb";
for @tests -> $test {
    printf "%-10s => ", $test;
    say twice $test;
}

This program displays the following output:

$ raku ./twice-appaerance.raku
acbddbca   => d
abccd      => c
abcdabbb   => a

Twice Appearance in Perl

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

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

sub twice {
    my %seen;
    for my $let (split //, shift) {
        return $let if exists $seen{$let};
        $seen{$let} = 1;
    }
}

my @tests = ("acbddbca", "abccd", "abcdabbb");
for my $test (@tests) {
    printf "%-10s => ", $test;
    say twice $test;
}

This program displays the following output:

$ perl ./twice-appaerance.pl
acbddbca   => d
abccd      => c
abcdabbb   => a

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

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

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on July 28, 2024 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 2: Split String

You are given a string, $str.

Write a script to split the given string into two containing exactly same number of vowels and return true if you can otherwise false.

Example 1

Input: $str = "perl"
Ouput: false

Example 2

Input: $str = "book"
Ouput: true

Two possible strings "bo" and "ok" containing exactly one vowel each.

Example 3

Input: $str = "good morning"
Ouput: true

Two possible strings "good " and "morning" containing two vowels each or "good m" and "orning" containing two vowels each.

We are asked to say whether the input string can be split into two substrings containing the same number of vowels. This can always be done if the input string contains an even number of vowels, and can never be done if it contains an odd number of vowels. So all we need to do it to count the vowels and return "True" if the count is even, and "False otherwise'.

Split String in Raku

As said above, we want to count the vowels in the input string. We use the comb method (with a regex matching vowels and an ignore-caseadverb) to get the vowels, count them with the elems method and find out whether the count can be evenly divided by 2, using the %% operator. We end up with a one-liner subroutine:

sub split-string ($in) {
    return $in.comb(/:i <[aeiou}]>/).elems %% 2;
}

for "Perl", "book", "bOok", "good morning" -> $test {
    printf "%-15s => ", $test;
    say split-string $test;
}

This program displays the following output:

$ raku ./split-string.raku
Perl            => False
book            => True
bOok            => True
good morning    => True

Split String in Perl

This is a port to Perl of the above Raku program. Not much to say about this port, except that we return "true" or "false" as strings.

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

sub split_string {
    my @vowels = grep {/[aeiou]/i} split "", shift;
    scalar @vowels % 2 == 0 ? "true" : "false";

}

for my $test ("Perl", "book", "bOok", "good morning") {
    printf "%-12s => ", $test;
    say split_string $test;
}

This program displays the following output:_

$ perl ./split-string.pl
Perl         => false
book         => true
bOok         => true
good morning => true

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

These are some answers to the Week 279, Task 1, 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 July 28, 2024, at 23:59). This blog post provides some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Sort Letters

You are given two arrays, @letters and @weights.

Write a script to sort the given array @letters based on the @weights.

Example 1

Input: @letters = ('R', 'E', 'P', 'L')
       @weights = (3, 2, 1, 4)
Output: PERL

Example 2

Input: @letters = ('A', 'U', 'R', 'K')
       @weights = (2, 4, 1, 3)
Output: RAKU

Example 3

Input: @letters = ('O', 'H', 'Y', 'N', 'P', 'T')
       @weights = (5, 4, 2, 6, 1, 3)
Output: PYTHON

Sort Letters in Raku

We need some way of combining the data of the two arrays to be able to sort the items of the @letters array in accordance with the values of the @weights array. For example, we could build an intermediate data structure of records containing each a letter and the value of its weight, sort his data structure in accordance with the weight and then extract the letters from the sorted data structure.

We don't need, however to create a new variable to contain an array with this intermediate data structure. We will use an anonymous array of pairs to host this data structure and perform the required operations on a data pipeline. The solution is often called Schwartzian Transform, because it was suggested by Randall Schwartz on a Perl newsgroup back in 1995, in the early days of Perl 5.

A literal translation to Raku of the canonical Perl Schwartzian Transform might look like this:

sub sort-letters (@letters, @weights) {
    return join "", map { $_[0] }, 
    sort { $^a[1] <=> $^b[1] }, 
    map { @letters[$_], @weights[$_] }, 0..@letters.end;
}

When trying to understand this construct, it is probably best to read from bottom to top, and from right to left. On the last line, the 0..@letters.end code at the end creates a list of subscripts used in the beginning of that line to create an anonymous array of arrays. The next line upwards sorts the data according to the weights and, finally, the map on the first line extracts the letters from sorted array.

This is, as I said, a Raku translation of how we would do it in Perl. But Raku offers some opportunities for improvement. In Raku, when the code block or subroutine called by sort takes only one parameter, then it specifies not the comparison subroutine, but the transformation to be applied to each item of the input data before sorting. So, we can simplify our Schwartzian Transform as follows:

sub sort-letters2 (@letters, @weights) {
    return join "", map { $_[0] }, sort { $_[1] }, 
    map { @letters[$_], @weights[$_] }, 0..@letters.end;
}

In addition, the creation of the intermediate data strucure can be greatly simplified using the zip routine, leading to a one-line Schwartzian Transform. We now display the full program:

sub sort-letters3 (@let, @w) {
    join "", map { $_[0] }, sort { $_[1] }, zip @let, @w;
}

my @tests = (< R E P L>, <3 2 1 4>),
            (<A U R K>, <2 4 1 3>),
            (<O H Y N P T>, <5 4 2 6 1 3>);
for @tests -> @test {
    printf "%-14s => ", "@test[0]";
    say sort-letters3 @test[0], @test[1];
}

This program (as well as its previous versions) displays the following output:

$ raku ./sort-letters.raku
R E P L        => PERL
A U R K        => RAKU
O H Y N P T    => PYTHON

Sort Letters in Perl

This is a port to Perl of the first Raku program above, with the original implementation of the Schwartzian Transform. Please refer to the above section if you need explanations.

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

sub sort_letters {
    my @letters = @{$_[0]};
    my @indices = @{$_[1]};
    return map $_->[0], sort { $$a[1] <=> $$b[1] } 
    map [ $letters[$_], $indices[$_] ], 0..$#letters;
}

my @tests = ( [ [< R E P L>], [<3 2 1 4>] ],
              [ [<A U R K>], [<2 4 1 3>] ],
              [ [<O H Y N P T>], [<5 4 2 6 1 3>] ] );
for my $test (@tests) {
    printf "%-14s => ", "@{$test->[0]}";
    say sort_letters $test->[0], $test->[1];
}

This program displays the following output:

$ perl  ./sort-letters.pl
R E P L        => PERL
A U R K        => RAKU
O H Y N P T    => PYTHON

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

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

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

Task 2: Reverse Word

You are given a word, $word and a character, $char.

Write a script to replace the substring up to and including $char with its characters sorted alphabetically. If the $char doesn’t exist, then DON'T do anything.

Example 1

Input: $str = "challenge", $char = "e"
Ouput: "acehllnge"

Example 2

Input: $str = "programming", $char = "a"
Ouput: "agoprrmming"

Example 3

Input: $str = "champion", $char = "b"
Ouput: "champion"

This task is not at all about reversing words, but I kept the title provided in the task description for proper reference.

Reverse Word in Raku

First, we use the index built-in routine to find the position of the first occurrence of $char in the input string. Then, we split the substring up to char into an array of individual characters and sort this array alphabetically (in ascending order), and join the characters into a string to provide the $prefix. We use the substr routine to extract the suffix, and stitch together the prefix and the suffix.

sub shuffle-word ($word is copy, $char) {
    my $ind = index $word, $char;
    return $word unless $ind;
    my $prefix = join "", sort $word.comb[0..$ind];
    return $prefix ~ substr $word, $ind + 1;
}

my @tests = <challenge e>, <programming a>, <champion, b>; 
for @tests -> @test {
    printf "%-12s %-2s => ", @test;
    say shuffle-word @test[0], @test[1];
}

This program displays the following output:

$ raku ./reverse-word.raku
challenge    e  => acehllnge
programming  a  => agoprrmming
champion,    b  => champion,

Reverse Word in Perl

This is a port to Perl of the above Raku program. There are a few syntax differences, but the basic built-in functions, index and substr, have essentially the same syntax in Perl and in Raku (at least for our purposes).

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

sub shuffle_word {
    my ($word, $char) = @_;
    my $ind = index $word, $char;
    return $word unless $ind;
    my @prefix_letters = (split //, $word)[0..$ind];
    my $prefix = join "", sort @prefix_letters;
    return $prefix . substr $word, $ind + 1;
}

my @tests = ( [ qw<challenge e> ], 
              [ qw<programming a> ], 
              [ qw<champion b> ] ); 
for my $test (@tests) {
    printf "%-12s %-2s => ", @$test;
    say shuffle_word @$test;
}

This program displays the following output:

$ perl ./reverse-word.pl
challenge    e  => acehllnge
programming  a  => agoprrmming
champion     b  => champion

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

These are some answers to the Week 278, Task 1, 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 July 21, 2024, at 23:59). This blog post provides some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Sort String

You are given a shuffle string, $str.

Write a script to return the sorted string.

A string is shuffled by appending word position to each word.

Example 1

Input: $str = "and2 Raku3 cousins5 Perl1 are4"
Output: "Perl and Raku are cousins"

Example 2

Input: $str = "guest6 Python1 most4 the3 popular5 is2 language7"
Output: "Python is the most popular guest language"

Example 3

Input: $str = "Challenge3 The1 Weekly2"
Output: "The Weekly Challenge"

There are a number of ways this could go wrong with faulty input. We will not try to validate the input, and we will assume correct input.

Sort String in Raku

We first split the input string into space-separated words, using the words method. We then use a regex to capture separately the letters and the digits, and store the letters in the @positions array, at the index given by the digit part.

sub sort-string ($in) {
    my @positions;
    for $in.words -> $word {
        $word ~~ m/(\D+)(\d+)/;
        @positions[$/[1]] = ~$/[0];

    }
    return "@positions[1..@positions.end]";
}
my @tests = "and2 Raku3 cousins5 Perl1 are4", 
            "guest6 Python1 most4 the3 popular5 is2 language7",
            "Challenge3 The1 Weekly2";
for @tests -> $test {
    say $test;
    say sort-string $test;
    say "";
}

This program displays the following output:

$ raku ./sort-sting.raku
and2 Raku3 cousins5 Perl1 are4
Perl and Raku are cousins

guest6 Python1 most4 the3 popular5 is2 language7
Python is the most popular guest language

Challenge3 The1 Weekly2
The Weekly Challenge

Sort String in Perl

This is a port to Perl of the above Raku program. Here, the words are separated using the split built-in function. Then, we use regular expression captures to retrieve the alphabetical part and the numeric part, which are then stored into the @positions array.

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

sub sort_string {
    my @positions;
    my @words = split /\s+/, shift;
    for my $word (@words) {
        my ($letters, $digits) = ($word =~ m/(\D+)(\d+)/);
        $positions[$digits] = $letters;

    }
    return "@positions[1..$#positions]";
}
my @tests = ("and2 Raku3 cousins5 Perl1 are4", 
            "guest6 Python1 most4 the3 popular5 is2 language7",
            "Challenge3 The1 Weekly2");
for my $test (@tests) {
    say $test;
    say sort_string $test;
    say "";
}

This program displays the following output:

$ perl  ./sort-sting.pl
and2 Raku3 cousins5 Perl1 are4
Perl and Raku are cousins

guest6 Python1 most4 the3 popular5 is2 language7
Python is the most popular guest language

Challenge3 The1 Weekly2
The Weekly Challenge

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

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

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

Task 2: Strong Pair

You are given an array of integers, @ints.

Write a script to return the count of all strong pairs in the given array.

A pair of integers x and y is called strong pair if it satisfies: 0 < |x - y| < min(x, y).

Example 1

Input: @ints = (1, 2, 3, 4, 5)
Ouput: 4

Strong Pairs: (2, 3), (3, 4), (3, 5), (4, 5)

Example 2

Input: @ints = (5, 7, 1, 7)
Ouput: 1

Strong Pairs: (5, 7)

We have a slight problem with example 2: since the integer 7 appears twice in the input array, we will find twice the strong pair (5, 7) and the output will be 2, not 1. To solve this issue and obtain the result specified in the example, we will remove duplicates from the input array before we start building the pairs.

Strong Pair in Raku

First, we use the unique method to remove duplicates from the input array, then we use the combinations method to generate all possible pairs. We increment the $count counter for each pair matching the strong pair criteria, and finally return the counter.

sub strong-pairs (@in) {
    my` $count = 0;
    for @in.unique.combinations: 2 -> @pair {
        $count++ if 0 < (@pair[0] - @pair[1]).abs < @pair.min;
    }
    return $count;
}

my @tests = (1, 2, 3, 4, 5), (5, 7, 1, 7);
for @tests -> @test {
    printf "%-10s => ", "@test[]";
    say strong-pairs @test;
}

This program displays the following output:

$ raku ./strong-pairs.raku
1 2 3 4 5  => 4
5 7 1 7    => 1

Strong Pair in Perl

This is essentially a port to Perl of the above Raku program. In Perl, the canonical way to remove duplicates is to coerce the input list into a hash and then retrieve the keys of the hash. Then we use two nested for loops to generate all the possible pairs. Next, we increment the $count counter for each pair matching the strong pair criteria, and finally return the counter.

sub strong_pairs {
    my %input = map { $_ => 1 } @_; # remove duplicates
    my @in = keys %input;
    my $count = 0;
    for my $i (0..$#in) {
        for my $j ($i+1..$#in) {
            my $min = $in[$i] < $in[$j] ? $i : $j;
            $count++ if 0 < abs($in[$i] - $in[$j]) and
                abs($in[$i] - $in[$j]) < $in[$min];
        }
    }
    return $count;
}

my @tests = ([1, 2, 3, 4, 5], [5, 7, 1, 7]);
for my $test (@tests) {
    printf "%-10s => ", "@$test";
    say strong_pairs @$test;
}

This program displays the following output:

$ perl ./strong-pairs.pl
1 2 3 4 5  => 4
5 7 1 7    => 1

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

These are some answers to the Week 277, Task 1, 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 July 14, 2024, known in France as Bastille Day, at 23:59). This blog post provides some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Count Common

You are given two arrays of strings, @words1 and @words2.

Write a script to return the count of words that appears in both arrays exactly once.

Example 1

Input: @words1 = ("Perl", "is", "my", "friend")
       @words2 = ("Perl", "and", "Raku", "are", "friend")
Output: 2

The words "Perl" and "friend" appear once in each array.

Example 2

Input: @words1 = ("Perl", "and", "Python", "are", "very", "similar")
       @words2 = ("Python", "is", "top", "in", "guest", "languages")
Output: 1

Example 3

Input: @words1 = ("Perl", "is", "imperative", "Lisp", "is", "functional")
       @words2 = ("Crystal", "is", "similar", "to", "Ruby")
Output: 0

Count Common in Raku

We could probably suggest a more concise solution by chaining the operations in a pipeline, but I preferred not to do so to improve readability.

First, we find the word frequencies by coercing the input arrays into Bags. Then, we keep items that appear only once and filter out the others. Finally, we use ∩,infix%E2%88%A9) intersection operator between the two unique bags and return the number of items in the intersection Set.

sub count-common (@in1, @in2) {
    my $bag-in1 = @in1.Bag;
    my $bag-in2 = @in2.Bag;
    my $unique1 = grep {$bag-in1{$_} == 1}, $bag-in1.keys;  .
    my $unique2 = grep {$bag-in2{$_} == 1}, $bag-in2.keys;
    return ($unique1 ∩ $unique2).elems;
}

my @tests = ( <Perl is my friend>, 
              <Perl and Raku are friend> ),
            ( <Perl is my friend>, 
              <Raku is friend of my friend Perl> ),
            ( <Perl and Python are very similar>, 
              <Python is top in guest languages> ),
            ( <Perl is imperative Lisp is functional>, 
              <Crystal is similar to Ruby> );

for @tests -> @test {
    say @test[0];
    say @test[1];
    say count-common @test[0], @test[1];
    say "";
}

This program displays the following output:

$ raku ./count-common.raku
(Perl is my friend)
(Perl and Raku are friend)
2

(Perl is my friend)
(Raku is friend of my friend Perl)
3

(Perl and Python are very similar)
(Python is top in guest languages)
1

(Perl is imperative Lisp is functional)
(Crystal is similar to Ruby)
0

Count Common in Perl

This is a port to Perl of the above Raku program. However, since there are no Bags in Perl, we use hashes to the same effect and have to populate them manually in a for loop. Similarly, we replace the intersection operator by another for loop.

use warnings;
use feature 'say';
use Data::Dumper;

sub count_common {
    my (%in1, %in2);
    for my $word (@{$_[0]}) {
        $in1{$word}++;
    }
    for my $word (@{$_[1]}) {
        $in2{$word}++;
    }
    my %unique1 = map { $_ => 1 } grep {$in1{$_} == 1} keys %in1;
    my %unique2 = map { $_ => 1 } grep {$in2{$_} == 1} keys %in2;
    my @intersect;
    for my $word (keys %unique1) {
        push @intersect, $word if exists $unique2{$word};
    }
    return scalar @intersect;  
}
my @tests = ( [ [<Perl is my friend>], 
               [<Perl and Raku are friend>] ],
             [ [<Perl is my friend>],
               [<Raku is friend of my friend Perl>] ],
             [ [<Perl and Python are very similar>],
               [<Python is top in guest languages>] ],
             [ [<Perl is imperative Lisp is functional>],
               [<Crystal is similar to Ruby>] ]
           );
for my $test (@tests) {
    say  "@{$test->[0]}";
    say  "@{$test->[1]}";
    say count_common $test->[0], $test->[1];
    say "";
}

This program displays the following output:

$ perl  ./count-common.pl
Perl is my friend
Perl and Raku are friend
2

Perl is my friend
Raku is friend of my friend Perl
3

Perl and Python are very similar
Python is top in guest languages
1

Perl is imperative Lisp is functional
Crystal is similar to Ruby
0

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

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

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

Task 2: Maximum Frequency

You are given an array of positive integers, @ints.

Write a script to return the total number of elements in the given array which have the highest frequency.

Example 1

Input: @ints = (1, 2, 2, 4, 1, 5)
Ouput: 4

The maximum frequency is 2.
The elements 1 and 2 has the maximum frequency.

Example 2

Input: @ints = (1, 2, 3, 4, 5)
Ouput: 5

The maximum frequency is 1.
The elements 1, 2, 3, 4 and 5 has the maximum frequency.

Maximum Frequency in Raku

We use a Bag to store the frequencies. This is very simple because we just need to coerce the input array to a Bag in order to compute the various frequencies. Then, we compute the maximum frequency and finally count the items whose frequency is equal to the maximum frequency.

sub max-frequency (@in) {
    my $frequencies = @in.Bag;
    my $max = $frequencies.values.max;
    my $count = 0;
    for $frequencies.keys -> $i {
        $count += $max if $frequencies{$i} == $max;
    }
    return $count;
}

my @tests = (1, 2, 2, 4, 1, 5), (1, 2, 3, 4, 5);
for @tests -> @test {
    printf "%-15s => ", "@test[]";
    say max-frequency @test;
}

This program displays the following output:

$  raku ./max-frequency.raku
1 2 2 4 1 5     => 4
1 2 3 4 5       => 5

Maximum Frequency in Perl

This is a port to Perl of the above Raku program. Perl having no Bags, we use a hash instead, but we need an explicit for loop to compute the frequencies and populate the %frequencies hash. Similarly, we need a for loop to compute the maximum frequency.

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

sub max_frequency {
    my %frequencies;
    for my $i (@_) {
        $frequencies{$i}++;
    }                                                                                                                       `
    my $max = 0;
    for my $i (values %frequencies) {
        $max = $i if $i > $max;
    }
    my $count = 0;
    for my $i (keys %frequencies) {
        $count += $max if $frequencies{$i} == $max;
    }
    return $count;
}

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

This program displays the following output:

$ perl  ./max-frequency.pl
1 2 2 4 1 5     => 4
1 2 3 4 5       => 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 July 14, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 276, Task 1, 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 July 7, 2024 at 23:59). This blog post provides some solutions to this challenge. Please don’t read on if you intend to complete the challenge on your own.

Task 1: Complete Day

You are given an array of integers, @hours.

Write a script to return the number of pairs that forms a complete day.

A complete day is defined as a time duration that is an exact multiple of 24 hours.

Example 1

Input: @hours = (12, 12, 30, 24, 24)
Output: 2

Pair 1: (12, 12)
Pair 2: (24, 24)

Example 2

Input: @hours = (72, 48, 24, 5)
Output: 3

Pair 1: (72, 48)
Pair 2: (72, 24)
Pair 3: (48, 24)

Example 3

Input: @hours = (12, 18, 24)
Output: 0

Complete Day in Raku

I have been trying to think about more clever solutions, but they quickly turned out to be far too complicated. By contrast, the brute force approach is very simple: we simply generate all possible pairs (with the combinations method) and keep the count of those whose sum is evenly divided by 24.

sub complete-day (@in) {
    my $count = 0;
    for @in.combinations: 2 -> @pair {
        $count++ if ([+] @pair) %% 24;
    }
    return $count;

my @tests = <12 12 30 24 24>, <72 48 24 5>, <12 18 24>;
for @tests -> @test {
    printf "%-15s => ", "@test[]";
    say complete-day @test;
}

This program displays the following output:

$ raku ./complete-days.raku
12 12 30 24 24  => 2
72 48 24 5      => 3
12 18 24        => 0

Complete Day in Perl

This is a port to Perl of the above Raku program. However, since Perl doesn't have a built-in combinations function, we generate all possible pairs "by hand" with nested loops.

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


sub complete_day {
    my @in = @_;
    my $count = 0;
    for my $i (0..$#in) {
        for my $j ($i+1..$#in) {
            $count++ if ($in[$i] + $in[$j]) % 24 == 0;
        }
    }
    return $count;
}

my @tests = ([<12 12 30 24 24>], [<72 48 24 5>], [<12 18 24>]);
for my $test (@tests) {
    printf "%-15s => ", "@$test";
    say complete_day @$test;
}

This program displays the following output:

$ perl ./complete-days.pl
12 12 30 24 24  => 2
72 48 24 5      => 3
12 18 24        => 0

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