Wherein we mix our metaphors before they hatch.
THE WEEKLY CHALLENGE – PERL & RAKU #82
episode one
“He Claimed He Hardly Knew Her”
TASK #1 › Common Factors
Submitted by: Niels van Dijke
You are given 2 positive numbers $M and $N.
Write a script to list all common factors of the given numbers.
Example 1:
Input:
$M = 12
$N = 18
Output:
(1, 2, 3, 6)
Explanation:
Factors of 12: 1, 2, 3, 4, 6
Factors of 18: 1, 2, 3, 6, 9
Example 2:
Input:
$M = 18
$N = 23
Output:
(1)
Explanation:
Factors of 18: 1, 2, 3, 6, 9
Factors of 23: 1
Method
When a number is said to be a factor of another number, the meaning is that that number times some other number will in turn equal the third number. Reciprocally, the number tested and the multiplier are both commutatively factors of that same third, should we chose to look at it that way. As such when factoring, when we see whether a candidate evenly divides into our target, we will only need only check for numbers up to the square root, because when we do find a pair that fit we can immediately conclude that both numbers are factors. Every factor above the square root will have a corresponding complement below, and vice versa. This saves us quite a bit of search space. We simply do a naive check for a remainder, and if it comes up without, we’re in.
Once we have the factors for one of our numbers, the best way to determine the common elements between two arrays (when we don’t care about duplicates) is to use a hash. The factors of the first input number are hashed and the the sorted list of factors for the second number are filtered for presence in the hash before being output.
Perl Solution
The solution follows the plan outlined above. One case still need addressing: when the number is a square itself the root factor will be duplicated when we add both it and its complement, which will of course be it again, come around a second time . The hashing nicely removes this duplicate from the first number processed, but when the second number is a square it still slips through. We simply make a validation check before we add the complement to squash this behavior.
~/PWC/82_1_factorize.pl
------------------------------------------------------------
input :
N = 1530
M = 1440
output: ( 1 2 3 5 6 9 10 15 18 30 45 90 )
use warnings;
use strict;
use feature ":5.26";
## ## ## ## ## MAIN:
my $M = shift || 1440;
my $N = shift || 1530;
my %lookup = map { $_ => undef } factor($M);
my @out = grep { exists $lookup{$_} } sort {$a-$b} factor($N);
say "input :\n\tN = $N \n\tM = $M";
say "output: ( @out )";
## ## ## ## ## SUBS:
sub factor {
my $num = shift;
my @out;
my $sq = int sqrt $num;
for (1..$sq) {
if ($num % $_ == 0) {
push @out, $_;
push @out, $num / $_ unless $_**2 == $num;
}
}
return @out;
}
Raku Solution
In Raku, we can utilize the Bag type to painlessly set up a lookup on the first set of factors, then on the second set we can chain a sequence of methods to immediately resolve the output. For the factorizing itself, we can apply a filter directly to the iterator to only allow those numbers that evenly divide the target using the %% divisibility operator. This also presents a fine opportunity to use the gather/take idiom to first take the filtered topic, which we already know to be a factor, and then the complement if, again, it isn’t a duplicate.
As for duplication, in Raku, of course, there’s a function for that; we have the unique routine to weed through our arrays. I was, however, having quite a problem getting it to actually work. Whichever way I inserted it it was having no effect. For my testing I had used 36 for my second input, and there, plain as day, were a pair of 6s. If I added the conditional check used in the Perl program one of these went away, but no application of unique seemed to mirror the behavior. It was getting annoying and I had given up a few times as no longer worth the effort, but as giving up isn’t something I seem capable of doing I kept coming back.
To cut to the chase, it turns out my use of $num/$_ to find our complement was causing it to fail, with the pairs of square root factors continuing to get passed through. I only really figured out what was happening after a bit of systematic sleuthing proved that this construction was by its nature returning a Rat, rather than an Int, which in hindsight seems perfectly reasonable. The two take statements were thus producing a list of alternating Ints and Rats, and my test example for 36 contained two distinct elements, an Int 6 and a Rat 6. Sneaky! It was only when I applied the .WHAT method to the actual array elements that I finally caught what I was doing. Without that I may have never have figured it out. Changing the operator to div, the integer division operator, got us out of that particular hole without requiring us to recast our data, and unique was back on the menu. As the Bag type, being essentially a hash, will already give us unique keys this wasn’t required with the first set of factors; it proved easy to just add .unique into the output function chain above the .sort. Everything ends up clean, tight and squeaky clean in the end, just the way it’s supposed to be. I think I’m fond of this gather / take thing.
unit sub MAIN (Int $M = 18, Int $N = 36) ;
my %bag = bag factor($M);
my @out = factor($N).unique
.sort
.grep: {%bag{$_}:exists};
say "input :\n\tM = $M\n\tN = $N";
say "output : ", @out;
sub factor (Int $num) {
gather {
for (1..$num.sqrt.Int).grep({$num %% $_}) {
take $_;
take $num div $_;
}
}
}
episode two
“The A-B Roll”
TASK #2 › Interleave String
Submitted by: Mohammad S Anwar
You are given 3 strings; $A, $B and $C.
Write a script to check if $C is created by interleave $A and $B.
Print 1 if check is success otherwise 0.
Example 1:
Input:
$A = "XY"
$B = "X"
$C = "XXY"
Output: 1
EXPLANATION
"X" (from $B) + "XY" (from $A) = $C
Example 2:
Input:
$A = "XXY"
$B = "XXZ"
$C = "XXXXZY"
Output: 1
EXPLANATION
"XX" (from $A) + "XXZ" (from $B) + "Y" (from $A) = $C
Example 3:
Input:
$A = "YX"
$B = "X"
$C = "XXY"
Output: 0
Method
This is a really interesting problem. At first look it seems to present a very complex solution space, but because all of the strings maintain their ordering throughout, the actual decision making never gets beyond a series of binary choices. The key to cracking it is to entertain a complete idea of what “interleaving” is.
Interleaving is the process of taking two strings and, from the beginnings of both, selecting and gathering partitions of first one string and then the other, assembling a constructed third string from the two until all characters from both inputs are utilized.
Ok, but what does that mean to us?
If we start with the two strings, we are given the choice to take the first letter from either one or the other to begin our common concatenation. After that character is added, we are then given the choice of continuing to add the next letter from our chosen string or switch and add the first letter from the other string. When a letter is selected, the position to be added next from that string is advanced; if one string becomes exhausted, the assembly continues with the last part of the remaining string. The process continues until there are no more options for characters to be added.
Practically, we can physically remove letters from the strings as we use them, which lightens the bookkeeping load as we’re always looking at the first letter. This includes the target string we’re validating; when a character is chosen that letter is removed as well, leaving us with a remaining string of characters left to match. We don’t need to keep a record of the string we’re assembling, because we know that if we run out of letters, between our two input strings and the target, simultaneously we’ve matched our last letter. The validation of the interleaving has been successful, and we already know what the result looks like.
Perl Solution
I left a $VERBOSE switch in to examine the progress of the output: you can follow the action as the letters are removed from the target string one by one as the interleaving progresses. To do the work, we use a simple recursive routine, picking a valid input, shortening the strings as applicable and sending the new data around again. When we run out of string or options we are finished, for better or worse.
For rather long strings the algorithm still finishes quickly, but does desire to have the deep recession warning turned off after a hundred characters. There is no risk of a runaway recursion.
I find the progress interesting to look at. Here the strings are crafted to produce a misdirection requiring backtracking before landing on the correct meshing of partitions. Notice that sometimes the two strings switch roles when a match is made: “A” becomes “B” and vice versa; this is a side effect of whatever string is taken from the other string becomes string B. It doesn’t matter in any way which is which at any given moment, only that their characters are utilized in the end, in order, to make the weave.
~/Code/82_2_ab_interneg.pl
--------------------------------------------------------------------------------
A AXXZ
B XXYZ
C AXXYXZXZ
took A target now XXYXZXZ
A XXZ
B XXYZ
C XXYXZXZ
took X target now XYXZXZ
A XZ
B XXYZ
C XYXZXZ
took X target now YXZXZ
A Z
B XXYZ
C YXZXZ
backtracking...
took X target now YXZXZ
A XYZ
B XZ
C YXZXZ
backtracking...
backtracking...
took X target now XYXZXZ
A XYZ
B XXZ
C XYXZXZ
took X target now YXZXZ
A YZ
B XXZ
C YXZXZ
took Y target now XZXZ
A Z
B XXZ
C XZXZ
took X target now ZXZ
A XZ
B Z
C ZXZ
took Z target now XZ
A
B XZ
C XZ
took X target now Z
A Z
B
C Z
took Z target now
A
B
C
1
use warnings;
use strict;
use feature ":5.26";
no warnings 'recursion';
## ## ## ## ## MAIN:
my $VERBOSE = 1;
my ($A, $B, $C) = @_;
$A //= "AXXZ";
$B //= "XXYZ";
$C //= "AXXYXZXZ";
say 0 and exit if length($A)+length($B)!=length($C);
say interleave($A, $B, $C);
## ## ## ## ## SUBS:
sub interleave {
my ($A, $B, $C) = @_;
say "A $A \nB $B \nC $C\n" if $VERBOSE;
return 1 unless ( $A or $B or $C ); ## we've used all our letters
for ($A,$B) {
if (substr($_, 0, 1) eq substr($C, 0, 1) ) {
my $taken = substr $_, 1;
my $other = $_ eq $A ? $B : $A;
my $target = substr $C, 1;
say "took ", substr($_, 0, 1), " target now $target\n" if $VERBOSE;
return 1 if interleave($taken, $other, $target);
}
}
say "backtracking..." if $VERBOSE;
return 0;
}
Raku Solution
For the Raku version I have inserted some rather ridiculously long strings that, yes, can be interwoven to produce the combined output. The use of the starts-with method makes the letter match confirmation more direct. Likewise the use of a junction any to keep trying to match as long as characters are present in either of the inputs or the output string.
unit sub MAIN () ;
my $VERBOSE = True;
my $A = "AABBCCAABBCCXXYAABBCCAABBCCXXYXXYAABBCCAABBCCXXYAABBCCAABBCCXXY";
my $B = "AXBYAXBYAXZAXBYAXBYAXZAXZAXBYAXBYAXZAXBYAXBYAXZ";
my $C = "AABAXBBCCYAABAXBBCCYXAXXZYAABAXBBCCYAABAXBBCCYXAXXZYXAXXZYAABAXBBCCYAABAXBBCCYXAXXZYAABAXBBCCYAABAXBBCCYXAXXZY";
say 0 and exit if $A.chars + $B.chars != $C.chars;
say "\noutput: ", interleave($A, $B, $C);
## ## ## ## ## SUBS:
sub interleave (Str $A, Str $B, Str $C) {
say "\nA $A \nB $B \nC $C" if $VERBOSE;
return 1 unless any( $A, $B, $C ); ## we've used all our letters
for $A,$B {
when $_.starts-with: $C.substr(0, 1) {
my $taken = $_.substr(1);
my $other = $_ eq $A ?? $B !! $A;
my $target = $C.substr(1);
say "took " ~ $_.substr(0, 1) ~ " target now $target" if $VERBOSE;
return 1 if interleave($taken, $other, $target);
}
}
return 0;
}
Programming Excursions in Perl and Raku 