Perl Weekly Challenge 293: Similar Dominoes

These are some answers to the Week 293, 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 November 3, 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:

You are given a list of dominoes, @dominoes.

Write a script to return the number of dominoes that are similar to any other domino.

$dominoes[i] = [a, b] and $dominoes[j] = [c, d] are same if either (a = c and b = d) or (a = d and b = c).

Example 1

Input: @dominoes = ([1, 3], [3, 1], [2, 4], [6, 8])
Output: 2

Similar Dominoes: $dominoes[0], $dominoes[1]

Example 2

Input: @dominoes = ([1, 2], [2, 1], [1, 1], [1, 2], [2, 2])
Output: 3

Similar Dominoes: $dominoes[0], $dominoes[1], $dominoes[3]

First, I would say that dominoes (1, 3) and (3,1) are not really similar, they are equal, they are the same domino seen from a different angle.

Then we are not said what to do when you have for example dominoes (1, 3), (3,1), (2,4) and (4,2), i.e. two pairs of "similar" dominoes. And the examples provided don't clarify this case. I'll consider that, in that case, we have 4 similar dominoes, even if they are similar two by two.

To make things simple, I've chosen to represent dominoes as simple strings: rather than having a pair of integers such as (3,1), I'll use the string "31". Common domino sets have square ends with 0 (blank) to 6 spots. So this representation is sufficient and not ambiguous. There are, however, some extended domino sets with square ends having more than 6 spots. In the event that there are more than 9 spots (I've never seen that, but it could happen), we would need to change an input tile representation to a string with a separator, for example 11-13, and slightly modify the sort-dom subroutine accordingly (but the change is really simple).

Similar Dominoes in Raku

The first thing this program does is to "normalize" tiles, i.e. reorganize them so that the tiles square ends always appear in ascending order (done by the sort-dom subroutine). Once this is done, we simply need to count the dominoes of each type (done in the $histo histogram) and finally count the histogram values greater than 1. The $histo data structure is a Bag, i.e. an immutable collection of distinct objects with integer weights.

sub sort-dom ($dom) {
    my ($a, $b) = $dom.comb;
    return $a < $b ?? "$a$b" !! "$b$a";
}

sub similar-dom (@doms) {
    my $histo = bag map { sort-dom $_ }, @doms;
    my $count = 0;
    $count += $_ for grep { $_ > 1 }, $histo.values;
    return $count;
}

my @tests = <13 31 24 68>, <12 21 11 12 22>, <31 24 13 56 24>;
for @tests -> @test {
    printf "%-15s => ", "@test[]";
    say similar-dom @test;
}

This program displays the following output:

$ raku ./similar-dominoes.raku
13 31 24 68     => 2
12 21 11 12 22  => 3
31 24 13 56 24  => 4

Similar Dominoes in Perl

This is a port to Perl of the above Raku program. The only significant difference is that it uses a hash instead of a Bag. Please refer to the above two sections if you need explanations.

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

sub sort_dom  {
    my $dom = shift;
    my ($a, $b) = split //, $dom;
    return $a < $b ? $dom : "$b$a";
}

sub similar_dom {
    my %histo;  
    $histo{$_}++ for map { sort_dom $_ } @_;
    my $count = 0;
    $count += $_ for grep { $_ > 1 } values %histo;
    return $count;
}

my @tests = ( [<13 31 24 68>], [<12 21 11 12 22>], 
                [<31 24 13 56 24>] );
for my $test (@tests) {
    printf "%-15s => ", "@$test";
    say similar_dom @$test;
}

This program displays the following output:

$ perl ./similar-dominoes.pl
13 31 24 68     => 2
12 21 11 12 22  => 3
31 24 13 56 24  => 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 November 10, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

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.