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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (June 27, 2021). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Binary Palindrome

You are given a positive integer $N.

Write a script to find out if the binary representation of the given integer is Palindrome. Print 1 if it is otherwise 0.

Example:

Input: $N = 5
Output: 1 as binary representation of 5 is 101 which is Palindrome.

Input: $N = 4
Output: 0 as binary representation of 4 is 100 which is NOT Palindrome.

Binary Palindrome in Raku

In Raku, the base method converts the invocant number to a string representation of the number in the given base. So we need to compare compare the binary representation of the number to its reverse string (using the flip routine). The code for doing that is a simple Raku one-liner. The + sign is used to numify Boolean values returned by the comparison (i.e. convert Trueand False values to 1 and 0, respectively).

use v6;

for 1..12 -> $test {
    say "$test -> ", + ($test.base(2) eq $test.base(2).flip);
}

This is the output with the 12 test cases:

$ raku ./bin-palindrome.raku
1 -> 1
2 -> 0
3 -> 1
4 -> 0
5 -> 1
6 -> 0
7 -> 1
8 -> 0
9 -> 1
10 -> 0
11 -> 0
12 -> 0

Binary Palindrome in Perl

The Perl implementation is quite similar to the Raku implementation, except that we use the sprintf built-in function to convert the number to a binary representation of the input number.

use strict;
use warnings;
use feature "say";

for my $test (1..12) {
    my $bin_num = sprintf "%b", $test;
    say "$test -> ", $bin_num eq reverse ($bin_num) ? 1 : 0;
}

This is the output with the 12 test cases:

$ perl ./bin-palindrome.pl
1 -> 1
2 -> 0
3 -> 1
4 -> 0
5 -> 1
6 -> 0
7 -> 1
8 -> 0
9 -> 1
10 -> 0
11 -> 0
12 -> 0

Task 2: Adventure of Knight

A knight is restricted to move on an 8×8 chessboard. The knight is denoted by N and its way of movement is the same as what it is defined in Chess.

* represents an empty square. x represents a square with treasure.

The Knight’s movement is unique. It may move two squares vertically and one square horizontally, or two squares horizontally and one square vertically (with both forming the shape of an L).

There are 6 squares with treasures.

Write a script to find the path such that Knight can capture all treasures. The Knight can start from the top-left square.

  a b c d e f g h
8 N * * * * * * * 8
7 * * * * * * * * 7
6 * * * * x * * * 6
5 * * * * * * * * 5
4 * * x * * * * * 4
3 * x * * * * * * 3
2 x x * * * * * * 2
1 * x * * * * * * 1
  a b c d e f g h

BONUS: If you believe that your algorithm can output one of the shortest possible path.

I have secured a Raku program solving the knight’s tour problem, using Warnsdorff’s rule. Since this program guarantees that the knight visits every square exactly once, we’re guaranteed to find all treasures in a relatively limited number of moves. But it is rather unlikely to find the shortest possible path. I’ll try to look for an optimal path, but this appears to require an entirely different algorithm. I’m very busy this week: I have meetings late on Thursday and Friday evenings and I have a fully booked weekend, with at best a couple of hours free on Saturday night. In short, I’m really not sure that I’ll be able to complete task 2 in time. This is the reason I decided to publish this blog post with solutions to only task 1. I’ll update this post if I succeed to complete task 2 in due time.

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 Independence Day, i.e. July 4, 2021. And, please, also spread the word about the Perl Weekly Challenge if you can.

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (June 20, 2021). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Missing Row

You are given text file with rows numbered 1-15 in random order but there is a catch one row in missing in the file.

11, Line Eleven
1, Line one
9, Line Nine
13, Line Thirteen
2, Line two
6, Line Six
8, Line Eight
10, Line Ten
7, Line Seven
4, Line Four
14, Line Fourteen
3, Line three
15, Line Fifteen
5, Line Five

Write a script to find the missing row number.

If the numbers are really 1 to 15 and if only one number is missing, then we could sum the numbers that we have and subtract the result from the sum of all integers between 1 and 15 (120), which would give us the missing number.

