October 2024 Archives

Perl Weekly Challenge 292: Twice Largest

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

Task 1: Twice Largest

You are given an array of integers, @ints, where the largest integer is unique.

Write a script to find whether the largest element in the array is at least twice as big as every element in the given array. If it is return the index of the largest element or return -1 otherwise.

Example 1

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

The largest integer is 4.
For every other elements in the given array is at least twice as big.
The index value of 4 is 1.

Example 2

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

The largest integer is 4.
4 is less than twice the value of 3, so we return -1.

My first comment is that we don't really know what to do with negative integers, especially if all input values are negative. We will assume that exactly the same rules apply for negative values (an array with only negative values will always qualify because when you double a negative value, it becomes smaller, not larger), or that the input array will contain only non-negative values.

There is no other solution than to check (even if implicitly, say with a sort) each number of the input array. The only very slight difficulty is that we should not compare the greatest number in the input array with twice its value, because it would always fail (except if the greatest integer is 0, but that's an edge case).

Twice Largest in Raku

Once we have integrated the considerations in the previous section (please read them if you didn't), the solution is straight forward. I was initially hoping to use a junction, probably an any or none junction, but the fact that we need to exclude the largest item from the comparison makes it slightly more complicated and less efficient (since we would have to visit each input value once more). So, I used a simple loop. Thinking again about it afterward, I came to the conclusion that using a one junction might have avoided the need for an extra loop: if there is one (and only one) value whose double is larger than the greatest integer, then our input array almost certainly satisfies the task's conditions (at least with positive input values). Testing that alternate solution is left as an exercise for the reader.

sub twice-larger (@in) {d for an extra loop. 
    my ($max-i, $largest) = @in.max(:kv);
    for @in -> $i {
        next if $i == $largest;
        return -1 if 2 * $i > $largest;
    }
    return $max-i;
}
for (2, 4, 1, 0), (1, 2, 3, 4), (4, 3, 5, 12, 2) -> @test {
    printf "%-12s => ", "@test[]";
    say twice-larger @test;
}

This program displays the following output:

$ raku ./twice-largest.raku
2 4 1 0      => 1
1 2 3 4      => -1
4 3 5 12 2   => 3

Twice Largest in Perl

This program is essentially a port to Perl of the above Raku program. Please refer to the previous sections if you need explanations. Since Perl doesn't have junctions, we need to use a loop over the input values, just as we did in Raku. Note that we had to implement a max auxiliary subroutine, since there is no built-in function to do that (which is no problem, as it is very simple and worked fine straight out of the box).

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

sub max {
    my $max = shift;
    for (@_) {
        $max = $_ if $_ > $max;
    }
    return $max;
}

sub twice_larger {
    my $largest = max @_;
    my $max_i;
    for my $i (0..$#_){
        my $val = $_[$i];
        if ($val == $largest) {
            $max_i = $i;
            next;
        }
        return -1 if 2 * $val > $largest;
    }
    return $max_i;
}
for my $test ([2, 4, 1, 0], [1, 2, 3, 4], [4, 3, 5, 12, 2]) {
    printf "%-12s => ", "@$test";
    say twice_larger @$test;
}

This program displays the following output:

$ perl ./twice-largest.pl
2 4 1 0      => 1
1 2 3 4      => -1
4 3 5 12 2   => 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 November 3, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

Perl Weekly Challenge 291: Poker Hand Rankings

These are some answers to the Week 291, 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 20, 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: Poker Hand Rankings

A draw poker hand consists of 5 cards, drawn from a pack of 52: no jokers, no wild cards. An ace can rank either high or low.

Write a script to determine the following three things:

1. How many different 5-card hands can be dealt?

2. How many different hands of each of the 10 ranks can be dealt? See here for descriptions of the 10 ranks of Poker hands: https://en.wikipedia.org/wiki/List_of_poker_hands#Hand-ranking_categories

3. Check then the numbers you get in step 2 by adding them together and showing that they're equal to the number you get in step 1.

We need a subroutine (com) for computing the binomial coefficient formula for: n choose k. The simplest formula is: n! / k! (n - k)! But this leads to compute very large numbers that we then divide by other very large numbers. For example, 52! has 68 digits: 52! = 80658175170943878571660636856403766975289505440883277824000000000000. So I prefer to use a formula that considerably simplifies the fraction: n * (n - 1) * ... * (n - k + 1) / k!.
This ought to be faster, but that's not the point, since it is quite fast anyway; the point is that we avoid the risk of integer overflow during intermediate computations. There is no such risk in Raku, and probably also not in Perl, but there are many languages or programming environments that can't handle integers with 68 digits.

Poker Hand Rankings in Raku

See the previous section above for explanations on the com auxiliary subroutine, which really does the bulk of the work.

The poker-hands does only one thing: it populates a hash with the various hand types and their frequencies. This Wikipedia page provides a table with the mathematical expression of the absolute frequency of each hand type. The code did not really need a separate subroutine and could have been inserted in the main code, but I find it clearer this way, in a separate subroutine.

The rest of the program basically displays the hash in a form hopefully readable to the human eye.

sub com ($n, $k) {
    # Binomial coefficient formula for: n choose k
    my $nr_of_com = ([*] ($n - $k + 1)..$n)/([*] 1..$k); 
    return $nr_of_com;
}

sub poker-hands (){
    my %hands =
        "0. RF" => com(4, 1),  # Royal flush 
        "1. SF" => com(10, 1) * com(4, 1) - com(4, 1),
                               # Straight flush
        "2. FK" => com(13, 1) * com(12, 1) * com(4, 1),
                               # Four of a kind
        "3. FH" => com(13, 1) * com(4, 3) * com(12, 1)
            * com(4, 2),       # Full house
        "4. Fl" => com(13, 5) * com(4, 1) - com(10, 1)
            * com(4, 1),       # Flush (excl. RF and SF)
        "5. St" => com(10, 1) * com(4, 1)**5 - com(10, 1)
            * com(4, 1),       # Straight (excl. RF and SF)
        "6. TK" => com(13, 1) * com(4, 3) * com(12, 2)
            * com(4, 1) ** 2,  # Three of a kind
        "7. TP" => com(13, 2) * com(4, 2)**2 *com(11, 1) 
            * com(4, 1),       # Two pairs
        "8. OP" => com(13, 1) * com(4, 2) * com(12, 3)
            * com(4, 1)**3,    # One pair
        "9. NP" => (com(13, 5) - com(10,1)) * (com(4, 1)**5
            - com(4, 1)),      # No pair (or High card)
    ;
    return %hands;
}

my %hand-count = poker-hands;
my $num-hands = com 52, 5;
say "Total number of hands (direct count) => $num-hands";

for %hand-count.keys.sort -> $key {
    say "  - $key => ", %hand-count{$key};
}
say "Sum of the hands by type => ", [+] %hand-count.values;

This program displays the following output:

    $ raku ./poker-hands.raku
    Total number of hands (direct count) => 2598960
      - 0. RF => 4
      - 1. SF => 36
      - 2. FK => 624
      - 3. FH => 3744
      - 4. Fl => 5108
      - 5. St => 10200
      - 6. TK => 54912
      - 7. TP => 123552
      - 8. OP => 1098240
      - 9. NP => 1302540
    Sum of the hands by type => 2598960

Poker Hand Rankings in Perl

This program is essentially a port to Perl of the above Raku program. Please refer to the previous sections if you need explanations.

There is one important change, though: rather than using hand abbreviations (RF, SF, FK, etc.) for the hash keys, it uses hand full name (Royal flush, Straight flush, Four of a kind, etc.), leading to more explicit output.

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

sub com  {
    # Binomial coefficient formula for: n choose k
    my ($n, $k) = @_;
    my $fact_k = 1;
    $fact_k *= $_ for 1..$k;
    my $nr_of_com_numerator = 1;
    $nr_of_com_numerator *= $_ for ($n -$k + 1)..$n;
    return $nr_of_com_numerator/ $fact_k;
}

sub poker_hands {
    my %hands =
       ("0. Royal flush" => com(4, 1),
        "1. Straight flush" => com(10, 1) * com(4, 1) 
            - com(4, 1),
        "2. Four of a kind" => com(13, 1) * com(12, 1) 
            * com(4, 1),
        "3. Full house" => com(13, 1) * com(4, 3) 
            * com(12, 1) * com(4, 2), 
        "4. Flush" => com(13, 5) * com(4, 1) - com(10, 1)
            * com(4, 1),       # Flush (excl. RF and SF)
        "5. Straight" => com(10, 1) * com(4, 1)**5 - com(10, 1)
            * com(4, 1),       # Straight (excl. RF and SF)
        "6. Three of a kind" => com(13, 1) * com(4, 3) 
            * com(12, 2) * com(4, 1) ** 2,
        "7. Two pairs" => com(13, 2) * com(4, 2)**2 
            * com(11, 1) * com(4, 1), 
        "8. One pair" => com(13, 1) * com(4, 2) * com(12, 3)
            * com(4, 1)**3,    # 
        "9. No pair" => (com(13, 5) - com(10,1)) 
            * (com(4, 1)**5 - com(4, 1)),      
            # No pair or High card
    );
    return %hands;
}

my %hand_count = poker_hands;
my $num_hands = com 52, 5;
say "Total number of hands (direct count) => $num_hands";

for my $key (sort keys %hand_count) {
    printf "  - %-20s => %-10i \n", $key, $hand_count{$key};
}
my $sum = 0;
$sum += $_ for values %hand_count;
say "Sum of the hands by type => ", $sum

This program displays the following output:

    $ perl ./poker-hands.pl
    Total number of hands (direct count) => 2598960
      - 0. Royal flush       => 4
      - 1. Straight flush    => 36
      - 2. Four of a kind    => 624
      - 3. Full house        => 3744
      - 4. Flush             => 5108
      - 5. Straight          => 10200
      - 6. Three of a kind   => 54912
      - 7. Two pairs         => 123552
      - 8. One pair          => 1098240
      - 9. No pair           => 1302540
    Sum of the hands by type => 2598960

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

Perl Weekly Challenge 291: Middle Index

These are some answers to the Week 291, 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 20, 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: Middle Index

You are given an array of integers, @ints.

Write a script to find the leftmost middle index (MI) i.e. the smallest amongst all the possible ones.

A middle index is an index where ints[0] + ints[1] + … + ints[MI-1] == ints[MI+1] + ints[MI+2] + … + ints[ints.length-1].

If MI == 0, the left side sum is considered to be 0. Similarly, if MI == ints.length - 1, the right side sum is considered to be 0.

Return the leftmost MI that satisfies the condition, or -1 if there is no such index.

Example 1

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

The sum of the numbers before index 3 is: 2 + 3 + -1 = 4
The sum of the numbers after index 3 is: 4 = 4

Example 2

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

The sum of the numbers before index 2 is: 1 + -1 = 0
The sum of the numbers after index 2 is: 0

Example 3

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

There is no valid MI.

I first thought of starting from both ends of the array and working inwards progressively to try to find "the man in the middle", something similar to what is done in a bisection algorithm. But that doesn't work because the input values are not sorted, or, at least, it would lead to too many complicated and time-consuming edge cases.

So we decided to use a "brute force" approach, i.e. we try every possible index from 0 to the last (from left to right) and check if it is a middle index. And we stop as soon as we find one.

Middle Index in Raku

We loop over the input array indexes and check and check whether the index qualifies as a middle index. Note that, for the sake of simplicity, the program doesn't check whether:

ints[0] + ints[1] + … + ints[MI-1] == ints[MI+1] + ints[MI+2] + … + ints[ints.length-1]

but rather whether:

ints[0] + ints[1] + … + ints[MI] == ints[MI] + ints[MI+2] + … + ints[ints.length-1],

which is equivalent and slightly simpler.

sub middle-index (@in) {
    return $_ if @in[0..$_].sum == @in[$_..@in.end].sum 
        for 0..@in.end;
    return -1;
}
my @tests = (2, 3, -1, 8, 4), (1, -1, 4), (2, 5);
for @tests -> @test {
    printf "%-12s => ", "@test[]";
    say middle-index @test;
}

This program displays the following output:

$ raku ./middle-index.raku
2 3 -1 8 4   => 3
1 -1 4       => 2
2 5          => -1

Middle Index in Perl

This is a port to Perl of the above Raku program. Please refer to the above two sections if you need further explanations. The only significant change is that I had to implement a sum subroutine since it is not natively built in Perl (although I admit there are some modules doing that, but I consider that using off-the-shelf modules is not proper conduct in a coding challenge).

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

sub sum {
    my $sum = 0;
    $sum += $_ for @_;
    return $sum;
}

sub middle_index {
    for my $i (0..$#_) {
        return $i if sum(@_[0..$i]) == sum(@_[$i..$#_]);
    }
    return -1;
}
my @tests = ( [2, 3, -1, 8, 4], [1, -1, 4], [2, 5]);
for my $test (@tests) {
    printf "%-12s => ", "@$test";
    say middle_index @$test;
}

This program displays the following output:

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

Perl Weekly Challenge 290: Double Exist

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.

Perl Weekly Challenge 290: Luhn's Algorithm

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.

Perl Weekly Challenge 289: Jumbled Letters

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.

Perl Weekly Challenge 289: Third Maximum

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.

About laurent_r

user-pic I am the author of the "Think Perl 6" book (O'Reilly, 2017) and I blog about the Perl 5 and Raku programming languages.