These are some answers to the Week 284, 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 September 1, 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: Relative Sort

You are given two list of integers, @list1 and @list2. The elements in the @list2 are distinct and also in the @list1.

Write a script to sort the elements in the @list1 such that the relative order of items in @list1 is same as in the @list2. Elements that is missing in @list2 should be placed at the end of @list1 in ascending order.

Example 1

Input: @list1 = (2, 3, 9, 3, 1, 4, 6, 7, 2, 8, 5)
       @list2 = (2, 1, 4, 3, 5, 6)
Ouput: (2, 2, 1, 4, 3, 3, 5, 6, 7, 8, 9)

Example 2

Input: @list1 = (3, 3, 4, 6, 2, 4, 2, 1, 3)
       @list2 = (1, 3, 2)
Ouput: (1, 3, 3, 3, 2, 2, 4, 4, 6)

Example 3

Input: @list1 = (3, 0, 5, 0, 2, 1, 4, 1, 1)
       @list2 = (1, 0, 3, 2)
Ouput: (1, 1, 1, 0, 0, 3, 2, 4, 5)

Relative Sort in Raku

Instead of sorting @list1 in accordance with the order of @list2, we will duplicate @list2 with each item of @list2 being repeated the number of times it occurs un @list1. At the end, we append to the resulting list the items (sorted in ascending order) of @list1 not used previously.

We first need to create an histogram of frequencies of @list1, which can be easily done with Bag, as we've done previously (for example in the lucky number task of this week's challenge. The only slight problem is that we also want to use this histogram data structure to track the items that we have already used and know which items are left. A Bag is immutable, so we will use its mutable variant, a BagHash instead. So, once we use an item, we set its frequency to 0 and the item is automatically removed from the BagHash.

Note that, although we are told that the elements of @list2 are all in @list1, we nonetheless check to avoid an exception, but don't do anything about it (we don't know what should be done) and let the program run to its end. Also note that we print out only @list2 with the results, for space reasons.

sub relative-sort (@in1, @in2) {
    my @result;
    my $to-be-sorted = @in1.BagHash;
    for @in2 -> $i {
        if $to-be-sorted{$i}:exists {
            append @result, $i xx $to-be-sorted{$i};
            $to-be-sorted{$i} = 0;
        }
    }
    append @result, (map { $_ xx $to-be-sorted{$_}}, $to-be-sorted.keys).sort;
    return "@result[]";
}

my @tests = ((2, 3, 9, 3, 1, 4, 6, 7, 2, 8, 5), (2, 1, 4, 3, 5, 6)),
            ((3, 3, 4, 6, 2, 4, 2, 1, 3), (1, 3, 2)),
            ((3, 0, 5, 0, 2, 1, 4, 1, 1), (1, 0, 3, 2));
for @tests -> @test {
    printf "%-15s => ", "@test[1]";
    say relative-sort @test[0], @test[1];
}

This program displays the following output:

$ raku ./relative-sort.raku
2 1 4 3 5 6     => 2 2 1 4 3 3 5 6 7 8 9
1 3 2           => 1 3 3 3 2 2 4 4 6
1 0 3 2         => 1 1 1 0 0 3 2 4 5

Relative Sort in Perl

This is a port to Perl of the above Raku program. Please refer to the previous section if you need explanations. Instead of a BagHash, we use in Perl a regular hash.

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

sub relative_sort {
    my ($in1, $in2) = @_;
    my @result;
    my %unsorted;
    $unsorted{$_}++ for @$in1;
    for my $i (@$in2) {
        if (exists $unsorted{$i}) {
            push @result, ($i) x $unsorted{$i};
            $unsorted{$i} = 0;
        }
    }
    push @result, sort map { ($_) x $unsorted{$_}} 
        grep { $unsorted{$_} > 0 } keys %unsorted;
    return "@result";
}

my @tests = ( [[2, 3, 9, 3, 1, 4, 6, 7, 2, 8, 5], [2, 1, 4, 3, 5, 6]],
              [[3, 3, 4, 6, 2, 4, 2, 1, 3], [1, 3, 2]],
              [[3, 0, 5, 0, 2, 1, 4, 1, 1], [1, 0, 3, 2]] );
for my $test (@tests) {
    printf "%-15s => ", "@{$test->[1]}";
    say relative_sort @$test[0], @$test[1];
}

This program displays the following output:

$ perl  ./relative-sort.pl
2 1 4 3 5 6     => 2 2 1 4 3 3 5 6 7 8 9
1 3 2           => 1 3 3 3 2 2 4 4 6
1 0 3 2         => 1 1 1 0 0 3 2 4 5

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on September 9, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 284, 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 1, 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: Lucky Integer

You are given an array of integers, @ints.

Write a script to find the lucky integer if found otherwise return -1. If there are more than one then return the largest.

A lucky integer is an integer that has a frequency in the array equal to its value.

Example 1

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

Example 2

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

Example 3

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

We will assume that the input array contains only strictly positive integers, as in the examples provided. Negative numbers would not make sense in the context, as a negative frequency is impossible.

Lucky Integer in Raku

Once again, we use a Bag to create the $count histogram of frequencies. Then, we create an array of items whose count is equal to the key value. And we return -1 if none was found, and the max value otherwise.

sub lucky-integer (@in) {
    my $count = @in.Bag;
    my @lucky = grep { $_ == $count{$_} }, $count.keys;
    return -1 if @lucky.elems == 0;
    return @lucky.max;
}

my @tests = <2 2 3 4>, <1 2 2 3 3 3>, <1 1 1 3>;
for @tests -> @test {
    printf "%-12s => ", "@test[]";
    say lucky-integer @test;
}

This program displays the following output:

$ raku ./lucky-integer.raku
2 2 3 4      => 2
1 2 2 3 3 3  => 3
1 1 1 3      => -1

Lucky Integer in Perl

This is a port to Perl of the above Raku program. Note that we use a hash (%count) instead of a Bag to host the histogram of frequencies. We also need a loop to find maximum value in the @lucky array.

sub lucky_integer {
    my %count;
    $count{$_}++ for @_;
    my @lucky = grep { $_ == $count{$_} } keys %count;
    return -1 if $#lucky == 0;
    my $max = shift @lucky;
    for my $i (@lucky) {
        $max = $i if $i > $max;
    }
    return $max;
}

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

This program displays the following output:

$ raku ./lucky-integer.raku
2 2 3 4      => 2
1 2 2 3 3 3  => 3
1 1 1 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 September 9, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 283, Task 2, of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: 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: Digit Count Value

You are given an array of positive integers, @ints.

Write a script to return true if for every index i in the range 0 <= i < size of array, the digit i occurs exactly the $ints[$i] times in the given array otherwise return false.

Example 1

Input: @ints = (1, 2, 1, 0)
Ouput: true

$ints[0] = 1, the digit 0 occurs exactly 1 time.
$ints[1] = 2, the digit 1 occurs exactly 2 times.
$ints[2] = 1, the digit 2 occurs exactly 1 time.
$ints[3] = 0, the digit 3 occurs 0 time.

Example 2

Input: @ints = (0, 3, 0)
Ouput: false

$ints[0] = 0, the digit 0 occurs 2 times rather than 0 time.
$ints[1] = 3, the digit 1 occurs 0 time rather than 3 times.
$ints[2] = 0, the digit 2 occurs exactly 0 time.

Digit Count Value in Raku

We first use a Bag to create the count histogram of frequencies. For some obscure reason, I wasn't able to use the bag directly (as I did for task 1 of this same challenge), and has to coerce the bag into a hash. Then, we check for each index in the array range that the input value matches the count. Actually, we return False if it doesn't match, and return True at the end of the loop if we reach there.

sub digit-count-value (@in) {
    my %count = @in.Bag;
    for 0..@in.end -> $i {
        return False if %count{$i}:exists and 
            @in[$i] != %count{$i};
    }
    return True;
}

my @tests = <1 2 1 0>, <0 3 0>; 
for @tests -> @test {
    printf "%-8s => ", "@test[]";
    say digit-count-value @test;
}

This program displays the following output:

$ raku ./digit-count-value.raku
1 2 1 0  => True
0 3 0    => False

Digit Count Value in Perl

This is a port to Perl of the above Raku program. Note that we use a hash (%count) to host the histogram of frequencies.

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

sub digit_count_value {
    my @in = @_;
    my %count;
    $count{$_}++ for @in;
    for my $i (0..$#in) {
        return "False" if exists $count{$i} and 
            $in[$i] != $count{$i};
    }
    return "True";
}

my @tests = ( [<1 2 1 0>], [<0 3 0>] ); 
for my $test (@tests) {
    printf "%-8s => ", "@$test";
    say digit_count_value @$test;
}

This program displays the following output:

$ perl ./digit-count-value.pl
1 2 1 0  => True
0 3 0    => 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 September 1, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 283, 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 25, 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: Unique Number

