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

Task 1: Divide Integers

You are given two integers $M and $N.

Write a script to divide the given two integers i.e. $M / $N without using multiplication, division and mod operator and return the floor of the result of the division.

Example 1:

Input: $M = 5, $N = 2
Output: 2

Example 2:

Input: $M = -5, $N = 2
Output: -3

Example 3:

Input: $M = -5, $N = -2
Output: 2

Dividing $m by $n with integer or Euclidian division is equivalent to finding how many times you can subtract $n from $m while getting a positive result. Thus the algorithm is fairly straight forward. A slight difficulty is that either $m or $n (or both) might be negative. My way to tackle the problem is to work on absolute values of the $m and $n input values, and to change the sign of the result when needed. I wish I could have used multiplication of the two input values to find the sign of the result (this is not the core of the algorithm), as this is simpler, but since multiplication is forbidden, I had to use more complicated Boolean expressions.

Divide Integers in Raku

With the above explanations, the implementation is quite straight forward:

use v6;

sub MAIN (Int $m is copy, $n is copy where $n != 0) {
    my $neg = ($m <0 && $n >0 or $m > 0 && $n < 0) ?? True !! False;
    $_ = .abs for $m, $n;
    my $quotient = 0;
    while $m > $n {
        $m -= $n;
        $quotient++;
    }
    $quotient = -$quotient if $neg;
    say $quotient;
}

Running the script with various input values yields the following results:

$ perl6 int-division.p6 -5 2
-2

$ perl6 int-division.p6 5 -2
-2

$ perl6 int-division.p6 -5 -2
2

$ perl6 int-division.p6 5 2
2

Divide Integers in Perl

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

use strict;
use warnings;
use feature qw /say/;

die "Two integers needed!" unless @ARGV == 2;
my ($m, $n) = @ARGV;
die "Second argument cannot be 0" if $n == 0;
my $neg = ($m <0 && $n >0 or $m > 0 && $n < 0) ? 1 : 0;
$_ = abs $_ for $m, $n;
my $quotient = 0;
while ($m > $n) {
    $m -= $n;
    $quotient++;
}
$quotient = -$quotient if $neg;
say $quotient;

This program displays the following output for various input data:

$ perl int-division.pl 5 2
2

$ perl int-division.pl -5 2
-2

$ perl int-division.pl -5 -2
2

$ perl int-division.pl 5 -2
-2

$ perl int-division.pl 5 0
Second argument cannot be 0 at int-division.pl line 7.

Task 2: Power Integers

You are given an integer n.

Write a script to check if the given number can be expressed as m ** n where m and n are positive integers. Otherwise print 0.

Please make sure m > 1 and n > 1.

BONUS: If there are more than one ways to express the given number then print all possible solutions.

Example 1:

For given $N = 9, it should print 32 or 3^2.

Example 2:

For given $N = 45, it should print 0.

Example 3:

For given $N = 64, it should print all or one of 8^2 or 2^6 or 4^3.

I think that there should probably a better way to do it, but since I'm late and I don't have very much time to really think about it, I'll use a brute force approach in which I first find the prime factors of the input number, then find all factors less than or equal to the square root of the input number, and finally find all the combinations whose product is equal to the input number.

Please note that I'm quite late and will only provide a Raku solution. It should be pretty easy to port the Raku program to Perl.

Power Integers in Raku

use v6;

my @primes = grep { .is-prime }, 1 .. *;

sub prime-factors (UInt $num-in is copy) {
    my @factors;
    my $num = $num-in;
    for @primes -> $div {
        while ($num %% $div) {
            push @factors, $div;
            $num div= $div;
        }
        return @factors if $num == 1;
    }
    push @factors, $num unless $num == $num-in;
    return @factors;
}

sub find-powers (Int $n) {
    my @prime-factors = prime-factors $n;
    my $max = sqrt $n;
    return 0 unless @prime-factors;
    my @factors = @prime-factors.combinations.map({[*] $_}).grep({$_ <= $max and $_ > 1}).unique;
    my @powers;
    for @factors -> $div {
        for 2..* -> $exp {
            last if $div ^ $exp > $n;
            push @powers, "$div ^ $exp" if $div ** $exp == $n;
        }
    }
    return @powers;
}

sub MAIN (Int $n is copy where $n > 1) {
    my @pow = find-powers $n;
    say 0 if @pow.elems == 0;
    .say for @pow;
}

These are some results for various input values:

$ perl6 power-integer.p6 125
5 ^ 3

$ perl6 power-integer.p6 128
2 ^ 7

$ perl6 power-integer.p6 64
2 ^ 6
4 ^ 3
8 ^ 2

$ perl6 power-integer.p6 256
2 ^ 8
4 ^ 4
16 ^ 2

$ perl6 power-integer.p6 9
3 ^ 2