However, I’ll work on a task that is a bit more general: rather than only 1 to 15, I’ll use a range from 1 to any larger integer, and I’ll also suppose that there can be more than 1 number missing.

Missing Row in Raku

I will simulate the input file as a string variable. We read the input data and store in the %seen hash the row numbers. At the end, we go through the range and print out numbers that are not in the hash.

use v6;

my $file = "11, Line Eleven
1, Line one
9, Line Nine
13, Line Thirteen
2, Line two
6, Line Six
8, Line Eight
10, Line Ten
7, Line Seven
4, Line Four
14, Line Fourteen
3, Line three
15, Line Fifteen
5, Line Five";

my %seen;
my $max = 0;

for $file.lines -> $line {
    my $num = $line ~~ /^(\d+)/;
    %seen{$num} = 1;
    $max = $num if $num > $max;
}
for 1..$max -> $i {
    say "Missing number = ", $i unless %seen{$i}:exists;
}

This program displays the following output:

raku ./missing_row.raku
Missing number = 12

Missing Row in Perl

This is essentially a port to Perl of the Raku program above, except that we store the input in a __DATA__ section:

use strict;
use warnings;
use feature "say";

my %seen;
my $max = 0;

while (my $line = <DATA>) {
    my $num = $1 if $line =~ /^(\d+)/;
    $seen{$num} = 1;
    $max = $num if $num > $max;
}
for my $i (1..$max) {
    say "Missing number = ", $i unless exists $seen{$i};
}

__DATA__
11, Line Eleven
1, Line one
9, Line Nine
13, Line Thirteen
2, Line two
6, Line Six
8, Line Eight
10, Line Ten
7, Line Seven
4, Line Four
14, Line Fourteen
3, Line three
15, Line Fifteen
5, Line Five

This program displays the same output as the Raku program:

$ perl missing_row.pl
Missing number = 12

Task 2 - Find Possible Paths

You are given size of a triangle.

Write a script to find all possible paths from top to the bottom right corner.

In each step, we can either move horizontally to the right (H), or move downwards to the left (L) or right (R).

BONUS: Try if it can handle triangle of size 10 or 20.

Example 1:

Input: $N = 2

           S
          / \
         / _ \
        /\   /\
       /__\ /__\ E

Output: RR, LHR, LHLH, LLHH, RLH, LRH

Example 2:

Input: $N = 1

           S
          / \
         / _ \ E

Output: R, LH

First, I will not try the bonus, because the result would just be insanely large: a triangle of size 10 has more than one million possible paths and a triangle of size 20 has billions or possibly trillions of paths.

Possible Paths in Raku

We use the recursive visit subroutine to build all possible paths.

use v6;

sub visit ($row, $col, $path) {
    print "$path " and return if $row == $col == $*end;
    visit($row + 1, $col + 1, "{$path}R") if $row < $*end and $col < $*end;
    visit($row, $col + 1, "{$path}H") if $col < $row;
    visit($row + 1, $col, "{$path}L") if $row < $*end;
}   

sub MAIN(UInt $size = 3) {
    my $*end = $size;
    visit(0, 0, '');
}

This program displays the following output:

raku ./possible_path.raku 3
RRR RRLH RLRH RLHR RLHLH RLLHH LRRH LRHR LRHLH LRLHH LHRR LHRLH LHLRH LHLHR LHLHLH LHLLHH LLRHH LLHRH LLHHR LLHHLH LLHLHH LLLHHH

We can also find the number of paths with an input value of 10:

raku ./possible_path.raku 10 | wc
      0 1037718 18474633

Possible Paths in Perl

This a port to Perl of the above Raku program:

use strict;
use warnings;
use feature "say";

my $end = shift // 3;

sub visit  { 
    my ($row, $col, $path) = @_;
    print "$path " and return if $row == $end and $col == $end;
    visit($row + 1, $col + 1, "${path}R") if $row < $end and $col < $end;
    visit($row, $col + 1, "${path}H") if $col < $row;
    visit($row + 1, $col, "${path}L") if $row < $end;
}   

visit(0, 0, '');

This program displays the following output:

