These are some answers to the Week 223, 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 2, 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: Count Primes

You are given a positive integer, $n.

Write a script to find the total count of primes less than or equal to the given integer.

Example 1

Input: $n = 10
Output: 4

Since there are 4 primes (2,3,5,7) less than or equal to 10.

Example 2

Input: $n = 1
Output: 0

Example 3

Input: $n = 20
Output: 8

Since there are 8 primes (2,3,5,7,11,13,17,19) less than or equal to 20.

Count Primes in Raku

Raku has the build-in is-prime routine, implementing the very fast probabilistic Miller-Rabin test for primality. So we just need to test each integer in the 1..$n range and count those that are prime.

sub count-primes ($n) {
    return ((1..$n).grep({.is-prime})).elems;
}
for 10, 1, 20 -> $test {
    say $test.fmt("%-3d => "), count-primes $test;
}

This program displays the following output:

$ raku ./count-primes.raku
10  => 4
1   => 0
20  => 8

Count Primes in Perl

This is a port to Perl of the Raku program above. Since Perl doesn't have an is-prime built-in routine, we implement our own is_prime subroutine.

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

sub is_prime {
    my $in = shift;
    for my $i (2..sqrt $in) {
        return 0 if $in % $i == 0;
    }
    return 1;
}
sub count_primes {
    my $n = shift;
    return scalar grep {is_prime $_} 2..$n;
}

for my $test (10, 1, 20) {
    printf "%-3d => %d\n", $test, count_primes $test;
}

This program displays the following output:

$ perl ./count-primes.pl
10  => 4
1   => 0
20  => 8

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

These are some answers to the Week 222 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 June 25, 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: Matching Members

You are given a list of positive integers, @ints.

Write a script to find the total matching members after sorting the list increasing order.

Example 1

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

Original list: (1, 1, 4, 2, 1, 2)
Sorted list  : (1, 1, 1, 2, 3, 4)

Compare the two lists, we found 3 matching members (1, 1, 2).

Example 2

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

Original list: (5, 1, 2, 3, 4)
Sorted list  : (1, 2, 3, 4, 5)

Compare the two lists, we found 0 matching members.

Example 3

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

Original list: (1, 2, 3, 4, 5)
Sorted list  : (1, 2, 3, 4, 5)

Compare the two lists, we found 5 matching members.

Matching Members in Raku

The matching-members subroutine first sorts the input array and then compares the values of the input array and the sorted array for each index within the range. Note that Raku allows you to use two postfix expressions:

do-something if <condition> for <range>;

which is quite convenient and leads to fairly concise code.

sub matching-members (@in) {
    my @sorted = @in.sort;
    my $match = 0;
    $match++ if @in[$_] == @sorted[$_] for 0..@in.end;
    return $match;
}

for <1 1 4 2 1 3>, <5 1 2 3 4>, <1 2 3 4 5> -> @test {
    printf "%-12s => ", "@test[]";
    say matching-members @test;
}

This program displays the following output:

$ raku ./matching-members.raku
1 1 4 2 1 3  => 3
5 1 2 3 4    => 0
1 2 3 4 5    => 5

The matching-members subroutine can me made more concise using the grep and elems routines:

sub matching-members (@in) {
    my @sorted = @in.sort;
    (grep {@in[$_] == @sorted[$_]}, 0..@in.end).elems;
}

This modified subroutine leads to the same output as before.

Matching Members in Perl

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

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

sub matching_members {
    my @sorted = sort { $a <=> $b } @_;
    my $match = 0;
    for my $i (0..$#sorted) {
        $match++ if $_[$i] == $sorted[$i];
    }
    return $match;
}

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

This program displays the following output:

$ perl ./matching-members.pl
1 1 4 2 1 3  => 3
5 1 2 3 4    => 0
1 2 3 4 5    => 5

Task 2: Last Member

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

Write a script to find the last member if found otherwise return 0. Each turn pick 2 biggest members (x, y) then decide based on the following conditions, continue this until you are left with 1 member or none.