$ perl6 power-integer.p6 45
0

Wrapping up

The next week Perl Weekly Challenge is due to 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, July 5, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

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

You are given two positive numbers $N and $S.

Write a script to list all positive numbers having exactly $N digits where sum of all digits equals to $S.

Example:

Input:
    $N = 2
    $S = 4

Output:
    13, 22, 31, 40

Digit Sum in Raku

My first attempt to solve the problem would be a pure brute force approach as follows:

use v6;
sub MAIN (Int $nb_digits, Int $sum) {
    for 10 ** ($nb_digits - 1) .. 10 ** $nb_digits - 1 -> $num {
        say $num if $num.comb.sum == $sum;
    }
}

We’re just checking every number in the range.

A slight performance improvement is possible:

use v6;

sub MAIN (Int $nb_digits, Int $sum) {
    my $max = -1 + $sum <= 9 
        ?? $sum * 10 ** ($nb_digits -1) 
        !! 10 ** $nb_digits;
    for 10 ** ($nb_digits - 1) .. $max -> $num {
        say $num if $num.comb.sum == $sum;
    }
}

This is an example output:

$ ./perl6 digit-sum.p6 3 6
105
114
123
132
141
150
204
213
222
231
240
303
312
321
330
402
411
420
501
510
600

Digit Sum in Perl

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

use strict;
use warnings;
use feature qw /say/;

sub sum {
    my $sum_digits = 0;
    $sum_digits += $_ for split //, shift;
    return $sum_digits;
}
my ($nb_digits, $sum) = @ARGV;
for my $num (10 ** ($nb_digits - 1) .. 10 ** $nb_digits - 1 ) {
    say $num if $sum == sum $num;
}

Wrapping up

Note: there was another task in this challenge, but I was extremely busy the whole weekend and did not have time to work on it. This is also the reason why I am publishing this blog post so late. However, task 2 seems interesting, I might come back to it this week if I have more time.

The next week Perl Weekly Challenge has already started. 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 28, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

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

Spoiler Alert: This weekly challenge deadline is due in a few hours . 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: Minimum Sum Path

Given an m × n matrix with non-negative integers, write a script to find a path from top left to bottom right which minimizes the sum of all numbers along its path. You can only move either down or right at any point in time.

Example

Input:

[ 1 2 3 ]
[ 4 5 6 ]
[ 7 8 9 ]

The minimum sum path looks like this:

1→2→3
    ↓
    6
    ↓
    9

Thus, your script could output: 21 ( 1 → 2 → 3 → 6 → 9 )

Minimum Sum Path in Raku

Whenever I have to explore multiple paths in a tree or some other data structure, I tend to use a recursive approach. Here, the recursive traverse-mat subroutine tries every possible path in the matrix, compares the path cost with a global $min variable, and keeps track of the best solution so far. One of the small difficulties is how to initialize the $min variable. You could start with a very large value, but cannot be sure it will really be large enough if you don’t know your input data. In my first solution, I initialized it to the sum of all values in the matrix:

my $min = 0;
$min += [+] $_ for @mat;

This is relatively cheap compared to the exploration of the tree of all possible paths (especially for large matrices).

Then I thought that Raku has the Inf or ∞ infinity value, which should be large enough compared to any defined non-negative integer.

use v6;

my @mat = (<7 8 9>, <1 2 3>,  <4 5 6>, );
# say @mat;
my @best-path;
my $min = Inf;
my @empty-path;

traverse-mat(0, 0, 0, @empty-path);

sub traverse-mat (UInt $i, UInt $j, UInt $sum, @path is copy) {
    my $new-sum = $sum + @mat[$i][$j];
    return if $new-sum > $min;
    push @path, @mat[$i][$j];
    if @mat[$i][$j+1].defined {
        traverse-mat($i, $j+1, $new-sum, @path);
    } 
    if @mat[$i+1][$j].defined {
        traverse-mat($i+1, $j, $new-sum, @path);
    } 
    unless (@mat[$i][$j+1].defined or @mat[$i+1][$j].defined) {
        @best-path = @path;
        $min = $new-sum;
    }
}
say $min, " (", join(' → ', @best-path), ")";

This program displays the following output:

$ perl6 best-path.p6
19 (7 → 1 → 2 → 3 → 6)

Minimum Sum Path in Perl

For initializing the $min variable, we don’t have an infinity value available in Perl, so I implemented a loop to initialize it to the sum of all values in the matrix. Other than that, this program is a simple port to Perl of the Raku program:

use strict;
use warnings;
use feature qw/say/;

my @mat = ([qw<7 8 9>], [qw<1 2 3>],  [qw<4 5 6>] );
my @best_path;
my $min = 0;
for my $row (@mat) {
    $min += $_ for @$row;
}
my @empty_path;