You are given an array of integers, @ints, where every element appears more than once except one element. ` Write a script to find the one element that appears exactly one time.

Example 1

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

Example 2

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

Example 3

Input: @ints = (1)
Output: 1

Example 4

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

We will assume that the input array of integers is valid in accordance with the specification above, i.e. that every element appears more than once except one element. Therefore, we will not try to validate the input array (although this would be quite easy).

Unique Number in Raku

We first use a Bag to create the count histogram of frequencies. Then we return the Bag's key for which the value is 1.

sub find-unique-number (@in) {
    my $count = @in.Bag;
    return (grep { $count{$_ } == 1}, $count.keys).first;
}

my @tests = <3 3 1>, <3 2 4 2 4>, (1,), <4 3 1 1 1 4>;
for @tests -> @test {
    printf "%-12s => ", "@test[]";
    say find-unique-number @test;
}

This program displays the following output:

$ raku ./unique-number.raku
3 3 1        => 1
3 2 4 2 4    => 3
1            => 1
4 3 1 1 1 4  => 3

Unique Number in Perl

This is a port to Perl of the above Raku program. Note that we use a hash (%count) instead of a Bag to host the histogram of frequencies.

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

sub find_unique_number {
    my %count;
    $count{$_}++ for @_;
    return (grep { $count{$_ } == 1} keys %count)[0];
}

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

This program displays the following output:

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

These are some answers to the Week 282, Task 2, of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on August 18, 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: Changing Keys

You are given an alphabetic string, $str, as typed by user.

Write a script to find the number of times user had to change the key to type the given string. Changing key is defined as using a key different from the last used key. The shift and caps lock keys won’t be counted.

Example 1

Input: $str = 'pPeERrLl'
Ouput: 3

p -> P : 0 key change
P -> e : 1 key change
e -> E : 0 key change
E -> R : 1 key change
R -> r : 0 key change
r -> L : 1 key change
L -> l : 0 key change

Example 2

Input: $str = 'rRr'
Ouput: 0

Example 3

Changing Key in Raku

We could probably use a regex to design a more concise solution, but I preferred the simplicity of a single loop through the input string's letters. We set the input string to lower case before splitting into individual characters. The only small gotcha is that, according to the examples, the first pressed key is not considered as a key change. So I decided to shift the first letter of the @letters array and use it to initialize the $old variable containing the previous key within the loop.

sub changing-key ($in) {
    my $count = 0;
    my @letters = $in.lc.comb;
    my $old = shift @letters;
    for @letters -> $let {
        $old = $let and $count++ if $let ne $old;
    }
    return $count;
}

my @tests = 'pPeERrLl', 'rRr', 'GoO';
for @tests -> $test {
    printf "%-10s => ", $test;
    say changing-key $test;
}

Note BTW that the person who typed in the input examples is apparently even more dyslexic than I am.

This program displays the following output:

$ raku ./changing-key.raku
pPeERrLl   => 3
rRr        => 0
GoO        => 1

Changing Key in Perl

This is a port to Perl of the previous Raku program. Please refer to the explanations above if needed.

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

sub changing_key {
    my $count = 0;
    my @letters = split //, lc shift;
    my $old = shift @letters;
    for my $let (@letters) {
        $old = $let and $count++ if $let ne $old;
    }
    return $count;
}

my @tests = ('pPeERrLl', 'rRr', 'GoO');
for my $test (@tests) {
    printf "%-10s => ", $test;
    say changing_key $test;
}

This program displays the following output:

$ perl  ./changing-key.pl
pPeERrLl   => 3
rRr        => 0
GoO        => 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 August 25, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 281, 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 18, 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: Good Integer

You are given a positive integer, $int, having 3 or more digits.

Write a script to return the Good Integer in the given integer or -1 if none found.

A good integer is exactly three consecutive matching digits.

Example 1

Input: $int = 12344456
Output: "444"

Example 2

Input: $int = 1233334
Output: -1

Example 3

Input: $int = 10020003
Output: "000"

Good Integer in Raku

I first tried with a single regex using lookaround assertions such as <!before $0> and <!after $O> to prevent matches when there is a sequence of more than 3 identical digits, but it appears that it is not possible to combine lookaround assertions with a previous captured match special variable ($0 or $/[0]), or, at least, that I did not find the proper syntax (but it seems to me that there are some good reasons for this not to be possible).

So I decided to simply use two successive regexes, one to exclude the cases with 4 (or more) identical digits, and the second one to match three identical digits.

sub good-integer ($in) {
    return -1 if $in ~~ / (\d) $0 ** 3 /;    # 4 digits
    return  ~$/ if $in ~~ / (\d) $0 ** 2 /;  # 3 digits
    return -1;
}

my @tests = 12344456, 123444456, 1233334, 10020003;
for @tests -> $test {
    printf "%-10s => ", $test;
    say good-integer $test;
}

This program displays the following output:

$ raku ./good-integer.raku
12344456   => 444
123444456  => -1
1233334    => -1
10020003   => 000

Good Integer in Perl

I suspect that Perl's look-ahead and look-behind assertions will have the same behavior as Raku's lookaround assertions. So, I used the same strategy as in Raku, and this is actually a port to Perl of the previous Raku program.

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

sub good_integer {
    my $in = shift;
    return -1 if $in =~ /(\d)\1{3}/;
    return  $1 x 3 if $in =~ /(\d)\1{2}/;
    return -1;
}

my @tests = (12344456, 123444456, 1233334, 10020003);
for my $test (@tests) {
    printf "%-10s => ", $test;
    say good_integer $test;
}

This program displays the following output:

$ perl ./good-integer.pl
12344456   => 444
123444456  => -1
1233334    => -1
10020003   => 000

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

These are some answers to the Week 281, Task 2, of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few days from now (on August 11, 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: Knight’s Move

A Knight in chess can move from its current position to any square two rows or columns plus one column or row away. So in the diagram below, if it starts a S, it can move to any of the squares marked E.

Write a script which takes a starting position and an ending position and calculates the least number of moves required.

Example 1

Input: $start = 'g2', $end = 'a8'
Ouput: 4

g2 -> e3 -> d5 -> c7 -> a8

Example 2

Input: $start = 'g2', $end = 'h2'
Ouput: 3

g2 -> e3 -> f1 -> h2

This is a classical computer science topic. In fact, I had to implement almost the same task in C and in Pascal as a homework exercise in the beginning of my CS studies many years ago. It is an opportunity to study and understand First-In First-Out (FIFO) data structures such as queues, as opposed to Last-in First Out (LIFO) data structures, aka stacks. It is also an occasion to work on Breadth-First Search (BFS) algorithms (as opposed to Depth-First Search (DFS) algorithms) for creating and traversing a tree.

BFS traverses a tree by visiting all possible moves level by level, so that as soon as we find a solution, we know it is the shortest path (or, rather, one of the shortest paths) and can stop iteration and return the level value. In DFS, by contrast, you would need to explore essentially all possible paths to make sure you've found the shortest one.

A final point before we go on: how do we model the chess board? I considered various solutions and decided to transform the chess notation a to h abscissas to a 0 to 7 range. For the ordinates, we subtract 1 to convert the 1 to 8 range to a 0 to 7 range. For example, the c2 square would be transformed to rectangular or Cartesian coordinates (2, 1). This conversion is performed by the to-coordinates subroutine.

Knight’s Move in Raku

The authorized moves for a knight are modeled by @moves, an array of eight pairs representing the values to be added to the coordinates of one square to find the next square.

The @to-be-explored array contains subarrays describing the next squares to be visited along with the level depth (i.e. the number of moves to reach this square). The @to-be-explored array is initialized with the starting position (and a depth of 0). The %seen hash contains the squares that have already been visited (we simply stringify the pair of coordinates to build the hash key). The %seen hash is also initialized with the starting position.

The process traverses the @to-be-explored array and return the depth if it is the target square. Otherwise, for each item, it computes the next position that would be reached with each of the eight possible moves. This next position is dismissed if it falls out of the chess board (unauthorized move) or if it has already been visited. Else, the next position is added to the %seen hash and to the @to-be-explored array.

my @moves = <2 1>, <2 -1>, <1 2>, <1 -2>, 
            <-1 2>, <-1 -2>, <-2 1>, <-2 -1>;

sub to-coordinates ($in) {
    my ($col, $row) = $in.comb;
    return $col.ord - 'a'.ord, $row - 1;
}

sub find-shortest ($st-in, $end-in) {
    # convert input to Cartesian coordinates
    my @start = to-coordinates $st-in;
    my @end = to-coordinates $end-in;

    my @to-be-explored;  # a queue of squares to be visited    
    push @to-be-explored, (0, @start).flat; 
    my %seen = "@start[]" => 1;  # already visited squares

    while @to-be-explored {
        my @node = shift @to-be-explored;
        my ($depth, @current) = @node[0];
        return $depth if "@current[]" eq "@end[]";
        for @moves -> @move {
            my @next = @current[0] + @move[0], 
                       @current[1] + @move[1];
            # dismiss if computed position not on chessboard
            next if @next.any > 7 or @next.any < 0;
            # dismiss if computed position already visited
            next if %seen{"@next[]"}:exists;
            # update seen hash and to-be-explored queue
            %seen{"@next[]"} = 1;
            push @to-be-explored, ($depth + 1, @next).flat;
        }
    }
}

my @tests = <g2 a8>, <g2 h2>;
for @tests -> @test {
    printf "%-6s => ", "@test[]"; 
    say find-shortest @test[0], @test[1];
}

This program displays the following output:

$ raku ./shortest-knight-path.raku
g2 a8  => 4
g2 h2  => 3

Knight’s Move in Perl

This is a port to Perl of the Raku program above. Please refer to the rather large chunks of information provided in the two sections above if you need further information.

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

my @moves = ( [<2 1>], [<2 -1>], [<1 2>], [<1 -2>], 
              [<-1 2>], [<-1 -2>], [<-2 1>], [<-2 -1>] );

sub to_coordinates {
    my ($col, $row) = split //, shift;
    return ord($col) - ord('a'), $row - 1;
}

sub find_shortest  {
    my ($st_in, $end_in) = @_;
    # convert input to Cartesian coordinates
    my @start = to_coordinates $st_in;
    my @end = to_coordinates $end_in;

    my @to_be_explored;  # a queue of squares to be visited    
    push @to_be_explored, [0, @start]; 
    my %seen = ("@start" => 1);  # already visited squares
    while (@to_be_explored) {
        my $node = shift @to_be_explored;
        my ($depth, @current) = @$node;
        return $depth if "@current" eq "@end";
        for my $move (@moves) {
            my @next = ( $current[0] + $move->[0], 
                         $current[1] + $move->[1] );
            # dismiss if computed position not on chessboard
            next if $next[0] > 7 or $next[0] < 0 or
                    $next[1] > 7 or $next[1] < 0;
            # dismiss if computed position already visited
            next if exists $seen{"@next"};
            # update seen hash and to_be_explored queue
            $seen{"@next"} = 1;
            push @to_be_explored, [$depth + 1, @next];
        }
    }
}

my @tests = ([<g2 a8>], [<g2 h2>]);
for my $test (@tests) {
    printf "%-6s => ", "@$test"; 
    say find_shortest @$test;;
}

This program displays the following output:

$ perl  ./shortest-knight-path.pl
g2 a8  => 4
g2 h2  => 3

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on August 18, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.

These are some answers to the Week 281, 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 11, 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: Check Color

You are given coordinates, a string that represents the coordinates of a square of the chessboard as shown below:

Write a script to return true if the square is light, and false if the square is dark.

Example 1

Input: $coordinates = "d3"
Output: true

Example 2

Input: $coordinates = "g5"
Output: false

Example 3

Input: $coordinates = "e6"
Output: true

Check Color in Raku

We could replace the abscissa letters with numbers from 1 to 8 (or 0 to 7), add the two values of the coordinates and check whether the sum is even or odd. But it is even simpler to assign 0 or 1 to a variable depending on whether the abscissa belong to the [aceg] or [bdfh] character class. We then add this variable to the ordinates and check whether the sum is even or odd.

sub check-color ($in) {
    my ($abscissa, $ordinate) = $in.comb;`
    my $code;
    given $abscissa {
        when /<[aceg]>/ {$code = 0}
        when /<[bdfh]>/ {$code = 1}
    }
    return True if ($code + $ordinate) %% 2;
    False;
}

for <a1 d3 g5 e6 h8> -> $coordinates { 
    printf "%-2s => ", $coordinates;
    say check-color $coordinates;
}

This program displays the following output:

$ raku ./check-color.raku
a1 => False
d3 => True
g5 => False
e6 => True
h8 => False

Check Color in Perl

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

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

sub check_color {
    my ($abscissa, $ordinate) = split //, shift;
    my $code = 1;
    $code = 0 if $abscissa =~ /[aceg]/;
    return "True" if ($code + $ordinate) % 2 == 0;
    return "False";
}

for my $coordinates (qw<a1 d3 g5 e6 h8>) { 
    printf "%-2s => ", $coordinates;
    say check_color $coordinates;
}

This program displays the following output:

$ perl ./check-color.pl
a1 => False
d3 => True
g5 => False
e6 => True
h8 => 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 August 18, 2024. And, please, also spread the word about the Perl Weekly Challenge if you can.