a) if x == y then remove both members

b) if x != y then remove both members and add new member (y-x)

Example 1:

Input: @ints = (2, 7, 4, 1, 8, 1)
Output: 1

Step 1: pick 7 and 8, we remove both and add new member 1 => (2, 4, 1, 1, 1).
Step 2: pick 2 and 4, we remove both and add new member 2 => (2, 1, 1, 1).
Step 3: pick 2 and 1, we remove both and add new member 1 => (1, 1, 1).
Step 4: pick 1 and 1, we remove both => (1).

Example 2:

Input: @ints = (1)
Output: 1

Example 3:

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

Step 1: pick 1 and 1, we remove both and we left with none.

In its first version, the task description told us to pick two random numbers (rather than the 2 biggest members). This could lead to different results, depending on the order in which you picked the items from the input. Given the first example provided, I decided to sort once the input in descending order and then to pick the first two items. With the revised version of the task description, I now need to sort the array at each iteration of the process.

Last Member in Raku

sub last-member (@ints) {
    my @in = reverse sort @ints;
    while @in.elems > 1 {
        @in = @in[0] == @in[1] ?? @in[2..@in.end].sort.reverse !!
              (@in[1] - @in[0], @in[2..@in.end]).flat.sort.reverse;
    }
    return @in.elems;
}

for (2, 7, 4, 1, 8, 1), (1,), (1, 1) -> @test {
  printf "%-12s => ", "@test[]";
  say last-member @test;
}

This program displays the following output:

$ raku ./last-member.raku
2 7 4 1 8 1  => 1
1            => 1
1 1          => 0

Last Member in Perl

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

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