traverse_mat(0, 0, 0, ());

sub traverse_mat {
    my ($i, $j, $sum, @path) = @_;
    my $new_sum = $sum + $mat[$i][$j];
    return if $new_sum > $min;
    my @new_path = (@path, $mat[$i][$j]);
    if (defined $mat[$i][$j+1]) {
        traverse_mat($i, $j+1, $new_sum, @new_path);
    } 
    if (defined $mat[$i+1][$j]) {
        traverse_mat($i+1, $j, $new_sum, @new_path);
    } 
    unless (defined $mat[$i][$j+1] or defined $mat[$i+1][$j]) {
        @best_path = @new_path;
        $min = $new_sum;
    }
}
say $min, " (", join(' → ', @best_path), ")";

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

$ perl best-path.pl
19 (7 → 1 → 2 → 3 → 6)

Task 2: Word Break

You are given a string $S and an array of words @W.

Write a script to find out if $S can be split into sequence of one or more words as in the given @W.

Print the all the words if found otherwise print 0.

Example 1:

*Input:*

$S = "perlweeklychallenge"
@W = ("weekly", "challenge", "perl")

Output:

"perl", "weekly", "challenge"

Example 2:

Input:

$S = "perlandraku"
@W = ("python", "ruby", "haskell")

Output:

0 as none matching word found.

Word Break in Raku