$ perl possible_path.pl 3
RRR RRLH RLRH RLHR RLHLH RLLHH LRRH LRHR LRHLH LRLHH LHRR LHRLH LHLRH LHLHR LHLHLH LHLLHH LLRHH LLHRH LLHHR LLHHLH LLHLHH LLLHHH

$ perl possible_path.pl 2
RR RLH LRH LHR LHLH LLHH

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

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (June 13, 2021). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: Number Sequence

• You are given a number $N >= 10.*

• Write a script to split the given number such that the difference between two consecutive numbers is always 1 and it shouldn’t have leading 0.*

Print the given number if it impossible to split the number.

Example:

Input: $N = 1234
Output: 1,2,3,4

Input: $N = 91011
Output: 9,10,11

Input: $N = 10203
Output: 10203 as it is impossible to split satisfying the conditions.

Number Sequence in Raku

One way to see it is to say that we want to partition the digits of the input number in such a way that each partition (with one or several digits) is a number one more than the preceding one.

In Raku, my first idea was to use the combinations built-in method to generate the particions, but this turned out to be impractical. So I decided to use a completely different route: in Raku, the regex sub-language has an exhaustive (or ex for short) adverb which generate all possible matches between a string and the searches pattern. With this adverb and a pattern such as (\d+)+, we can generate all possible combinations of digits of an input number. This leads to the following program:

use v6;

sub num-seq (Int $in) {
    MATCH: for $in ~~ m:ex/^(\d+)+$/ -> $m {
        my @match = $m[0].map({~$_}); # stringify the match object
        next MATCH if @match.elems < 2; 
        for 1..@match.end -> $i {
            next MATCH if @match[$i] ~~ /^0/ or # remove a match starting with 0
                @match[$i] - @match[$i - 1] != 1;
        }
        return @match;
    }
    return $in
}

for <1234 91011 10203> -> $test {
    say join ', ', num-seq $test;
}

This program displays the following output:

raku ./num-seq.raku
1, 2, 3, 4
9, 10, 11
10203

Number Sequence in Perl

Perl regexes don’t have a functionality for exhaustive pattern matching. So our Perl solution will be entirely different.

We use a num_seq recursive subroutine to potentially generate all possible partitions, except that we don’t really generate all partitions, as we filter out early in the process beginnings of partitions that cannot yield a solution,

use strict;
use warnings;
use feature "say";
my $end_result;

