Perl Weekly Challenge: Week 314
Challenge 1:
Equal Strings
You are given three strings.
You are allowed to remove the rightmost character of a string to make all equals.
Write a script to return the number of operations to make it equal otherwise
-1.
Example 1
Input: $s1 = "abc", $s2 = "abb", $s3 = "ab"
Output: 2
Operation 1: Delete "c" from the string "abc"
Operation 2: Delete "b" from the string "abb"
Example 2
Input: $s1 = "ayz", $s2 = "cyz", $s3 = "xyz"
Output: -1
Example 3
Input: $s1 = "yza", $s2 = "yzb", $s3 = "yzc"
Output: 3
First we set up storage for the number of operations performed.
my $ops = 0;
Because script arguments in Raku are immutable, we make copies we can work on.
my @strs = ($s1, $s2, $s3);
Then we go into an infinite loop.
loop {
There are two conditions that can cause us to break out of the loop.
First, if any of the strings have been completely erased, it means we will not be able
to make them all equal. We print -1 and exit.
if @strs.map({ $_.chars }).any == 0 {
say -1;
last;
}
If all the strings are equal, we have success. We print the number of operations performed and exit.
if [eq] @strs {
say $ops;
last;
}
If neither case is true, we find the length of the longest string in the list.
my $maxlen = @strs.map({ $_.chars }).max;
We go through all the strings and all the ones that are this length are truncated by lopping off one character from the end. The number of operations performed is incremented.
for @strs.keys -> $i {
if @strs[$i].chars == $maxlen {
@strs[$i] = @strs[$i].substr(0, *-1);
$ops++;
}
}
Then the next iteration ofthe loop is performed.
}
This is the Perl version.
my $ops = 0;
my @strs = ($s1, $s2, $s3);
Now that we have proper true and false keywords in modern Perl, I'm using while (true) instead
of while (1) to express the infinite loop.
while (true) {
In lieu of .any() I am using grep().
if (grep { length($_) == 0 } @strs) {
say -1;
last;
}
Without convenient metaoperators like [eq] we have to check if the strings
are equal pair by pair.
if ($strs[0] eq $strs[1] && $strs[1] eq $strs[2]) {
say $ops;
last;
}
The last missing piece was .max(). I worked around its' lack by sorting the strings
by length longest to shortest and taking the first element,
my $maxlen = (sort { $b <=> $a } map { length($_) } @strs)[0];
for my $i (keys @strs) {
if (length($strs[$i]) == $maxlen) {
$strs[$i] = substr($strs[$i], 0, -1);
$ops++;
}
}
}
Challenge 2:
Sort Columns
You are given a list of strings of same length.
Write a script to make each column sorted lexicographically by deleting any non sorted columns.
Return the total columns deleted.
Example 1
Input: @list = ("swpc", "tyad", "azbe")
Output: 2
swpc
tyad
azbe
Column 1: "s", "t", "a" => non sorted
Column 2: "w", "y", "z" => sorted
Column 3: "p", "a", "b" => non sorted
Column 4: "c", "d", "e" => sorted
Total columns to delete to make it sorted lexicographically.
Example 2
Input: @list = ("cba", "daf", "ghi")
Output: 1
Example 3
Input: @list = ("a", "b", "c")
Output: 0
We convert the input into a 2D array which I have called @table for reasons I can't remember.
We can't directly manipulate @list due to the immutability of input parameters. One other thing to
note in this line is the use of .List. This is because .comb() returns a Sequence and we want an actual List.
my @table = @list.map({ $_.comb.List });
The next part is all one line but I've spread it out to make it more readable.
The elements of @table are rows in the 2D array. We need columns so first we find the indices of the columns with
@table[0].keys. Actually we could use any element of @table for this purpose.
say @table[0]
.keys
.grep() is used to filter these indices. we use them to get columns with an array slice. The column is turned into a Str with .join() then the same procedure is performed on a sorted version of the column. The two strings are compared and if
they are not equal, the index is kept otherwise it is discarded.
.grep({ @table[*;$_].join ne @table[*;$_].sort.join })
By noe we have a list of indices of columns to be deleted. All we have to do is count them with .elems()...
.elems;
...and the say() at the beginning of the line will print the answer.
In the Perl version we don't have to worry about immutabilty so the 2D array is created straight from the input.
my @list = map { [split //, $_] } @ARGV;
In this version, I created an array of already joined up columns though I could have done things the way I did in Raku.
my @cols;
for my $row (keys @list) {
for my $col (keys @{$list[$row]}) {
$cols[$col] .= $list[$row]->[$col];
}
}
The rest works the same as in Raku.
say scalar grep { $_ ne join q{}, sort split //, $_ } @cols;