laurent_r

These are some answers to the Week 290, 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 October 13, 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: Double Exist

You are given an array of integers, @ints.

Write a script to find if there exist two indices $i and $j such that:

1) $i != $j
2) 0 <= ($i, $j) < scalar @ints
3) $ints[$i] == 2 * $ints[$j]

Example 1

Input: @ints = (6, 2, 3, 3)
Output: true

For $i = 0, $j = 2
$ints[$i] = 6 => 2 * 3 =>  2 * $ints[$j]

Example 2

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

Example 3

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

For $i = 2, $j = 3
$ints[$i] = 4 => 2 * 2 =>  2 * $ints[$j]

I initially didn't understand condition (2). This ($i, $j) expression didn't make sense to me, until I understood that it meant that both $i and $j have to be greater than or equal to zero, and smaller than the number of items in the array.

Note that the first condition, $i != $j, is unnecessary since, if $i == $j, then we cannot meet condition (3), $ints[$i] == 2 * $ints[$j]. Well, that is except if the value is 0, but zeros should be avoided anyway because we could have 0 = 2 * 0, which is technically true, but that's not really the meaning of the task. I'll therefore consider that the input should be an array of non-zero integers because what we should do with the zero special case is unclear and not specified in the task. Thus, there is no need to check condition (1) in our code (this applies only to the Perl implementation, as we don't have this issue with the Raku implementation).

Double Exist in Raku

In Raku, the built-in combinations routine make it possible to generate automatically all combinations of two items of an array. Combinations are unordered. In other words, with an input such as <1 2 3>, the combinations method will generate the following combinations: (1 2) (1 3) (2 3), but not (2, 1), (3, 1), or (3, 2). Therefore, for each combination, we need to compare both ways: is the first item the double of the second, and is the second item the double of the first.

sub double-exists (@in) {
    for @in.combinations: 2 -> $comb {
        return True if $comb[0] == 2 * $comb[1] or 
            $comb[1] == 2 * $comb[0];
    }
    False;
}

my @tests = <1 2 3 4>, <6 2 3 3>, <3 1 4 13>, <2 1 4 2>;
for @tests -> @test {
    printf "%-10s => ", "@test[]";
    say double-exists @test;
}

This program displays the following output:

$ raku ./double-exists.raku
1 2 3 4    => True
6 2 3 3    => True
3 1 4 13   => False
2 1 4 2    => True

Double Exist in Perl

Perl doesn't have a built-in combinations subroutine, so we will apply the canonical method of generating them (as well as those reversing the value order) using two nested loops. Please read my comments at the beginning of this post concerning the first condition ($i != $j) and the need to avoid zero values in the input. If you disagree with my view, it is very easy to add a code list such as:

next if $i == $j;

in the inner loop of the code below.

sub double_exists {
    for my $i (0..$#_) {
        for my $j (0..$#_) {
            return "True" if $_[$i] == 2 * $_[$j];
        }
    }
    return "False";
}

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

This program displays the following output:

$ perl ./double-exists.pl
1 2 3 4    => True
6 2 3 3    => True
3 1 4 13   => False
2 1 4 2    => 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 October 20, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 290, 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 October 13, 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: Luhn’s Algorithm

You are given a string $str containing digits (and possibly other characters which can be ignored). The last digit is the payload; consider it separately. Counting from the right, double the value of the first, third, etc. of the remaining digits.

For each value now greater than 9, sum its digits.

The correct check digit is that which, added to the sum of all values, would bring the total mod 10 to zero.

Return true if and only if the payload is equal to the correct check digit.

It was originally posted on reddit.

Example 1

Input: "17893729974"
Output: true

Payload is 4.

Digits from the right:

7 * 2 = 14, sum = 5
9 = 9
9 * 2 = 18, sum = 9
2 = 2
7 * 2 = 14, sum = 5
3 = 3
9 * 2 = 18, sum = 9
8 = 8
7 * 2 = 14, sum = 5
1 = 1

Sum of all values = 56, so 4 must be added to bring the total mod 10 to zero. The payload is indeed 4.

Example 2

Input: "4137 8947 1175 5904"
Output: true

Example 3

Input: "4137 8974 1175 5904"
Output: false

The Luhn algorithm is a simple check digit formula (or checksum) used to validate a variety of identification numbers.

The algorithm was invented in 1960 and is in wide use today. It is aimed at protecting against accidental typing errors. Most credit cards and many government identification numbers use the algorithm as a simple method of distinguishing valid numbers from mistyped or otherwise incorrect numbers.

This task has real life applications. In my professional career as a contractor for a tier-one cell phone operator for 26 years, I implemented the Luhn algorithm at least three times (in three different programming languages, including Perl, but I no longer have the code developed then, so I had to re-implement it from scratch for this task). In the mobile phone industry, the Luhn formula is used for validating at least two identification numbers: the International Mobile Equipment Identity (IMEI), an identifier for the phone itself, and the Integrated Circuit Card Identifier (ICCID) for the SIM card (or eSIM profile).

The algorithm described above can be simplified. Rather than performing the calculations on the identification number without the trailing check digit, we can do it directly on the whole number (with the check digit). This modified algorithm goes as follows:

• Reverse the order of the digits in the number.

• Take the second, fourth ... and every other even digit in the reversed digits, multiply them by two and sum the digits if the answer is greater than nine.

• Add all the digits; if the sum is a multiple of 10 (ends in zero), then the original number is a valid identification number.

Luhn’s Algorithm in Raku

This program implements the modified algorithm described just above. First, the program uses a regex to remove characters that are not digits from the input string. Then it reverses the resulting string, using the flip method, and splitted into an array of individual characters (@digits), using the comb method. Then, it multiplies by 2 the values of @digits with and even index, and sums the digits of the resulting number (using a comb and sum combination. Finally, the original number is validl if the sum of all digits can be evenly divided by 10.

sub luhn ($in is copy) {
    $in ~~ s:g/\D+//;  # remove non-digits
    my @digits = $in.flip.comb;  # reverse and split
    for 0..@digits.end -> $i {
        # values for even indices don't change
        @digits[$i] = (2 * @digits[$i]).comb.sum unless $i %% 2;
    }
    return @digits.sum %% 10; # valid if sum end with a 0
}

for "17893729974", "178az93r729974", "178 9372 9 9  74",
    "4137 8947 1175 5904", "4137 8974 1175 5904" -> $test {
    printf "%-25s => ", $test;
    say luhn $test;
}

This program displays the following output:

$ raku ./luhn.raku
17893729974               => True
178az93r729974            => True
178 9372 9 9  74          => True
4137 8947 1175 5904       => True
4137 8974 1175 5904       => False

Luhn’s Algorithm in Perl

This is a port to Perl of the above Raku program. Please refer to the previous sections if you need explanations. The comb built-in is replaced by split and we implemented our own sum and sum_digits auxiliary subroutines.

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

sub sum {
    my $sum = 0;
    for my $n (@_) {
        $sum += $n;
    }
    return $sum;
}
sub sum_digits {
    return sum split //, shift;
}

sub luhn {
    my $in = shift;
    $in =~ s/\D+//g;             # remove non-digits
    my @digits = reverse split //, $in; # reverse and split
    for my $i (0..$#digits) {
        next unless $i % 2;   #skip even indices
        my $val = 2 * $digits[$i];
        $digits[$i] = sum_digits $val;
    }
    # valid luhn if sum ends with a 0 (multiple of 10)
    return (sum @digits) % 10 == 0 ? "True" : "False"; 
}

for my $test ("17893729974", "178a93r729974", "178 9372 9 9 74",
    "4137 8947 1175 5904", "4137 8974 1175 5904") {
    printf "%-25s => ", $test;
    say luhn $test;
}

This program displays the following output:

$ perl  ./luhn.pl
17893729974               => True
178a93r729974             => True
178 9372 9 9 74           => True
4137 8947 1175 5904       => True
4137 8974 1175 5904       => False

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

These are some answers to the Week 289, 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 October 6, 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: Jumbled Letters

An Internet legend dating back to at least 2001 goes something like this:

Aoccdrnig to a rscheearch at Cmabrigde Uinervtisy, it deosn't mttaer in waht oredr the ltteers in a wrod are, the olny iprmoetnt tihng is taht the frist and lsat ltteer be at the rghit pclae. The rset can be a toatl mses and you can sitll raed it wouthit porbelm. Tihs is bcuseae the huamn mnid deos not raed ervey lteter by istlef, but the wrod as a wlohe.

This supposed Cambridge research is unfortunately an urban legend. However, the effect has been studied. For example—and with a title that probably made the journal’s editor a little nervous—Raeding wrods with jubmled lettres: there is a cost by Rayner, White, et. al. looked at reading speed and comprehension of jumbled text.

Your task is to write a program that takes English text as its input and outputs a jumbled version as follows:

1. The first and last letter of every word must stay the same
2. The remaining letters in the word are scrambled in a random order (if that happens to be the original order, that is OK).
3. Whitespace, punctuation, and capitalization must stay the same
4. The order of words does not change, only the letters inside the word

So, for example, “Perl” could become “Prel”, or stay as “Perl,” but it could not become “Pelr” or “lreP”.

I don’t know if this effect has been studied in other languages besides English, but please consider sharing your results if you try!

For this task, I will look for punctuation marks at the end of words. If a non-alphanumeric character occurs in the middle of a word (such as an apostrophe as in "don't" or a dash), I'll consider it as an ordinary letter subject to scrambling with other letters. It would not be difficult to consider these characters as punctuation marks and keep them in place, if we wanted it this way.

Jumbled Letters in Raku

First, we split the input string into words, using the words method. Then, we split each words into individual characters. If the word ends with a punctuation mark, we set it aside (in the $punctuation variable) and remove it from our list of letters. Then, we scramble the inner letters using the pick method on a slice of the letter array. With a parameter * (or a number greater than or equal to the size of the invocant list), pick returns the elements of the invocant list shuffled. Then we replace the original array slice with the shuffled items. Finally, we add the word to the @out array. Finally, once we have processed all words of the input string, we return a string joining all the words of the @out array.

sub jumble-letters ($in) {
    my @out;
    for $in.words -> $word {
        my @letters = $word.comb;
        my $punctuation = "";
        $punctuation = @letters.pop if $word ~~ /.*\W$/;
        @letters[1..*-2] = @letters[1..*-2].pick: *;
        my $out-word = (join "", @letters) ~ $punctuation;
        push @out, $out-word;
    }
    return join " ", @out;
}

my @tests = "Ask not what your country can do for you, ask what you can do for your country", 
            "I have a dream that one day this nation will rise up and live out the true meaning of its creed.",
            "The greatest thing you will ever learn is just to love and be loved in return.";
for @tests -> $test {
    say $test;
    say jumble-letters $test;
    say "";
}

This program displays the following output:

$ raku ./jumble-letters.raku
Ask not what your country can do for you, ask what you can do for your country
Ask not waht your coturny can do for you, ask waht you can do for your ctnruoy

I have a dream that one day this nation will rise up and live out the true meaning of its creed.
I hvae a draem that one day tihs naotin will rsie up and lvie out the true mannieg of its ceerd.

The greatest thing you will ever learn is just to love and be loved in return.
The geastret tihng you wlil ever lrean is jsut to lvoe and be leovd in ruretn.

We can observe that the first test case (quote from JFK) is made mostly of short words which undergo no or little changes, and its result is therefore quite readable. In the two other cases (sentences by Martin Luther King and Nat King Cole) which contain more longer words, the output is quite difficult to read.

Jumbled Letters in Perl

This is a port to Perl of the above Raku program. Please read the program description in the section above if you need further explanations. Since Perl doesn't have a pick built-in, we use a while loop to manually select random letters from the input list. I don't know if this is a good random shuffling, but I don't really care, as we don't need strong randomness (this is not cryptography).

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

sub jumble_letters {
    my $in = shift;
    my @out;
    for my $word (split /\s+/, $in) {
        my @letters = split //, $word;
        my $punctuation = "";
        $punctuation = pop @letters if $word =~ /.*\W$/;
        my @inner_letters = @letters[1..$#letters-1];
        my @scrambled;
        while (@inner_letters) {
            my $index = int rand scalar @inner_letters;
            push @scrambled, $inner_letters[$index];
            splice @inner_letters, $index, 1;  
        }
        @letters[1..$#letters-1] = @scrambled;
        my $out_word = (join "", @letters) . $punctuation;
        push @out, $out_word;
    }
    return join " ", @out;
}

my @tests = ( "Ask not what your country can do for you, ask what you can do for your country", 
              "I have a dream that one day this nation will rise up and live out the true meaning of its creed.",
              "The greatest thing you will ever learn is just to love and be loved in return.");
for my $test (@tests) {
    say $test;
    say jumble_letters $test;
    say "";
}

This program displays the following output:

$ perl ./jumble-letters.pl
Ask not what your country can do for you, ask what you can do for your country
Ask not waht yuor cnrtuoy can do for you, ask waht you can do for your cornuty

I have a dream that one day this nation will rise up and live out the true meaning of its creed.
I hvae a daerm that one day tihs ntoain wlil rise up and live out the true mneanig of its cered.

The greatest thing you will ever learn is just to love and be loved in return.
The getsaert tihng you will eevr learn is jsut to love and be loevd in rrtuen.

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

These are some answers to the Week 289, 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 October 6, 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: Third Maximum

You are given an array of integers, @ints.

Write a script to find the third distinct maximum in the given array. If third maximum doesn’t exist then return the maximum number.

Example 1

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

The first distinct maximum is 6.
The second distinct maximum is 5.
The third distinct maximum is 4.

Example 2

Input: @ints = (4, 5)
Output: 5

In the given array, the third maximum doesn't exist therefore returns the maximum.

Example 3

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

The first distinct maximum is 3.
The second distinct maximum is 2.
The third distinct maximum is 1.

There are several possible interpretations to the word "distinct" in the task specification. I understand that each value should be used only once to figure out the third maximum value. Therefore, the first step in our program will be to remove duplicates from the input list.

Third Maximum in Raku

Our program uses the unique, sort and reverse to remove duplicates and obtain the input list sorted in descending order. Then, we return the third item (subscript 2) if it exists, otherwise return the first element.

sub third-max (@in) {
    my @sorted = @in.unique.sort.reverse;   
    return @sorted[2]:exists ?? @sorted[2] !! @sorted[0];
}

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

This program displays the following output:

$ raku ./third-maximum.raku
5 6 4 1    => 4
4 5        => 5
1 2 2 3    => 1

Third Maximum in Perl

This is a port to Perl of the above Raku program. In Perl, the easiest way to remove duplicates is to store the values in a hash (here, %unique) and then to retrieve the keys. Note that we have to specify a numeric sort (with the <=> operator) and, since we do that, we can put the parameters $a and $b in reverse order in order to obtain directly a descending order, without using a reverse.

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

sub third_max {
    my %unique = map { $_ => 1 } @_;    
    my @sorted = sort { $b <=> $a } keys %unique;
    return exists $sorted[2] ? $sorted[2] : $sorted[0];
}

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

This program displays the following output:

$ perl third-maximum.pl
5 6 4 1    => 4
4 5        => 5
1 2 2 3    => 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 October 13, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 288, 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 September 29, 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: Closest Palindrome

You are given a string, $str, which is an integer.

Write a script to find out the closest palindrome, not including itself. If there are more than one then return the smallest.

The closest is defined as the absolute difference minimized between two integers.

Example 1

Input: $str = "123"
Output: "121"

Example 2

Input: $str = "2"
Output: "1"

There are two closest palindrome "1" and "3". Therefore we return the smallest "1".

Example 3

Input: $str = "1400"
Output: "1441"

Example 4

Input: $str = "1001"
Output: "999"

Closest Palindrome in Raku

To find if a number is a palindrome, we simply flip it and check whether the result is equal to the original number. We start with a gap equal to 1, and check whether the original number minus the gap is a palindrome or whether the original number plus the gap is a palindrome. If any is a palindrome, we return it to the caller. If not, we continue with a gap of 2, and then 3, 4, etc.

sub closest-palindrome ($in) {
    for 1..Inf -> $i {
        return $in - $i if ($in - $i).flip eq $in - $i;
        return $in + $i if ($in + $i).flip eq $in + $i;
    }
}

my @tests = 123, 2, 1400, 1001;
for @tests -> $test {
    printf "%-6d => ", $test;
    say closest-palindrome $test;
}

This program displays the following output:

$ raku ./closest-palindrome.raku
123    => 121
2      => 1
1400   => 1441
1001   => 999

Closest Palindrome in Raku

This is a port to Perl of the above Raku program. Please see the previous section if you need further explanation. The equivalent of flip in Perl is reverse (in scalar context).

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

sub closest_palindrome {
    my $in = shift;
    my $i = 1;
    while (1) {
        return $in - $i if reverse($in - $i) eq $in - $i;
        return $in + $i if reverse($in + $i) eq $in + $i;
        $i++;
    }
}

my @tests = (123, 2, 1400, 1001);
for my $test (@tests) {
    printf "%-6d => ", $test;
    say closest_palindrome $test;
}

This program displays the following output:

$ perl ./closest-palindrome.pl
123    => 121
2      => 1
1400   => 1441
1001   => 999

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