I was hoping to dynamically construct a regex from the word list, something like `rx/weekly | challenge | week/’, but I wasn’t able to find the syntax that would work properly.

So, I decided to simply loop on the array of words and use the index built-in function. Although the task specification did not request it explicitly, the example provided had the output words in the order of the original string. To obtain such an output, I stored the matches as keys in a hash, with the position of the match as values.

use v6;

my $string = "perlweeklychallenge";
my @words = <weekly challenge week perl>;
my %location;
for @words -> $word {
    my $index = index $string, $word;
    push %location, $word => $index if $index.defined;;
}
if %location.elems == 0 {
    say "0" 
} else {
    print "{$_.key} " for %location.sort({.value});
}

This is the output:

$ perl6 word-break.p6
perl weekly week challenge

Word Break in Perl

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

use strict;
use warnings;
use feature qw/say/;

my $string = "perlweeklychallenge";
my @words = <weekly challenge week perl>;
my %loc;
for my $word (@words) {
    my $index = index $string, $word;
    $loc{$word} = $index if $index >= 0;
}
if (%loc == 0) {
    say "0";
} else {
    say join " ", sort { $loc{$a} <=> $loc{$b} } keys %loc;
}

Output:

$ perl word-break.pl
perl weekly week challenge

Wrapping up

The next week Perl Weekly Challenge is due to 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 21, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.

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

Spoiler Alert: This weekly challenge deadline is due in a couple of days (June 7, 2020). 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: Last Word Matching a Regex

Define sub last_word($string, $regexp) that returns the last word matching $regexp found in the given string, or undef if the string does not contain a word matching $regexp.

For this challenge, a “word” is defined as any character sequence consisting of non-whitespace characters (\S) only. That means punctuation and other symbols are part of the word.

The $regexp is a regular expression. Take care that the regexp can only match individual words! See the Examples for one way this can break if you are not careful.

Examples:

last_word('  hello world',                qr/[ea]l/);      # 'hello'
last_word("Don't match too much, Chet!",  qr/ch.t/i);      # 'Chet!'
last_word("spaces in regexp won't match", qr/in re/);      #  undef
last_word( join(' ', 1..1e6),             qr/^(3.*?){3}/); # '399933'

The only very slight difficulty here is that regular expressions or regexes fundamentally explore strings from left to right. It is possible to use the g modifier (in Perl) or :g adverb (in Raku) to get all the matches and then keep only the last one, but I’ve decided to use another approach which is simpler and also likely to be more efficient in most cases (when it matters): split the string into words, reverse the list and find the first match.

I’ve decided to return “Not found”, rather than undef for two reasons: first, undef does not exist in Raku and, besides, I think that printing “Not found” looks nicer.

Last Word Matching a Regex in Raku

Raku has a built-in words method that splits a string into words (the delimiter being white space) and a reverse method to reverse the items of a list. We only need to look at each item and stop when we get the first pattern match:

use v6;

sub last-word (Str $str, $regex) {
    for $str.words.reverse -> $reversed {
        return $reversed if $reversed ~~ $regex;
    }
    return "Not found";
}

say last-word "Hello Word", rx/<[ae]>l/;
say last-word("Don't match too much, Chet!",  rx:i/ch.t/);
say last-word("spaces in regexp won't match", rx:s/in re/);
my $str = join(' ', 1..1e5);
say last-word( $str, rx/^8 ** 3/);

This produces the following output:

$ perl6 last-word.p6
Hello
Chet!
Not found
88899

Last Word Matching a Regex in Perl

Besides small syntax differences, porting the Raku program to Perl only required replacing words with split on white space:

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

sub last_word {
    my ($str, $regex) = @_;
    for my $reversed (reverse split /\s+/, $str) {
        return $reversed if $reversed =~ $regex;
    }
    return "Not found";
}

say last_word('  hello world',                qr/[ea]l/); 
say last_word("Don't match too much, Chet!",  qr/ch.t/i);
say last_word("spaces in regexp won't match", qr/in re/);
say last_word( join(' ', 1..1e6),             qr/^(3.*?){3}/);

This program displays the following output:

$ perl last-word.pl
hello
Chet!
Not found
399933

Task 2: Rotate String

Given a word made up of an arbitrary number of x and y characters, that word can be rotated as follows: For the ith rotation (starting at i = 1), i % length(word) characters are moved from the front of the string to the end. Thus, for the string xyxx, the initial (i = 1) % 4 = 1 character (x) is moved to the end, forming yxxx. On the second rotation, (i = 2) % 4 = 2 characters (yx) are moved to the end, forming xxyx, and so on. See below for a complete example.

Your task is to write a function that takes a string of xs and ys and returns the minimum non-zero number of rotations required to obtain the original string. You may show the individual rotations if you wish, but that is not required.

Example:

Input: $word = 'xyxx';

Rotation 1: you get yxxx by moving x to the end.
Rotation 2: you get xxyx by moving yx to the end.
Rotation 3: you get xxxy by moving xxy to the end.
Rotation 4: you get xxxy by moving nothing as 4 % length(xyxx) == 0.
Rotation 5: you get xxyx by moving x to the end.
Rotation 6: you get yxxx by moving xx to the end.
Rotation 7: you get xyxx by moving yxx to the end which is same as the given word.

Output: 7

Rotate String in Raku

For solving this task, I decided to write a rotate-once subroutine, taking a string and a number of characters to be shifted as arguments, to perform one individual rotation. That subroutine is only one code line, so the code could very well have been in-lined in the main loop, but the main reason for writing a separate subroutine is that it makes it possible to properly unit test it (it is just too easy to make an off-by-one error on such processing), even though I won’t show these simple tests which are not part of the task. The rotate-str subroutine simply implements an infinite loop to generate the successive rotated strings and breaks out of the loop with a return statement when the new rotated string is the same as original input string.

sub rotate-once (Str $str, Int $num) {
    $str.substr($num, $str.chars - $num) ~ $str.substr(0, $num);
}
sub rotate-str (Str $origin-str) {
    my $tmp = $origin-str;
    my $len = $origin-str.chars;
    my $i = 1;
    loop {
        $tmp = rotate-once $tmp, $i % $len;
        # say $tmp;
        return $i if $tmp eq $origin-str;
        $i++;
    }
}
for <xyxx xxyyy abcdefgh> {
    say "Got original string $_ after {rotate-str($_)} rotations.";
}

Simply uncomment the say statement in the loop to display the individual rotations (that’s quite useful to check the results).

The loop control-flow statement normally takes three statements in parentheses to implement the equivalent of a C-style for statement:

loop (my $i = 0; $i < 10; $i++) {
    say $i;
}

Using loop { ... } with no such three statements (and no parentheses) is just an idiomatic way to implement an infinite loop in Raku, just like while (1) { ... } in Perl.

The above program displays the following output:

$ perl6 rotate_str.p6
Got original string xyxx after 7 rotations.
Got original string xxyyy after 4 rotations.
Got original string abcdefgh after 15 rotations.

Note that I have duly noticed that the original task description said that the input string should be made of letters x and y. One of my test examples above uses other letters because it makes it a bit easier to check the results.

Rotate Strings in Perl

The following program is simply a port to Perl of the Raku program above:

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

sub rotate_once {
    my ($str, $num) = @_;
    substr($str, $num, length($str) - $num) . substr($str, 0, $num);
}
sub rotate_str {
    my $origin_str = shift; 
    my $tmp = $origin_str;
    my $len = length $origin_str;
    my $i = 1;
    while (1) {
        $tmp = rotate_once $tmp, $i % $len;
        return $i if $tmp eq $origin_str;
        $i++;
    }
}
for (qw<xyxx xxyyy abcdefgh>) {
    say "Got original string $_ after ", rotate_str($_), " rotations.";
}

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

$ perl rotate_str.pl
Got original string xyxx after 7 rotations.
Got original string xxyyy after 4 rotations.
Got original string abcdefgh after 15 rotations.

Wrapping up

The next week Perl Weekly Challenge is due to 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 14, 2020. And, please, also spread the word about the Perl Weekly Challenge if you can.