These are some answers to the Week 228, 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 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 1: Unique Sum

You are given an array of integers.

Write a script to find out the sum of unique elements in the given array.

Example 1

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

In the given array we have 2 unique elements (1, 3).

Example 2

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

In the given array no unique element found.

Example 3

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

In the given array every element is unique.

Many programming languages, including Raku, have a built-in unique function or method that return a list of distinct values of an input list, and the List::Util core Perl module also offers several functions doing that. But they cannot be used here, because these functions keep one sample of each value from the input, and that's not what is desired here. In this task, we want to keep only the values that appear once in the input (and discard entirely any values that appear more than once).

Unique Sum in Raku

The unique-sum subroutine in the program below transforms the input list into a Bag, i.e. essentially an histogram of the values, a data structure that keeps track of the number of occurrences of each value. From there, it derives an array (@unique) containing all the items that appear only once. And, finally, it returns ther sum of these values.

sub unique-sum (@in) {
    my $histo = @in.Bag;    # histogram
    my @unique = grep { $histo{$_} == 1 }, $histo.keys;
    return [+] @unique;
}

for (2, 1, 3, 2), (1, 1, 1, 1), (2, 1, 3, 4) -> @test {
    printf "%-10s => ", "@test[]";
    say unique-sum @test;
}

This program displays the following output:

$ raku ./unique-sum.raku
2 1 3 2    => 4
1 1 1 1    => 0
2 1 3 4    => 10

Unique Sum in Perl

Perl doesn't have Bags, but we can use a hash to the same effect. The %histo hash tracks the number of occurrences of each item, and the @unique array keeps the items that appear only once. The unique_sum subroutine finally computes the sum of these items.

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

sub unique_sum {
    my %histo;      # histogram
    $histo{$_}++ for @_;
    my @unique = grep { $histo{$_} == 1 } keys %histo;
    my $sum = 0;
    $sum += $_ for @unique;
    return $sum;
}

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

This program displays the following output:

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

These are some answers to the Week 227, 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 30, 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: Roman Maths

Write a script to handle a 2-term arithmetic operation expressed in Roman numeral.

Example

