Perl Weekly Challenge: Week 111
Challenge 1:
Search Matrix
You are given 5x5 matrix filled with integers such that each row is sorted from left to right and the first integer of each row is greater than the last integer of the previous row.
Write a script to find a given integer in the matrix using an efficient search algorithm.
Example
Matrix: [ 1, 2, 3, 5, 7 ]
[ 9, 11, 15, 19, 20 ]
[ 23, 24, 25, 29, 31 ]
[ 32, 33, 39, 40, 42 ]
[ 45, 47, 48, 49, 50 ]
Input: 35
Output: 0 since it is missing in the matrix
Input: 39
Output: 1 as it exists in the matrix
This is my Raku solution. I came up with a working version in about five minutes which is a testament to the power and versatility of this language. Now if we could only get more people to use it.
Anyway...
sub MAIN() {
my @matrix = (1 .. 50).pick(25).sort.batch(5);
It wasn't clear in the spec but I assumed that the matrix should be randomly generated which I have
done in the line above. .pick() selects guaranteed unique numbers then .sort() puts the selected numbers
in order and .batch() groups them by 5 so that @matrix becomes a 2d array consisting of 5 rows each containing
5 unique integers from 1 to 50.
my $input = (1 .. 50).pick;
I also .pick() one number from 1 to 50 as the input. This is not guaranteed to be different from the 25 numbers selected
before, in fact I'm counting it being possibly the same or we wouldn't be able to do a very good search demo.
my $output = 0;
The output starts off as 0 — not found — by default.
for 0 ..^ @matrix.elems -> $i {
Now for each row of the matrix...
if $input <= @matrix[$i][*-1] {
We look at the last element. If our $input is lower than this amount, the answer might possibly be on this row.
for 0 ..^ @matrix[$i].elems -> $j {
if @matrix[$i][$j] == $input {
$output = 1;
last;
}
}
We compare $input with each element in the row. If we find it, we can set $output to 1 and stop looking.
last;
If it isn't on that row, we can also stop looking. It's not going to be on any other row either.
}
}
for 0 .. 4 -> $i {
print $i ?? q{ } !! 'matrix: ';
say q{[ }, @matrix[$i].map({ sprintf("%2d", $_)}).join(q{, }), q{ ]};
}
say "\nInput: ", $input;
say $output;
}
Printing the matrix input and output in the format shown in the spec was a little tricky and took more time than the rest of the script but still wasn't so bad really.
Translating my Raku solution to Perl wasn't so simple because we are missing some functionality.
Luckily, I had written a replacement for .pick() back in PWC 34 Here it is again below:
sub pick {
my @range = @{$_[0]};
my $quantity = $_[1] // 1;
if ($quantity < 1 || $quantity > scalar @range) {
die "out of range\n";
}
my @picked;
for my $i (1 .. $quantity) {
my $try = q{ };
while ($try eq q{ }) {
$try = $range[int(rand(scalar @range))];
}
@range = map { $_ eq $try ? q{ } : $_; } @range;
push @picked, $try;
}
return wantarray ? @picked : $picked[0];
}
.batch() on the other hand I had to write from scratch.
sub batch {
my @range = @{$_[0]};
my $quantity = $_[1];
if ($quantity < 1 || $quantity > scalar @range) {
die "out of range\n";
}
my $length = scalar @range;
my $i = 0;
while ($i < $length) {
my @row;
for (1 .. $quantity) {
push @row, shift @range;
$i++;
if ($i == $length) {
last;
}
}
push @range, [@row];
}
return wantarray ? @range : $range[0];
}
Now I can reproduce the algorithm I used in Raku.
my @matrix = batch([sort { $a <=> $b } pick([1 .. 50], 25)], 5);
my $input = pick([1 .. 50]);
my $output = 0;
for my $i (0 .. scalar @matrix - 1) {
if ($input <= $matrix[$i][-1]) {
for my $j (0 .. scalar @{$matrix[$i]} - 1) {
if ($matrix[$i][$j] == $input) {
$output = 1;
last;
}
}
last;
}
}
for my $i (0 .. scalar @matrix - 1) {
print $i ? q{ } : 'matrix: ';
say q{[ }, (join q{, }, map { sprintf("%2d", $_); } @{$matrix[$i]}), q{ ]};
}
say "\nInput: ", $input;
say $output;
Challenge 2:
Ordered Letters
Given a word, you can sort its letters alphabetically (case insensitive). For example, “beekeeper” becomes “beeeeekpr” and “dictionary” becomes “acdiinorty”.
Write a script to find the longest English words that don’t change when their letters are sorted.
This was a fun and interesting little problem. Unix systems usually have a pretty extensive word list. On my Ubuntu Linux
machine, it's in /usr/share/dict/words. I thought it best to take the path to the word list from the command line just in case
it is in some other location on other machines.
sub MAIN(
Str $filename
) {
my $longest = q{};
Then I simply go through the file (it has one word per line) and do the required transformation on each word. If the transformed word is the same as its original form, its length is examined and if it is the longest seen so far it is stored away.
for $filename.IO.lines -> $line {
chomp $line;
if $line.lc ~~ $line.lc.comb.sort.join && $line.chars > $longest.chars {
$longest = $line;
}
}
After all words have been checked, the longest word that fits the criterion seen so far is printed.
say $longest;
}
In the Perl version I followed my habitual practice of slurping up the entire file and then splitting it into lines. my $filename = shift // die "Need a filename\n";
open my $file, '<' , $filename or die "$OS_ERROR\n";
local $RS = undef;
my @lines = split "\n", <$file>;
close $file;
Other than that, it is the same as in Raku.
my $longest = q{};
for my $line (@lines) {
chomp $line;
if (lc $line eq (join q{}, sort split //, lc $line) &&
length $line > length $longest) {
$longest = $line;
}
}
say $longest;
Oh, in case you were wondering, the longest word I found that doesn’t change when its' letters are sorted is "billowy."