sub num_seq {
    my $cur_val = shift; 
    my $result = shift;
    my @digits = @_;

    my $len = length $cur_val;
    return if scalar @digits < $len;
    $cur_val = $digits[0] - 1 unless $cur_val;
    for my $i ($len - 1 .. $#digits) {
        my $new_val = join "", @digits[0..$i];
        next if $new_val - $cur_val != 1 or $new_val =~ /^0/;
        push @{$result}, join "", @digits[0..$i];
        # say "@$result";
        if (scalar @digits > $len) {
            num_seq($new_val, $result, @digits[$i+1..$#digits]);
        } else {
            $end_result = $result;
            return;
        }
    }
}

for my $test (qw<1234 91011 10203>) {
    $end_result = "";
    num_seq 0, [], split "", $test;
    if ($end_result) { 
        say join ", ", @$end_result;
    } else {
        say $test;
    }
}

This script displays the following output:

$ perl  num-seq.pl
1, 2, 3, 4
9, 10, 11
10203

Task 2: Sum of Squares

You are given a number $N >= 10.

Write a script to find out if the given number $N is such that sum of squares of all digits is a perfect square. Print 1 if it is otherwise 0.

Example:

Input: $N = 34
Ouput: 1 as 3^2 + 4^2 => 9 + 16 => 25 => 5^2

Input: $N = 50
Output: 1 as 5^2 + 0^2 => 25 + 0 => 25 => 5^2

Input: $N = 52
Output: 0 as 5^2 + 2^2 => 25 + 4 => 29

Note that all multiples of ten until 100 satisfy the perfect square condition, as well as all multiples of 100 until 1000 (and so on). Also note that since 34 satisfies the condition, as shown in the example above, then its anagram 43 also does.

Sum of Squares in Raku

Just straight forward: for every number in the test input range, we check whether the sum of digit squares is a perfect square.

use v6;

sub sum-squares (Int $n where * >= 10) {
    my $sum-sq = [+] $n.comb.map({$_²});
    my $sqrt-int = $sum-sq.sqrt.Int;
    return $sqrt-int² == $sum-sq ?? 1 !! 0;
}
say "$_: ", sum-squares $_ for 10..71;

This program displays the following output:

$ raku  ./sum-squares.raku
10: 1
11: 0
12: 0
13: 0
14: 0
15: 0
16: 0
17: 0
18: 0
19: 0
20: 1
21: 0
22: 0
23: 0
24: 0
25: 0
26: 0
27: 0
28: 0
29: 0
30: 1
31: 0
32: 0
33: 0
34: 1
35: 0
36: 0
37: 0
38: 0
39: 0
40: 1
41: 0
42: 0
43: 1
44: 0
45: 0
46: 0
47: 0
48: 0
49: 0
50: 1
51: 0
52: 0
53: 0
54: 0
55: 0
56: 0
57: 0
58: 0
59: 0
60: 1
61: 0
62: 0
63: 0
64: 0
65: 0
66: 0
67: 0
68: 1
69: 0
70: 1
71: 0

Sum of Squares in Raku

This is a port to Perl of the Raku program above:

use strict;
use warnings;
use feature "say";

sub sum_squares {
    my $n = shift;
    my $sum_sq = 0;
    $sum_sq += $_ ** 2 for split //, $n;
    my $sqrt_int = int sqrt $sum_sq;
    return $sqrt_int ** 2 == $sum_sq ? 1 : 0;
}
say "$_: ", sum_squares $_ for 10..71;

This program displays the same output as the Raku program above:

$ perl  ./sum-squares.pl
10: 1
11: 0
12: 0
13: 0
14: 0
15: 0
16: 0
17: 0
18: 0
19: 0
20: 1
21: 0
22: 0
23: 0
24: 0
25: 0
26: 0
27: 0
28: 0
29: 0
30: 1
31: 0
32: 0
33: 0
34: 1
35: 0
36: 0
37: 0
38: 0
39: 0
40: 1
41: 0
42: 0
43: 1
44: 0
45: 0
46: 0
47: 0
48: 0
49: 0
50: 1
51: 0
52: 0
53: 0
54: 0
55: 0
56: 0
57: 0
58: 0
59: 0
60: 1
61: 0
62: 0
63: 0
64: 0
65: 0
66: 0
67: 0
68: 1
69: 0
70: 1
71: 0

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

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (June 6, 2021). This blog post offers some solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

Task 1: String Chain

You are given an array of strings.

Write a script to find out if the given strings can be chained to form a circle. Print 1 if found otherwise 0.

A string $S can be put before another string $T in circle if the last character of $S is same as first character of $T.

Examples:

Input: @S = ("abc", "dea", "cd")
Output: 1 as we can form circle e.g. "abc", "cd", "dea".

Input: @S = ("ade", "cbd", "fgh")
Output: 0 as we can't form circle.

I interpreted the task as follows: find a string chain among the input strings. In other words, I looked for a possible chain among the input strings, even if some of the input strings are not part of the circular string. Reading again the task specification, it appears that the circular chain should contain all input strings (or perhaps the task was updated after I originally read it). Anyway, the task as described above is significantly easier than what I did, but I have no time this week to redo it.

String Chains in Raku

Since we’re looking for possible partial circular chains, we need to look at all combinations of strings. The find-circle subroutine uses the combinations and permutations built-in methods of Raku and for each permutation generated, the test-chain subroutine checks that they form a circle. There can be several solutions, but since we’re only required to print O or 1, we stop as soon as we’ve found one solution.

my @s = "abc", "dea", "cd";

sub test-chain (@input) {
    return False if (substr @input[0], 0, 1) 
        ne substr @input[*-1], (@input[*-1]).chars - 1, 1;
    for 1..@input.end -> $i {
        return False if (substr @input[$i], 0, 1)
            ne substr @input[$i-1], (@input[$i-1]).chars -1, 1;
    }
    True;
}

sub find-circle (@in) {
    for @in.combinations(2..@in.elems) -> $combin {
        for $combin.permutations -> $permute {
            next unless test-chain $permute;
            say $permute;
            return 1;
        }
    }
    return 0;
}

say find-circle @s;

This program displays the following output:

$ raku chain-str.raku
(abc cd dea)
1

I admit that I lazily used a brute-force approach here, that wouldn’t scale up too well for a large number of input string. There are better ways to solve the task, as we will see in the Perl implementation.

String Chains in Perl

Looking at porting the above program into Perl, my first idea was to implement the Raku built-in combinations/permutations methods in Perl. Nothing complicated, but a bit of a pain in the neck. Thinking about that, however, another idea came to me: in a circular chain of strings, the list of first letters is the same as the list of last letters. So, if we can make a list of first letters that are also last letters, then we have a solution.

use strict;
use warnings;
use feature "say";
use Data::Dumper;

my @s = ("abc", "dea", "cd", "xyz");

sub find_circle {
    # remove useless strings starting and ending with the same letter
    my @s = grep { not /^(\w)\w+$0$/} @_;
    my %first = map { (substr $_, 0, 1) => 1 } @s;
    say Dumper \%first;
    my %last = map { (substr $_, -1, 1) => 1 } grep { exists $first{substr $_, -1, 1 }}  @s;
    return scalar keys %last > 1 ? 1 : 0;
}
say find_circle @s;

Output:

$ perl chain-str.pl
1

Task 2: Largest multiple

You are given a list of positive integers (0-9), single digit.

Write a script to find the largest multiple of 2 that can be formed from the list.

Examples:

Input: @N = (1, 0, 2, 6)
Output: 6210

Input: @N = (1, 4, 2, 8)
Output: 8412

Input: @N = (4, 1, 7, 6)
Output: 7614

I think that the simplest way to get the largest number from a list of digits is to sort the digits in descending order and concatenate them. Since we additionally need the number to be even, we can, if needed, swap the last digit with the last even digit. Note that the problem has no solution if all digits are odd.

Largest Multiple in Raku

This is a Raku implementation of the algorithm described above:

sub find-largest (@in) {
    my @sorted = @in.sort.reverse;
    return @sorted if @sorted[*-1] %% 2;
    for (0..@in.end).reverse -> $i {
        # swap smallest even digit with last digit
        if @sorted[$i] %% 2 {
            @sorted[$i, *-1] = @sorted[*-1, $i];
            return @sorted;
        }
    }
    return (); # Failed, no even digit
}
for <1 0 2 6>, <1 3 2 6>, 
    <1 3 5 7>, <1 4 2 8> -> @test {
    my @result = find-largest @test;
    print @test, ": ";
    if @result.elems > 0 {
        say "Solution: ", @result.join('');
    } else {
        say "No solution"; 
    }
}

This program displays the following output for the given test cases:

$ raku ./mult-of-2.raku
1 0 2 6: Solution: 6210
1 3 2 6: Solution: 6312
1 3 5 7: No solution
1 4 2 8: Solution: 8412

Largest Multiple in Perl

This is an implementation of the same algorithm in Perl:

use strict;
use warnings;
use feature "say";

sub find_largest {
    my @sorted = reverse sort @_;
    return @sorted if $sorted[-1] % 2 == 0;
    for my $i (reverse 0..$#sorted) {
        # swap smallest even digit with last digit
        if ($sorted[$i] % 2 == 0) {
            @sorted[$i, -1] = @sorted[-1, $i];
            return @sorted;
        }
    }
    return (); # Failed, no even digit
}
for my $test ( [qw<1 0 2 6>], [qw<1 3 2 6>], 
               [qw<1 3 5 7>], [qw<1 4 2 8>] ) {
    my @result = find_largest(@$test);
    print @$test, ": ";
    if (@result > 0) {
        say "Solution: ", join '', @result;
    } else {
        say "No solution"; 
    }
}

This program displays the following output for given test cases:

$ perl  multiple-of2.pl
1026: Solution: 6210
1326: Solution: 6312
1357: No solution
1428: Solution: 8412

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