IV + V     => IX
M - I      => CMXCIX
X / II     => V
XI * VI    => LXVI
VII ** III => CCCXLIII
V - V      => nulla (they knew about zero but didn't have a symbol)
V / II     => non potest (they didn't do fractions)
MMM + M    => non potest (they only went up to 3999)
V - X      => non potest (they didn't do negative numbers)

Of course, there are some Perl modules on the CPAN to convert from and to Roman numerals, but there wouldn't be any challenge if the idea were to use an existing module.

Most people know more or less how Roman numerals work. They use Latin letters to represent numbers:

|---------------------------------------------------|
| Symbol |  I  |  V  |  X  |  L  |  C  |  D  |  M   |
|---------------------------------------------------|
| Value  |  1  |  5  |  10 |  50 | 100 | 500 | 1000 |
|---------------------------------------------------|

In general, Roman numerals use additive notation: for example, MCLXXIII means 1000 + 100 + 50 + 20 + 3 = 1173. Or, at least, this is so when the symbols are written from left to right in decreasing value order.

If, however, a given symbol has a smaller value than a symbol placed on its right, then this is an example of subtractive notation: in that case, the smaller symbol is subtracted from the one its right. For example, IV means 1 subtracted from 5, i.e. 5 - 1 = 4. Similarly, IX and XC respectively mean 10 - 1 = 9 and 100 - 10 = 90. And MCMXLIX corresponds to 1000 + ( 1000 - 100) + (50 - 10) + (10 - 1) = 1949.

The overall problem, though, is that there is no general standard for Roman numerals. Applying the rules above makes it possible to decode more or less unambiguously any Roman numeral coded according to such aforesaid rules, but there may be several different possible ways to encode a number into a Roman numeral. For example, 99 could be encoded as XCIX or IC (or even XCVIIII or possibly LXXXXVIIII). The first transcription (XCIX) seems to be the most frequent one, so this is the one we will chose when encoding to Roman numerals. Still, IC seems to be a valid Roman numeral for 99, so we will try at least to be able to decode it if we find it.

There is no Roman numeral for integers less than 1 and the largest possible Roman numeral is 3,999.

Performing arithmetic operations directly with Roman numerals would be almost a carry-over nightmare. So, we will convert the Roman numerals into Arabic integers, perform standard arithmetic operations on the Arabic numbers, and then convert the result back to Roman numerals.

Roman Maths in Raku

As said before, we first convert to Arabic numerals (subroutine from-roman), perform the arithmetic operation, and then convert the result back to Roman numerals (subroutine to-roman).

In principle, it should be possible to construct a grammar for parsing Roman numerals, but it appeared to me that this would be more complicated than the algorithm explained below and used in the from-roman subroutine of program below.

For converting Roman numerals to Arabic integers, the idea is to read the symbols one by one from left to right and to add the values, keeping track of the previously seen value. If the current value is larger than the previous value, then we were in a case of a subtractive combination at the previous step, and we need to subtract twice the previous value (once because it is a subtractive combination, and once again because we have previously erroneously added it). That's actually quite simple.

For encoding Arabic numerals to Roman numerals, the easiest is to perform integer division with decreasing values corresponding to Roman numerals (i.e. M D C L X V I). For example, suppose we want to encode 2023. We first try to divide by 1,000 (corresponding to M). We get 2, so the start of the string representing the Roman numeral will be MM. Then we continue with the remainder, i.e. 23. We try integer division successively with 500, 100 and 50 and get 0, so don't do anything with the result. Next we try with 10 and get 2, so the temporary result is now MMXX. The remainder is 3, so the result is MMXXIII, which is a correct Roman numeral for 2023.

If we had started with 2019, we would have obtained MMXVIIII, which is a correct (simplistic) Roman numeral for 2019, but not really what we want, since we want to apply the subtractive combination and get MMXIX. We can observe that if our list of decreasing Roman values also includes IX (9), then it will work straight without any need to reprocess the result. So, our list of decreasing values corresponding to Roman numperals needs to be augmented with subtractive cases to M CM D CD C XC L XL X IX V IV I (corresponding to numbers 1000, 900, 500, 100, 90, 50, 40, 10, 9, 5, 4, 1). Using this list instead of the original one shown above removes any need for special processing for subtractive combinations: we just need to keep doing integer divisions with the decreasing values and continue the processing with the remainder. This what the to-roman subroutine below does.

Note that we define a Roman-str subtype (or, really, a subset of the String type) containing a character class with all letters used for Roman numerals. This wasn't strictly necessary, but it enables some form of simple (and possibly incomplete) validation of the parameter passed to from-roman.

The error messages have been slightly shortened to allow better formatting on this blog post.

subset Roman-str of Str where $_ ~~ /^<[IVXLCDMivxlcdm]>+$/;

my %rom-tab = < I 1  V 5  X 10  L 50  C 100  D 500  M 1000 
               IV 4  IX 9  XL 40  XC 90  CD 400  CM 900 >;
my @ordered_romans = reverse sort { %rom-tab{$_} }, keys %rom-tab;

sub from-roman (Roman-str $roman) {
    my $numeric = 0;
    my $prev_letter = "M";
    for $roman.uc.comb -> $letter {
        $numeric -= 2 * %rom-tab{$prev_letter} 
            if %rom-tab{$letter} > %rom-tab{$prev_letter};
        $numeric += %rom-tab{$letter};
        # say "$letter $numeric";
        $prev_letter = $letter;
    }
    return $numeric;
}

sub to-roman (Int $arabic is copy where  { 0 < $_ < 4000 }) {
    my $roman = "";
    for @ordered_romans -> $key {
        my $num = ($arabic / %rom-tab{$key}).Int;
        $roman ~= $key x $num;
        $arabic -= %rom-tab{$key} * $num; 
    }
    return $roman;
}
sub process-input (Str $in) {
    my ($rom1, $op, $rom2) = split /\s+/, $in;
    my $arabic1 = from-roman $rom1;
    my $arabic2 = from-roman $rom2;
    my $result;
    given $op {
        when '+' { $result = $arabic1 + $arabic2 }
        when '-' { $result = $arabic1 - $arabic2 }
        when '*' { $result = $arabic1 * $arabic2 }
        when '/' { $result = $arabic1 / $arabic2 }
        when '**' { $result = $arabic1 ** $arabic2 }
    }
    return "nulla (they didn't have a symbol for 0)" 
        if $result == 0;
    return "non potest (they didn't do fractions)" 
        if $result.round != $result;
    return "non potest (they only went up to 3999)" 
        if $result >= 4000;
    return "non potest (no negative numbers)"
        if $result < 0;
    return to-roman $result.round;
}

for "IV + V", "M - I", "X / II", "XI * VI",
  "VII ** III", "V - V", "V / II", "MMM + M",
  "V - X ", "X - V"  -> $test-expr {
    printf "%-10s => ", $test-expr;
    say process-input $test-expr;
}

This program displays the following output:

$ raku ./roman_numerals.raku
IV + V     => IX
M - I      => CMXCIX
X / II     => V
XI * VI    => LXVI
VII ** III => CCCXLIII
V - V      => nulla (they didn't have a symbol for 0)
V / II     => non potest (they didn't do fractions)
MMM + M    => non potest (they only went up to 3999)
V - X      => non potest (no negative numbers)
X - V      => V

Roman Maths in Perl

This Perl program is essentially the same as the Raku program above (but contrary to usual, this Perl program is not a port to Perl of the Raku program above, as a good part of the Perl program below (the from_roman and to_roman subroutines) was originally written before the Raku program). Please refer to the previous two sections if you need additional explanations.

#!/usr/bin/perl
use strict;
use warnings;
use feature qw/say/;

my %rom_tab = (I => 1,  V => 5, X => 10, L => 50, 
               C => 100, D => 500, M => 1000,
               IV => 4, IX => 9,  XL => 40, XC => 90,
               CD => 400,  CM => 900);

sub from_roman {
    my $roman = uc shift;
    my $arabic = 0;
    my $prev_letter = "M";
    for my $letter (split //, $roman) {
        $arabic -= 2 * $rom_tab{$prev_letter} 
            if $rom_tab{$letter} > $rom_tab{$prev_letter};
        $arabic += $rom_tab{$letter};
        $prev_letter = $letter;
    }
    return $arabic;
}

sub to_roman {
    my $arabic = shift;
    warn "$arabic out of bounds" 
        unless $arabic > 0 and $arabic < 4000;
    my $roman = "";
    for my $key (sort { $rom_tab{$b} <=> $rom_tab{$a} }
        keys %rom_tab) {
        my $num = int ($arabic / $rom_tab{$key});
        $roman .= $key x $num;
        $arabic -= $rom_tab{$key} * $num; 
    }
    return $roman;
}
sub process_input {
    my ($rom1, $op, $rom2) = split /\s+/, $_[0];
    my $arabic1 = from_roman $rom1;
    my $arabic2 = from_roman $rom2;
    my $result = $op eq '+'  ?  $arabic1 + $arabic2 :
                 $op eq '-'  ?  $arabic1 - $arabic2 :
                 $op eq '/'  ?  $arabic1 / $arabic2 :
                 $op eq '*'  ?  $arabic1 * $arabic2 :
                 $op eq '**' ?  $arabic1 ** $arabic2:
                 "illegal";
    return "nulla (they didn't have a symbol for 0)" 
        if $result == 0;
    return "non potest (they didn't do fractions)" 
        if int($result) != $result;
    return "non potest (they only went up to 3999)" 
        if $result >= 4000;
    return "non potest (no negative numbers)"
        if $result < 0;
    return to_roman $result;
}

for my $test ("IV + V", "M - I", "X / II", "XI * VI",
              "VII ** III", "V - V", "V / II", "MMM + M",
              "V - X ", "X - V") {
    printf "%-10s => ", $test;
    say process_input $test;
}

This program displays the following output:

$ perl ./roman-numerals.pl
IV + V     => IX
M - I      => CMXCIX
X / II     => V
XI * VI    => LXVI
VII ** III => CCCXLIII
V - V      => nulla (they didn't have a symbol for 0)
V / II     => non potest (they didn't do fractions)
MMM + M    => non potest (they only went up to 3999)
V - X      => non potest (no negative numbers)
X - V      => 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 August 6 , 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 227, 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 30, 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: Friday 13th

You are given a year number in the range 1753 to 9999.

Write a script to find out how many dates in the year are Friday 13th, assume that the current Gregorian calendar applies.

Example

Input: $year = 2023
Output: 2

Since there are only 2 Friday 13th in the given year 2023 i.e. 13th Jan and 13th Oct.

The Gregorian calendar is the calendar used in most parts of the world. It was introduced in October 1582 by Pope Gregory XIII as a modification of, and replacement for, the previously used Julian calendar. The main change was to space leap years differently.

Date calculations are notoriously cumbersome and error-prone. So we will rely on well-tested core modules, which can tell us whether a given date in history or in the future is a Friday or some other day of the week.

Friday 13th in Raku

Raku has a built-in Date class that will compute the hard stuff for us. It has a new constructor that can take three parameters, year, month and day in the month, and return an immutable object (of type Date) identifying a day in the Gregorian calendar. It also has a day-of-week method, which returns an integer between 1 and 7, representing the day in the week (with Monday being 1 and Sunday being 7).

So, all we need to do for a given year is to check whether, for each month, the 13th falls on a Friday (day-of week == 5) and count how many times this happens in the year.

sub friday_13 ($y) {
    my $count = 0; 
    for 1..12 -> $m {
        # For the Raku Date class, Friday is the 
        # 5th day of the week
        $count++ if Date.new($y, $m, 13).day-of-week == 5;
    }
    return $count;
}
for 1753, |(2023..2030), 9998 -> $year {
    say $year, " => ", friday_13 $year;
}

This program displays the following output:

$ raku ./friday13.raku
1753 => 2
2023 => 2
2024 => 2
2025 => 1
2026 => 3
2027 => 1
2028 => 1
2029 => 2
2030 => 2
9998 => 3

Friday 13th in Perl

There are very powerful date and time calculation modules on the CPAN, such as, especially DateTime by Dave Rolsky. However, it is not a core module and, for various reasons, I prefer to use a core module such as Time::Piece, although its documentation has some opportunities for improvement.

Here, we use the (POSIX-inspired) strptime method as a constructor and the wday method to find the day in the week of any given date.

Just as in Raku, all we need to do for a given year is to check whether, for each month, the 13th falls on a Friday (day of week == 6) and count how many times this happens. Note that, for Time::Piece, the week starts on Sunday and, therefore, the integer representing Friday is 6.

use strict;
use warnings;
use feature 'say';
use Time::Piece;

sub friday_13 {
    my $year = shift;
    my $count = 0;
    my $day = 13;
    for my $month (1..12) {
        my $dt = Time::Piece->strptime("$month/$day/$year",
            "%m/%d/%Y");
        $count++ if $dt->wday == 6;   # Friday == 6th day
    }
    return $count;
}
for my $year (2023..2030, 9998) {
    say $year, " => ", friday_13 $year;
}

This program displays the following output:

2023 => 2
2024 => 2
2025 => 1
2026 => 3
2027 => 1
2028 => 1
2029 => 2
2030 => 2
9998 => 3

Note that we haven't computed the number of Friday 13th for the year 1753, because it appears that the Time::Piece module can't handle such old dates.

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

These are some answers to the Week 226, 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 23, 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: Zero Array

You are given an array of non-negative integers, @ints.

Write a script to return the minimum number of operations to make every element equal zero.

In each operation, you are required to pick a positive number less than or equal to the smallest element in the array, then subtract that from each positive element in the array.

Example 1:

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

operation 1: pick 1 => (0, 4, 0, 2, 4)
operation 2: pick 2 => (0, 2, 0, 0, 2)
operation 3: pick 2 => (0, 0, 0, 0, 0)

Example 2:

Input: @ints = (0)
Output: 0

Example 3:

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

operation 1: pick 1 => (1, 0, 3, 0, 2)
operation 2: pick 1 => (0, 0, 2, 0, 1)
operation 3: pick 1 => (0, 0, 1, 0, 0)
operation 4: pick 1 => (0, 0, 0, 0, 0)

We are required to find and display the number of operations needed to reduce all array items to 0. It would be quite easy to write an iterative (or even recursive) program following the prescribed description. But our program can be even simpler if we make the following observations, using the first example provided, (1, 5, 0, 3, 5).

First, the number of steps required will remain the same if, at the beginning or at any point in the process, we remove any or all zeros from the input. Thus, the first example can be reduced as follows:

(1, 5, 0, 3, 5) => (1, 5, 3, 5)

Second, the number of steps required will not change if we remove any duplicate (keeping only one integer of each input value). Thus, the first example can be further reduced as follows:

(1, 5, 3, 5) => (1, 5, 3)

We can easily see that we would now need three steps (subtracting 1, getting to (0, 4, 2), and then subtracting 2, getting (0, 2, 0), and finally subtracting 2 again). But we don't even need to actually perform the subtraction: all we need to do is to count the number of distinct (unique) non-zero values to find the required number of operations.

Zero Array in Raku

Based on the explanations above, the number-operations subroutine simply use a grep to remove zero values and the unique built-in method to remove duplicates, and finally returns the number of items in the resulting array. As it can be seen, this leads to a one-line solution.

sub number-operations (@ints) {
    return @ints.grep({$_ > 0}).unique.elems;
}

for <1 5 0 3 5>, (0,), <2 1 4 0 3> -> @test {
    printf "%-10s => ", "@test[]";
    say number-operations @test;
}

This program displays the following output:

$ raku ./number-operations.raku
1 5 0 3 5  => 3
0          => 0
2 1 4 0 3  => 4

Zero Array in Perl

We don't have a built-in unique function in Perl, but we can easily use a hash to remove the duplicates, leading to the following code:

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

sub number_operations {
    my %ints = map { $_ => 1} grep $_ > 0, @_;
    return scalar %ints;
}

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

This program displays the following output:

$ perl ./number-operations.pl
1 5 0 3 5  => 3
0          => 0
2 1 4 0 3  => 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 July 30 , 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 226, 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 23, 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: Shuffle String

You are given a string and an array of indices of same length as string.

Write a script to return the string after re-arranging the indices in the correct order.

Example 1

Input: $string = 'lacelengh', @indices = (3,2,0,5,4,8,6,7,1)
Output: 'challenge'

Example 2

Input: $string = 'rulepark', @indices = (4,7,3,1,0,5,2,6)
Output: 'perlraku'

I first thought that the indice represented the order in which to pick the letters from the string, and quickly came up with the following simple Raku subroutine:

sub shuffle-string ($string, @indices) {
    # Caution: wrong solution
    return ($string.comb)[@indices].join("");
}

and ran it with the first example provided with task:

$string = 'lacelengh', @indices = (3,2,0,5,4,8,6,7,1)

But that doesn't work, as, instead of "challenge", it returns the following string:

eclelhnga

What the heck is this? After some checks, I quickly came to the conclusion that my program did not appear to be buggy, but that I had misunderstood the task. How the hell can we obtain the string "challenge" from the given input data? It took me a few minutes to understand. Looking at the letters of the input string and the input indice:

[l a c e l e n g h]
(3 2 0 5 4 8 6 7 1)

we can see that it works differently: we need to pick the letter whose position is that of 0 in the indice (i.e. 'c'), then the letter whose position is that of 1 in the indice, and so on:

0   c
1   h
2   a
3   l
4   l
5   e
6   n
7   g
8   e

So we need to transform the input @indice array, or reverse it if you prefer, if we want to use it as a "slice" on the array containing the letters of the input string. The idea is to construct a new array where the first integer will be the position corresponding to 0 in the original @indice array (i.e. letter 'c'), the second item will be the position corresponding to 1 in the original @indice array (letter 'h'), and so on so that we will end up with the following new array:

[2 8 1 0 4 3 6 7 5]

which can readily used as a slice over the arrays of letters of the original string.

Shuffle String in Raku

Please refer to the above explanations to understand the array transformation (@indices -> @index) performed by the program.

sub shuffle-string ($string, @indice) {
    my @index;
    @index[@indice[$_]]= $_ for 0..@indice.end;
    # say @index;
    return ($string.comb)[@index].join("");
}

for ('lacelengh', (3,2,0,5,4,8,6,7,1)),
    ('rulepark', (4,7,3,1,0,5,2,6)) -> @test {
    printf "%-10s - %-20s => ", @test[0], "@test[1]";
    say shuffle-string @test[0], @test[1];
}

This program displays the following output:

$ raku ./shuffle-string.raku
lacelengh  - 3 2 0 5 4 8 6 7 1    => challenge
rulepark   - 4 7 3 1 0 5 2 6      => perlraku

Shuffle String in Perl

This a port to Perl of the above Raku program. Please refer to the explanations after the task description if you need any further explanation.

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

sub shuffle_string {
    my ($string, $idx_ref) = @_;
    my @indices = @$idx_ref;
    my @index;
    @index[$indices[$_]]= $_ for 0..$#indices;
    return join "", (split //, $string)[@index];
}

for my $test (['lacelengh', [3,2,0,5,4,8,6,7,1]],
    ['rulepark', [4,7,3,1,0,5,2,6]]) {
    printf "%-10s - %-18s => ", 
        $test->[0], "@{$test->[1]}";
    say shuffle_string $test->[0], $test->[1];

}

This program displays the following output:

$ perl ./shuffle-string.pl
lacelengh  - 3 2 0 5 4 8 6 7 1  => challenge
rulepark   - 4 7 3 1 0 5 2 6    => perlraku

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

These are some answers to the Week 225, 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 16, 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: Left Right Sum Diff

You are given an array of integers, @ints.

Write a script to return left right sum diff array as shown below:

@ints = (a, b, c, d, e)

@left  = (0, a, (a+b), (a+b+c))
@right = ((c+d+e), (d+e), e, 0)
@left_right_sum_diff = ( | 0 - (c+d+e) |,
                         | a - (d+e)   |,
                         | (a+b) - e   |,
                         | (a+b+c) - 0 | )

Example 1:

Input: @ints = (10, 4, 8, 3)
Output: (15, 1, 11, 22)

@left  = (0, 10, 14, 22)
@right = (15, 11, 3, 0)

@left_right_sum_diff = ( |0-15|, |10-11|, |14-3|, |22-0|)
                     = (15, 1, 11, 22)

Example 2:

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

@left  = (0)
@right = (0)

@left_right_sum_diff = ( |0-0| ) = (0)

Example 3:

Input: @ints = (1, 2, 3, 4, 5)
Output: (14, 11, 6, 1, 10)

@left  = (0, 1, 3, 6, 10)
@right = (14, 12, 9, 5, 0)

@left_right_sum_diff = ( |0-14|, |1-12|, |3-9|, |6-5|, |10-0|)
                     = (14, 11, 6, 1, 10)

Frankly, I don't understand the logic of this task, nor its aim. So I'll simply mimic blindly the task description and examples. The unstated assumption derived from the examples is that the left and right arrays should have the same size as the input array, that the left array should have a zero followed by partial sums of the input array except the last one, and that the right array should also have partial sums of the input array in reverse order, except the first one, and followed by a zero.

Left Right Sum Diff in Raku

In Raku, we can use reduction operator [] together with the + operator (to sum the items), prefixed with a \ to obtain partial or intermediate sums:

say [\+] 1..5;    # prints: (1 3 6 10 15)

This is sometimes called a triangular reduction. We use it for computing both the left and the right arrays. The rest of the program is straight forward: we use a map to perform the subtractions.

sub lrsd (@in) {
    my @l = (0, [\+] @in[0..@in.end - 1]).flat;
    my @r = 
    (( [\+] @in.reverse[0..@in.end - 1]).reverse, 0).flat;
    return map { (@l[$_] - @r[$_]).abs }, 0..@l.end;
}
my @tests = (10, 4, 8, 3), (1,), (1, 2, 3, 4, 5);
for @tests -> @test {
    printf "%-10s => ", "@test[]";
    say lrsd @test;
}

This program displays the following output:

$ raku ./left-right-sum-diff.raku
10 4 8 3   => (15 1 11 22)
1          => (0)
1 2 3 4 5  => (14 11 6 1 10)

Left Right Sum Diff in Perl

Perl doesn't have the reduction operator, but it is not complicated to compute partial sums in a for loop.

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

sub lrsd  {
    my @in = @_;
    my @l = (0);
    push @l, $l[-1] + $in[$_] for 0..$#in-1;
    my @r = (0); 
    push @r, $r[-1] + $in[$_] for reverse 1..$#in;
    @r = reverse @r;
    return join " ", map { abs ($l[$_] - $r[$_]) } 0..$#l;
}

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

This program displays the following output:

$ perl ./left-right-sum-diff.pl
10 4 8 3   => 15 1 11 22
1          => 0
1 2 3 4 5  => 14 11 6 1 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 July 23, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 225, 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 16, 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: Max Words

You are given a list of sentences, @list.

A sentence is a list of words that are separated by a single space with no leading or trailing spaces.

Write a script to find out the maximum number of words that appear in a single sentence.

Example 1

Input: @list = ("Perl and Raku belong to the same family.",
                "I love Perl.",
                "The Perl and Raku Conference.")
Output: 8

Example 2

Input: @list = ("The Weekly Challenge.",
                "Python is the most popular guest language.",
                "Team PWC has over 300 members.")
Output: 7

We will suppose that the point is just to count the words in a sentence, not to try to count unique words (i.e. without duplicates). If we wanted unique words, it would be very easy to change it (for example by adding an invocation to the unique method in the Raku version).

Max Words in Raku

In Raku, we simply chain invocations of the words and elems methods.

sub max-words (@sentences) {
    my $max = 0;
    for @sentences -> $sentence {
        my $cw = $sentence.words.elems;
        $max = $cw if $cw > $max;
    }
    return $max;
}

my @tests = 
    ("The quick brown fox jumps over the lazy dog",
        "Lorem ipsum dolor sit amet"),
    ("Perl and Raku belong to the same family.",
        "I love Perl.",
        "The Perl and Raku Conference."),
    ("The Weekly Challenge.",
        "Python is the most popular guest language.",
        "Team PWC has over 300 members.");
for @tests -> @test {
    say max-words @test;
}

This program displays the following output:

$ raku ./max-words.raku
9
8
7

Max Words in Perl

This is a port to Perl of the Raku program above. Here, we use split to divide the sentence into a list of words and use scalar to get the word count.

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

sub max_words {
    my $max = 0;
    for my $sentence (@_) {
        my $cw = scalar split /\s+/, $sentence;
        $max = $cw if $cw > $max;
    }
    return $max;
}

my @tests = (
    ["The quick brown fox jumps over the lazy dog",
        "Lorem ipsum dolor sit amet"], 
    ["Perl and Raku belong to the same family.",
        "I love Perl.",
        "The Perl and Raku Conference."],
    ["The Weekly Challenge.",
        "Python is the most popular guest language.",
        "Team PWC has over 300 members."]);
for my $test (@tests) {
    say max_words @$test;
}

This program displays the following output:

$ perl ./max-words.pl
9
8
7

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

These are some answers to the Week 224, 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 9, 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 Notes

You are given two strings, $source and $target.

Write a script to find out if using the characters (only once) from source, a target string can be created.

Example 1

Input: $source = "abc"
       $target = "xyz"
Output: false

Example 2

Input: $source = "scriptinglanguage"
       $target = "perl"
Output: true

Example 3

Input: $source = "aabbcc"
       $target = "abc"
Output: true

This task is somewhat similar to the "Good String" task of week 221, and we'll use essentially the same methods.

Special Notes in Raku

We can store the input source characters in a Bag and use the ⊆ subset of or equal to 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 special-note ($source, $target) {
    my $chars = $source.comb.Bag;
    return $target.comb.Bag ⊆ $chars;
}

for ("abc", "xyz"), ("scriptinglanguage", "perl"), 
        ("aabbcc", "abc") -> @test {
    printf "%-20s - %-7s => ", "@test[0]", "@test[1]";
    say special-note  @test[0], @test[1];
}

This program displays the following output:

$ raku ./main.raku
abc                  - xyz     => False
scriptinglanguage    - perl    => True
aabbcc               - abc     => True

Special Notes in Perl

Perl doesn't have Bags and set operators, but we can use a hash as a letter histogram to the same effect, with a loop to check whether each letter of $target word can be found in $source string.

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

sub special_note {
    my ($source, $target) = @_;
    my %chars;
    $chars{$_}++ for split //, $source;
    for my $let (split //, $target) {
        return "false" unless $chars{$let};
        $chars{$let}--;
    }
    return "true";
}
for my $test ([ "abc", "xyz"], 
    ["scriptinglanguage", "perl"],  ["aabbcc", "abc"] ) {
    printf "%-20s - %-7s => ", "@$test[0]", "@$test[1]";
    say special_note @$test[0], @$test[1];
}

_

This program displays the following output:

$ perl ./special-note.pl
abc                  - xyz     => false
scriptinglanguage    - perl    => true
aabbcc               - abc     => 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 July 16, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.

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

Task 2: Box Coins

You are given an array representing box coins, @box.

Write a script to collect the maximum coins until you took out all boxes. If we pick box[i] then we collect the coins $box[i-1] * $box[i] * $box[i+1]. If $box[i+1] or $box[i-1] is out of bound then treat it as 1 coin.

Example 1:

Input: @box = (3, 1, 5, 8)
Output: 167

Step 1: pick box [i=1] and collected coins 3 * 1 * 5 => 15.  Boxes available (3, 5, 8).
Step 2: pick box [i=1] and collected coins 3 * 5 * 8 => 120. Boxes available (3, 8).
Step 3: pick box [i=0] and collected coins 1 * 3 * 8 => 24.  Boxes available (8).
Step 4: pick box [i=0] and collected coins 1 * 8 * 1 => 8.   No more box available.

Example 2:

Input: @box = (1, 5)
Output: 10

Step 1: pick box [i=0] and collected coins 1 * 1 * 5 => 5. Boxes available (5).
Step 2: pick box [i=0] and collected coins 1 * 5 * 1 => 5. No more box available.

When we have more than three items, the best seems to take the smallest item, since other items will be used again (possibly several times), so it is good to keep the largest item when we can.

Box Coins in Raku

I must admit that this program is a little bit clunky and that there may very well be better ways to solve this task, but I don't have enough time to work more on that.

sub collect (@box is copy) {
    my $collected = 0; 
    while @box.elems > 3 {
        my $min = min (0..@box.end), :by( {@box[$_]});
        $collected += ((@box[$min-1 ] // 1) * @box[$min] * (@box[$min+1 ] // 1));
        @box = (@box[0..^$min, $min^.. @box.end]).flat;
    } 
    $collected += [*] @box;
    $collected += ((@box[0] ) * (@box[2] // 1)) if @box.elems == 3; 
    $collected +=  max @box;
    return $collected;
}
my @tests = (3, 1, 5, 8), (1, 5);
for @tests -> @test {
    print "@test[]".fmt("%-10s => ");
    say collect @test;
}

This program displays the following output:

$ raku ./box-coins.raku
3 1 5 8    => 167
1 5        => 10

Box Coins in Perl

This is essentially a port to Perl of the Raku program above, except that we had to write our own min_index and max subroutines.

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

sub min_index {
    my @in = @_;
    my $min = 0;
    for my $i (0..$#in) {
        $min = $i if $in[$i] < $in[$min];
    }
    return $min;
}
sub max {
    my $max = 0;
    for (@_) {
        $max = $_ if $_ > $max;
    }
    return $max;
}
sub collect {
    my @box = @_;
    my $collected = 0; 
    while (@box > 3) {
        my $min = min_index @box;
        $collected += (($box[$min-1 ] // 1) * $box[$min] * ($box[$min+1 ] // 1));
        @box = @box[0..$min-1, $min+1.. $#box];
    } 
    $collected += $box[0] * ($box[1] // 1) * ($box[2] // 1) ;
    $collected += (($box[0] ) * ($box[2] // 1)) if @box == 3; 
    $collected +=  max(@box);
    return $collected;
}
for my $test  ([3, 1, 5, 8], [1, 5]) {
    printf "%-15s => ", "@$test";
    say collect @$test;
}

This program displays the following output:

$ perl ./box-coins.pl
3 1 5 8         => 167
1 5             => 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 July 9, 2023. And, please, also spread the word about the Perl Weekly Challenge if you can.