These are some answers to the Week 231, 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 27, 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 2: Senior Citizens

You are given a list of passenger details in the form “9999999999A1122”, where 9 denotes the phone number, A the sex, 1 the age and 2 the seat number.

Write a script to return the count of all senior citizens (age >= 60).

Example 1

Input: @list = ("7868190130M7522","5303914400F9211","9273338290F4010")
Ouput: 2

The age of the passengers in the given list are 75, 92 and 40.
So we have only 2 senior citizens.

Example 2

Input: @list = ("1313579440F2036","2921522980M5644")
Ouput: 0

This is a very simple task, which can easily be solved with a one-liner solution. The only slight difficulty might be to deal with passengers aged 100 and above, but we'll have to ignore this edge case since we have not been given any information about them.

Since the input test items are rather long, my solutions will display only the last four digits of each data item, preceded by an ellipsis (...), in order to avoid silly formatting problems in the output as presented in this blog post.

Senior Citizens in Raku

The count-seniors subroutine uses the built-in substr method to retrieve the two digits containing the passenger's age and compare it with the age limit.

sub count-seniors (@in) {
    return (grep { .substr(11, 2) >= 60 }, @in).elems;
}
for <7868190130M7522 5303914400F9211 9273338290F4010>,
    <1313579440F2036 2921522980M5644> -> @test {
    printf "...%-s  ", .substr(11, 4) for  @test;
    say " => ", count-seniors @test;
}

This program displays the following output:

$ raku ./senior-citizens.raku
...7522  ...9211  ...4010   => 2
...2036  ...5644   => 0

Senior Citizens in Perl

This is a port to Perl of the above Raku program, using the same built-in substr function.

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

sub count_seniors {
    return scalar (grep { substr($_, 11, 2) >= 60 } @_);
}
for my $test 
    ([<7868190130M7522 5303914400F9211 9273338290F4010>],
     [<1313579440F2036 2921522980M5644>]) {
    printf "...%-s  ", substr($_, 11, 4) for @$test;
    say " => ", count_seniors @$test;
}

This program displays the following output:

$ perl ./senior-citizens.pl
...7522  ...9211  ...4010   => 2
...2036  ...5644   => 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 September 3, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 231, 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 27, 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: Min Max

You are given an array of distinct integers.

Write a script to find all elements that is neither minimum nor maximum. Return -1 if you can’t.

Example 1

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

The minimum is 1 and maximum is 4 in the given array. So (3, 2) is neither min nor max.

Example 2

Input: @ints = (3, 1)
Output: -1

Example 3

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

The minimum is 1 and maximum is 3 in the given array. So 2 is neither min nor max.

Min Max in Raku

We're simply looking for input integers that are different from the minimal and maximal values. We return these integers if there is at least one, or return -1 otherwise.

sub min-max (@in) {
    my @vals = grep {$_ != @in.min && $_ != @in.max}, @in;
    return @vals ?? @vals !! [-1];
}

for <3 2 1 4>, <3 1>, <2 1 3> -> @test {
    printf "%-10s => ", "@test[]";
    say min-max @test;
}

This program displays the following output:

$ raku ./min-max.raku
3 2 1 4    => [3 2]
3 1        => [-1]
2 1 3      => [2]

Min Max in Perl

This program does the same thing as the above Raku program, except that we need to implement our own find_min_max subroutine.

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

sub find_min_max {
    my $min = my $max = $_[0];
    for my $val (@_) {
        $min = $val if $val < $min;
        $max = $val if $val > $max;
    }
    return ($min, $max);
}

sub min_max {
    my ($min, $max) = find_min_max(@_);
    my @vals = grep {$_ != $min && $_ != $max} @_;
    return @vals ? @vals : (-1);
}

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

This program displays the following output:

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

These are some answers to the Week 230, 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 20, 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 2: Count Words

You are given an array of words made up of alphabetic characters and a prefix.

Write a script to return the count of words that starts with the given prefix.

Example 1

Input: @words  = ("pay", "attention", "practice", "attend")
       $prefix = "at"
Ouput: 2

Two words "attention" and "attend" starts with the given prefix "at".

Example 2

Input: @words  = ("janet", "julia", "java", "javascript")
       $prefix = "ja"
Ouput: 3

Three words "janet", "java" and "javascripr" starts with the given prefix "ja".

Again a very simple task. We just need to check each word against the prefix. To make things simpler, the first word passed as parameter to our subroutine will be the prefix.

Count Words in Raku

There are many ways to verify whether a word starts with a given prefix (index, substr, regex, etc.). We will use the built-in starts-with method, which is designed exactly for this purpose and is therefore very simple to use and likely to be efficient. We do it in a grep routine and count the input items that match the prefix.

sub count-words (@in is copy) {
    my $prefix = shift @in;
    return (grep { .starts-with($prefix) }, @in).elems;
}