sub last_member {
    my @in = sort { $b <=> $a } @_;
    while (@in > 1) {
        @in = $in[0] == $in[1] ? 
            sort { $b <=> $a } @in[2..$#in] :
            sort { $b <=> $a } ($in[1] - $in[0], @in[2..$#in]);
        # say "@in"; # uncomment to view the steps
    }
    return scalar @in;
}

for my $test ([2, 7, 4, 1, 8, 1], [1], [1, 1]) {
    printf "%-12s => ", "@$test";
    say last_member @$test;
}

This program displays the following output:

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

These are some answers to the Week 221, 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 June 18, 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.

Arithmetic Subsequence

You are given an array of integers, @ints.

Write a script to find the length of the longest Arithmetic Subsequence in the given array.

A subsequence is an array that can be derived from another array by deleting some or none elements without changing the order of the remaining elements.

A subsequence is arithmetic if ints[i + 1] - ints[i] are all the same value (for 0 <= i < ints.length - 1).

Example 1:

Input: @ints = (9, 4, 7, 2, 10)
Output: 3

The longest Arithmetic Subsequence (4, 7, 10) can be derived by deleting 9 and 2.

Example 2:

Input: @ints = (3, 6, 9, 12)
Output: 4

No need to remove any elements, it is already an Arithmetic Subsequence.

Example 3:

Input: @ints = (20, 1, 15, 3, 10, 5, 8)
Output: 4

The longest Arithmetic Subsequence (20, 15, 10, 5) can be derived by deleting 1, 3 and 8.

Arithmetic Subsequence in Raku

The longest-subseq subroutine first collects all combinations of items (@pairs) from the input and then populates the %gaps histogram of differences between pairs elements, and then returns the most frequent gap (+ 1, as for n gaps, we have n+1 items).

sub longest-subseq (@in) {
    my @pairs = @in.combinations: 2;
    my %gaps;
    %gaps{~($_[1] - $_[0])}++ for @pairs;
    # For n gaps, we have n + 1 values
    return %gaps.values.max + 1;
}

for <9 4 7 2 10>, <3 6 9 12>, <20 1 15 3 10 5 8> -> @test {
    printf "%-18s => %d\n", ~(@test), longest-subseq @test;
}

This program displays the following output:

9 4 7 2 10         => 3
3 6 9 12           => 4
20 1 15 3 10 5 8   => 4

Arithmetic Subsequence in Perl

This is essentially a port to Perl of the Raku program above. The call to the combinations method is replaced by a nested for loop over the input array, and we need also an additional for loop to find the gap with the highest frequency. The longest_subseq subroutine first collects all combinations of items (@pairs) from the input and then populates the %gaps histogram of differences between pairs elements, and then returns the most frequent gap (+ 1, as for n gaps, we have n+1 items).

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

sub longest_subseq {
    my @pairs;
    for my $i (0..$#_) {
        for my $j ($i+1..$#_) {
            push @pairs, [$_[$i], $_[$j]];
        }
    }
    my %gaps;
    $gaps{($_->[1] - $_->[0])}++ for @pairs;
    my $max = 0;
    for my $k (keys %gaps) {
        $max = $gaps{$k} if $gaps{$k} > $max;
    }
    # For n gaps, we have n + 1 values
    return $max + 1;
}

for my $test ( [<9 4 7 2 10>], [<3 6 9 12>], [<20 1 15 3 10 5 8>] ) {
    printf "%-18s => ", "@$test";
    say longest_subseq @$test;
}

This program displays the following output:

9 4 7 2 10         => 3
3 6 9 12           => 4
20 1 15 3 10 5 8   => 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 June 25, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 221, 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 June 18, 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.

Good Strings

You are given a list of @words and a string $chars.

A string is good if it can be formed by characters from $chars, each character can be used only once.

Write a script to return the sum of lengths of all good strings in words.

Example 1

Input: @words = ("cat", "bt", "hat", "tree")
       $chars = "atach"
Output: 6` 

The good strings that can be formed are "cat" and "hat" so the answer is 3 + 3 = 6.

Example 2

Input: @words = ("hello", "world", "challenge")
       $chars = "welldonehopper"
Output: 10

The strings that can be formed are "hello" and "world" so the answer is 5 + 5 = 10.

Good Strings in Raku

We can store the input characters in a Bag and use the ⊆ subset of or equal operator,infix%E2%8A%86) to figure out whether all letters of a word can be found in the input string. In this context, bags are clever enough to manage duplicates in the input characters and use input characters only once.

sub find-good ($string, @words) {
    my $chars = $string.comb.Bag;
    my $length = 0;
    for @words -> $word {
        $length += $word.chars if $word.comb.Bag ⊆ $chars;
    }
    return $length
}
for (("atach", <cat bt hat tree atac>), 
    ("atach", <cat bt hat tree ataca>),
    ("welldonehopper", <hello world challenge>)) -> @test {
    printf "%-15s - %-22s => ", "@test[0]", "@test[1]";
    say find-good  @test[0], @test[1];
}

This program displays the following output:

$ raku ./good-string.raku
atach           - cat bt hat tree atac   => 10
atach           - cat bt hat tree ataca  => 6
welldonehopper  - hello world challenge  => 10

Good Strings in Perl

Perl doesn't have Bags and set operators, but we can use hashes as histograms to the same effect, with a loop to check whether each letter of an input word can be found in the input character string.

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

sub find_good {
    my ($string, @words) = @_;
    # say $string, " - ", "@words"; 
    my $length = 0;
    my %chars;
    $chars{$_}++ for split //, $string;
    WORD: for my $word (@words) {
        my %char_cpy = %chars;
        for my $let (split //, $word) {
            next WORD unless $char_cpy{$let};
            $char_cpy{$let}--;
        }
        $length += length $word;
    }
    return $length
}
for my $test (
    ["atach", [<cat bt hat tree>]], 
    ["atach", [<cat bt hat tree cata>]], 
    ["atach", [<cat bt hat tree ataca>]],
    ["welldonehopper", [<hello world challenge>]]) {
    printf "%-15s - %-22s => ", "@$test[0]", "@{@$test[1]}";
    say find_good  @$test[0], @{@$test[1]};
}

This program displays the following output:

$ perl ./good-string.pl
atach           - cat bt hat tree        => 6
atach           - cat bt hat tree cata   => 10
atach           - cat bt hat tree ataca  => 6
welldonehopper  - hello world challenge  => 10

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

These are some answers to the Week 220, 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 June 11, 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.

Squareful Arrays

You are given an array of integers, @ints.

An array is squareful if the sum of every pair of adjacent elements is a perfect square.

Write a script to find all the permutations of the given array that are squareful.

Example 1:

Input: @ints = (1, 17, 8)
Output: (1, 8, 17), (17, 8, 1)

(1, 8, 17) since 1 + 8 => 9, a perfect square and also 8 + 17 => 25 is perfect square too.
(17, 8, 1) since 17 + 8 => 25, a perfect square and also 8 + 1 => 9 is perfect square too.

Example 2:

Input: @ints = (2, 2, 2)
Output: (2, 2, 2)

There is only one permutation possible.

Squareful Arrays in Raku

The is-squareful subroutine uses the rotor method with batch size of 2 and an overlap of -1 to generate each adjacent pair in the input array, sums the value of each such pair and returns True if all sums are perfect square. The find-squareful subroutine generates all permutations of the input list and keeps those that are squareful. Note that it uses a SetHash to store the permutations, so as to remove possible duplicate permutations.

sub is-squareful (@in) {
    for @in.rotor(2 => -1) -> @list {
        my $sum = [+] @list;
        return False if ($sum.sqrt.Int)² != $sum;
    }
    return True;
}
sub find-squareful (@in) {
    my $result = SetHash.new;
    for @in.permutations -> $perm {
        $result{"($perm)"}++ if is-squareful $perm;
    }
    return join ", ", $result.keys;
}   
for <1 17 8>, <17 1 8>, <2 2 2> -> @test {
    say @test, " => ",  find-squareful @test;
}

This program displays the following oputput:

$ raku ./squareful-arrays.raku
(1 17 8) => (17 8 1), (1 8 17)
(17 1 8) => (1 8 17), (17 8 1)
(2 2 2) => (2 2 2)

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

These are some answers to the Week 220, 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 June 11, 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.

Common Characters

You are given a list of words.

Write a script to return the list of common characters (sorted alphabetically) found in every word of the given list.

Example 1

Input: @words = ("Perl", "Rust", "Raku")
Output: ("r")

Example 2

Input: @words = ("love", "live", "leave")
Output: ("e", "l", "v")

Common Characters in Raku

Raku provides operators to make this task very simple. Each word is split into a list of individual letters and then, we use the infix ∩ set intersection operator,infix%E2%88%AA) to find the common characters. Note that we use the ∩ intersection operator together with the [] reduction meta-operator, which makes it possible to apply the intersection operator to any number of input lists.

sub common-char (@in) {
    return sort keys ([∩] map {.lc.comb}, @in);
}

for <Perl Rust Raku>, <love live leave> -> @test {
    printf "%-15s => ", "@test[]";
    say common-char @test;
}

This program displays the following output:

$ raku ./common-characters.raku
Perl Rust Raku  => (r)
love live leave => (e l v)

This program is simple enough to boil down to a Raku one-liner:

$ raku -e 'say sort keys ([∩] map {.lc.comb}, @*ARGS)' love live leave
(e l v)

Common Characters in Perl

Perl doesn't have sets or set operators, so we use hashes instead. For each list of characters, we first remove any duplicate letters (using the %unique hash and then populate the %histo histogram hash. At the end, we keep any letter whose count is equal to the number of words in the initial input list.

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

sub common_char {
    my %histo;
    my @in = map lc $_, @_;
    for my $word (@in) {
        my %unique = map { $_ => 1 } split //, $word;
        $histo{$_}++ for keys %unique;
    }
    return sort grep { $histo{$_} == scalar @in } keys %histo;
}

for my $test ([<Perl Rust Raku>], [<love live leave>]) {
  printf "%-15s => ", "@$test";
  say join " ", common_char @$test;
}

This program displays the following output:

$ perl ./common-characters.pl
Perl Rust Raku  => r
love live leave => e l v

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