for <at pay attention practice attend>, 
    <ja janet julia java javascript> -> @test {
    printf "%-3s - %-30s => ", 
        @test[0], "@test[1..@test.end]";
    say count-words @test;
}

This program displays the following output:

$ raku ./count-words.raku
at  - pay attention practice attend  => 2
ja  - janet julia java javascript    => 3

Count Words in Perl

This Perl program is based on the same approach as the above Raku program, but it uses the built-in substr function.

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

sub count_words {
    my $prefix = shift;
    return scalar grep { substr($_, 0, length $prefix)
        eq $prefix } @_;
}
for my $test ( [<at pay attention practice attend>], 
               [<ja janet julia java javascript>] ) {
    my @t = @$test;
    printf "%-3s - %-30s => ", 
        $t[0], "@t[1..$#t]";
    say count_words @t;
}

This program displays the following output:

$ perl ./count-words.pl
at  - pay attention practice attend  => 2
ja  - janet julia java javascript    => 3

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

These are some answers to the Week 230, 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 20, 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: Separate Digits

You are given an array of positive integers.

Write a script to separate the given array into single digits.

Example 1

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

Example 2

Input: @ints = (1, 24, 51, 60)
Output: (1, 2, 4, 5, 1, 6, 0

This task is very simple. We just need to split each value of the input array into individual digits and collect them into a list or an array.

Separate Digits in Raku

The separate-digits subroutine splits each input value into individual digits using the built-in comb method together with the map routine to iterate over the input items. Note that we also need to use the flat method to obtain a single Seq of values.

sub separate-digits (@ints) {
    return (map { $_.comb }, @ints).flat;
}

for <1 34 5 6>, <1 24 51 60> -> @test {
    printf "%-10s => ", "@test[]";
    say separate-digits @test;
}

This program displays the following output:

$ raku ./separate-digits.raku
1 34 5 6   => 1 3 4 5 6
1 24 51 60 => 1 2 4 5 1 6 0

Separate Digits in Perl

This is essentially a port to Perl of the above Raku program. We use split to split each input value into individual digits, and map to iterate over the input items. Contrary to Raku, Perl automatically flattens the result into one large array or list.

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

sub separate_digits {
    return join " ", map { split //, $_ } @_;
}

for my $test ( [<1 34 5 6>], [<1 24 51 60>] ) {
    printf "%-10s => ", "@$test";
    say separate_digits @$test;
}

This program displays the following output:

$ perl separate-digits.pl
1 34 5 6   => 1 3 4 5 6
1 24 51 60 => 1 2 4 5 1 6 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 August 27, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 229, 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 13, 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 2: Two out of Three

You are given three array of integers.

Write a script to return all the elements that are present in at least 2 out of 3 given arrays.

Example 1

Input: @array1 = (1, 1, 2, 4)
       @array2 = (2, 4)
       @array3 = (4)
Ouput: (2, 4)

Example 2

Input: @array1 = (4, 1)
       @array2 = (2, 4)
       @array3 = (1, 2)
Ouput: (1, 2, 4)

One simple solution is to count the values, after having removed duplicates from the original input arrays. Then, for each value, we obtain the number of arrays in which this value appears.

Two out of Three in Raku

In Raku, we will use a BagHash to construct a total histogram of values (unique in the input arrays). Once we have that, we can simply return the items of the histogram that occur more than twice.

sub two-out-of-three (@a) {
    my $histo = BagHash.new: @a[0].unique;
    $histo.add($_) for @a[1].unique, @a[2].unique;
    return sort grep { $histo{$_} >= 2 }, $histo.keys;
}
for ( (1, 1, 2, 4), (2, 4), (4,) ), 
    ( (4, 1), (2, 4), (1, 2) ) -> @test {
    printf "%-22s => ", @test.gist;
    say two-out-of-three (@test);
}

This program displays the following output:

$ raku ./two-out-of-three.raku
((1 1 2 4) (2 4) (4))  => (2 4)
((4 1) (2 4) (1 2))    => (1 2 4)

Two out of Three in Perl

This is a port to Perl of the above Raku problem. We use a hash instead of a BagHash to store the histogram of values from the input arrays. Before that, however, we use a temporary hash (%temp) to remove duplicates from each input array.

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

sub two_out_of_three {
    my %histo;
    for my $in (@_) {
        my %temp = map {$_ => 1} @$in; # make items unique
        $histo{$_} += 1 for keys %temp;
    }
    return sort grep { $histo{$_} >= 2 } keys %histo;
}
for my $test ( [ [1, 1, 2, 4], [2, 4], [4] ], 
      [ [4, 1], [2, 4], [1, 2] ] ) {
    print "(@$_) " for @$test;
    say " => ", join " ", two_out_of_three (@$test);
}

This program displays the following output:

$ perl ./two-out-of-three.pl
(1 1 2 4) (2 4) (4)  => 2 4
(4 1) (2 4) (1 2)  => 1 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 August 20, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 229, 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 13, 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: Lexicographic Order

You are given an array of strings.

Write a script to delete element which is not lexicographically sorted (forwards or backwards) and return the count of deletions.

Example 1

Input: @str = ("abc", "bce", "cae")
Output: 1

In the given array "cae" is the only element which is not lexicographically sorted.

Example 2

Input: @str = ("yxz", "cba", "mon")
Output: 2

In the given array "yxz" and "mon" are not lexicographically sorted.

Lexicographic Order in Raku

In the unsorted subroutine, for each input string, the string is split into individual letters and then sorted in lexicographic order. We then compare the original string with the strings produced with the re-arranged letters in lexicographic order and reverse lexicographic order. Note that we use here an any Junction to avoid separate equality tests. Note that the sort function defaults to lexicographic sort when given letters.

sub unsorted (@in) {
    my $count = 0;
    for @in -> $str {
        my @let = $str.comb.sort;
        $count++ if $str ne 
            (@let.join(""), @let.reverse.join("")).any;
    }
    return $count;
}
for <abc bce cae>, <yxz cba mon> -> @test {
    printf "%-12s => ", "@test[]";
    say unsorted @test;
}

This program displays the following output:

$ raku ./lexicographic-order.raku
abc bce cae  => 1
yxz cba mon  => 2

Lexicographic Order in Perl

This is essentially a port to Perl of the above Raku program. Please refer to the above if you want further explanations. The only significant difference is that, since there are no Junctions in Perl, we use two separate inequality tests. Note that sort defaults to lexicographical sort when it is not given a special comparison subroutine.

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

sub unsorted {
    my $count = 0;
    for my $str (@_) {
        my @let = sort split //, $str;
        $count++ if $str ne join "", @let and 
        $str ne join "", reverse @let;
    }
    return $count;
}
for my $test ([<abc bce cae>], [<yxz cba mon>]) {
    # print $test;
    printf "%-12s => ", "@$test";
    say unsorted @$test;
}

This program displays the following output:

$ perl ./lexicographic.pl
abc bce cae  => 1
yxz cba mon  => 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 August 20, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 228, 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 6, 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 2: Empty Array

You are given an array of integers in which all elements are unique.

Write a script to perform the following operations until the array is empty and return the total count of operations.

If the first element is the smallest then remove it otherwise move it to the end.

Example 1

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

Operation 1: move 3 to the end: (4, 2, 3)
Operation 2: move 4 to the end: (2, 3, 4)
Operation 3: remove element 2: (3, 4)
Operation 4: remove element 3: (4)
Operation 5: remove element 4: ()

Example 2

Input: @int = (1, 2, 3)
Ouput: 3

Operation 1: remove element 1: (2, 3)
Operation 2: remove element 2: (3)
Operation 3: remove element 3: ()

First, an important information is that all elements of the input array are unique. This means that there cannot be two items that are equal, or, in other words, that, if the first item is the smallest, then all other items are (strictly) larger.

Empty Array in Raku

We start with an end-less loop (from which we will exit with a last statement once the array is empty). In the loop, we shift the first item of the array (meaning that we remove it from the array and retrieve its value). If its value is not the smallest in the array, we push it back to the end of the array. Otherwise, it is the smallest item in the array, we don't do anything to the array, meaning that the array has now one item less than before. And we use a counter ($count) to record the number of steps. Note that we conveniently use an any junction to check whether the shifted item is the smallest item of the array, that is that it is not larger than any other item.

sub empty-array (@in is copy) {
    my $count = 0;
    loop {
        my $val = shift @in;
        push @in, $val if $val > @in.any;
        $count++;
        last unless @in;
    }
    return $count;
}

for <3 4 2>, <1 2 3>, <3 2 1>, <4 7 2 9 1> -> @test {
    printf "%-10s => ", "@test[]";
    say empty-array @test;
}

This program displays the following output:

$ raku ./empty-array.raku
3 4 2      => 5
1 2 3      => 3
3 2 1      => 6
4 7 2 9 1  => 12

Empty Array in Perl

This is a port to Perl of the above Raku program. Please refer to the above section if you need explanations. The only significant difference is that, since Perl doesn't have junctions, we need to implement an inner loop to find out whether the chosen item is smaller than all other remaining items of the array.

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

sub empty_array {
    my @in = @_;
    my $count = 0;
    while (1) {
        my $val = shift @in;
        my $pushback = 0;
        for my $item (@in) {
            $pushback = 1 if $val > $item;
            last if $pushback;
        }
        push @in, $val if $pushback;
        $count++;
        last unless @in;
    }
    return $count;
}

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

This program displays the following output:

$ perl ./empty-array.pl
3 4 2      => 5
1 2 3      => 3
3 2 1      => 6
4 7 2 9 1  => 12

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