The Weekly Challenge
This is where I post my solutions to The Weekly Challenge and try to write a bit about the problems.
Corrections - Week 289
Thu Oct 3 20:20:55 CEST 2024
- As can be seen in the words containing an em dash
of this week's second task,
dealing with utf-8 code or data requires
the
utf8pragma or marking the filehandle with":utf8".
Week 289 - Third Maximum & Jumbled Letters
Mon Sep 30 21:14:53 CEST 2024
The first task can be solved with some help from the List::Util module by creating a list of unique integers sorted in descending order and then getting the third element of that list, or the first if it is shorter than three.
#!/usr/bin/perl
use v5.40;
use Test::More tests => 3;
use List::Util qw(uniq);
sub get_third_maximum {
my @l = uniq sort { $b <=> $a } @_;
return @l > 2 ? $l[2] : $l[0];
}
is(get_third_maximum(5, 6, 4, 1), 4);
is(get_third_maximum(4, 5), 5);
is(get_third_maximum(1, 2, 2, 3), 1);
My first idea was to split the input string on word boundaries
and take it from there.
Unfortunately, the task's definition of a word
is not quite the same as how
Perl's \b metasymbol thinks of a word.
Therefore I decided to let the substitution operator do
the work of finding words,
and then use the
/e modifier
to jumble the word in the replacement portion of the operator.
Obviously, only words that are four characters or longer need to be considered. Shorter words will appear the same when jumbled.
#!/usr/bin/perl
use v5.40;
use List::Util qw(shuffle);
my $s = <<END;
This supposed Cambridge research is unfortunately an urban legend. However,
the effect has been studied. For example—and with a title that probably
made the journal’s editor a little nervous—Raeding wrods with jubmled
lettres: there is a cost by Rayner, White, et. al. looked at reading speed
and comprehension of jumbled text.
END
say $s;
say $s =~ s/(\pL)(\pL{2,})(\pL)/$1 . (join '', shuffle(split q(), $2)) . $3/reg;
Lessons learned in week 288
Mon Sep 30 19:17:42 CEST 2024
It is funny how your mental model influences the way you perceive a problem and it's solution. Every schoolboy knows that a palindrome is something that reads the same backwards as forwards. I know that too, but despite knowing that and despite being equipped with a language which allows me to easily allocate new memory for a reversed string, I treated a palindrome as something whose first half reads the same as it's last half backwards, and created an overly complicated function for checking palindromeness. And no, it didn't even save me from allocating memory.
Good terms to know:
- DFS
- flood filling algorithm
- connectivity matrix
Week 288 - Closest Palindrome & Contiguous Block
Wed Sep 25 21:31:00 CEST 2024
Brute-forcing seems to be a fine way of dealing with the first task. A function to determine whether a string is a palindrome or not comes in handy for finding the previous and next palindromes, and then it is a matter comparing the two the right way around so that the lower is returned, should they be of equal distance from the given integer.
#!/usr/bin/perl
use v5.40;
use Test::More tests => 4;
sub is_palindrome {
my $l = length $_[0] / 2;
return ($l == 0
or substr($_[0], 0, $l) eq scalar reverse substr($_[0], -$l));
}
sub get_closest_palindrome {
my ($l, $h) = ($_[0] - 1, $_[0] + 1);
--$l until is_palindrome($l);
++$h until is_palindrome($h);
return $h - $_[0] < $_[0] - $l ? $h : $l;
}
is(get_closest_palindrome(123), 121);
is(get_closest_palindrome(2), 1);
is(get_closest_palindrome(1400), 1441);
is(get_closest_palindrome(1001), 999);
Some basic optimization could be added to this algorithm. Given that the previous palindrome has been found, searching for the next could be aborted as soon as it is known that none exists at a closer distance than the previous.
I thought of solving the second task by attaching a piece of data to each cell to indicate which block it belongs so that all cells of a contiguous block are marked with the same block id. Finding the largest block would then be about finding the block id attached to the most number of cells. The only remaining issue is then how to actually assign block ids.
My initial idea was to scan the matrix from top to bottom and left to right and to each cell assign the same block id as the previous cell if they contained the same character. I quickly realized that such an algorithm would have to include a mechanism to join blocks and reassign block ids, making it a bit too complicated.
While I kept the idea of block ids,
I choose – instead of scanning – to walk each block
and mark each cell in the block using a function
that is applied to each unmarked cell
(indicated by block id 0)
and then recursively to all that cell's
neighboring cells that contain the same character
and is yet unmarked.
The last part is important to avoid ending up in an infinite loop.
#!/usr/bin/perl
use v5.40;
use Test::More tests => 3;
sub mark_cell {
my ($matrix, $row, $column, $block) = @_;
$matrix->[$row][$column][1] = $block;
if ($row > 0
and $matrix->[$row - 1][$column][0] eq $matrix->[$row][$column][0]
and $matrix->[$row - 1][$column][1] == 0) {
mark_cell($matrix, $row - 1, $column, $block);
}
if ($column > 0
and $matrix->[$row][$column - 1][0] eq $matrix->[$row][$column][0]
and $matrix->[$row][$column - 1][1] == 0) {
mark_cell($matrix, $row, $column - 1, $block);
}
if ($row < $#$matrix
and $matrix->[$row + 1][$column][0] eq $matrix->[$row][$column][0]
and $matrix->[$row + 1][$column][1] == 0) {
mark_cell($matrix, $row + 1, $column, $block);
}
if ($column < $#{ $matrix->[0] }
and $matrix->[$row][$column + 1][0] eq $matrix->[$row][$column][0]
and $matrix->[$row][$column + 1][1] == 0) {
mark_cell($matrix, $row, $column + 1, $block);
}
}
sub get_largest_contiguous_block {
my $matrix = [ map { [ map { [ $_, 0] } @$_ ] } @{$_[0]} ];
my $block = 1;
my %sizes;
foreach my $row (0..$#$matrix) {
foreach my $column (0..$#{ $matrix->[0] }) {
unless ($matrix->[$row][$column][1]) {
mark_cell($matrix, $row, $column, $block++)
}
++$sizes{ $matrix->[$row][$column][1] };
}
}
return (sort { $b <=> $a } values %sizes)[0];
}
my $example1 = [
[ 'x', 'x', 'x', 'x', 'o' ],
[ 'x', 'o', 'o', 'o', 'o' ],
[ 'x', 'o', 'o', 'o', 'o' ],
[ 'x', 'x', 'x', 'o', 'o' ],
];
my $example2 = [
[ 'x', 'x', 'x', 'x', 'x' ],
[ 'x', 'o', 'o', 'o', 'o' ],
[ 'x', 'x', 'x', 'x', 'o' ],
[ 'x', 'o', 'o', 'o', 'o' ],
];
my $example3 = [
[ 'x', 'x', 'x', 'o', 'o' ],
[ 'o', 'o', 'o', 'x', 'x' ],
[ 'o', 'x', 'x', 'o', 'o' ],
[ 'o', 'o', 'o', 'x', 'x' ],
];
is(get_largest_contiguous_block($example1), 11);
is(get_largest_contiguous_block($example2), 11);
is(get_largest_contiguous_block($example3), 7);
Lessons learned in week 286
Mon Sep 16 19:58:52 CEST 2024
There is more than one way to get the name of the file containing the script of the first task, as well as the content of that file.
To get the file name,
we can use the $0 variable
or the __FILE__ token.
Either is a good alternative for the purpose of this script
as they will both give the same value,
but when used from a module, they may give different values.
The caller function could also be used.
It is not clear to me exactly what __FILE__ is,
but it seems to be a function.
It is referred to as a special literal
in the Camel Book,
but it also appears in the alphabetical list of functions.
In perlfunc, it is listed as a keyword.
As for getting the actual content of the file
(and apart from the quine way of doing it,
which of course is extra impressive),
we can use the open function in combination with
read or the diamond operator,
or we can, as
one contribution shows,
use the DATA file handle.
Week 286 - Self Spammer & Order Game
Mon Sep 9 19:48:37 CEST 2024
The first task, Self Spammer, seems rather straightforward. We open the current script, slurp it and split it into a list of words of which we randomly select one to print:
#!/usr/bin/perl
use v5.40;
open my $f, '<', $0;
undef $/;
@_ = split /\s+/, <$f>;
say $_[ int rand @_ ];
As for the second task,
I would not be surprised if there is some clever way
of sorting or manipulating the list so that the number of
calls to min() and max() can be minimized.
While thinking about that, let me present a solution to
Order Game
that simply plays the game according to the specification:
#!/usr/bin/perl
use v5.40;
use Test::More tests => 3;
use List::Util qw(min max pairs);
sub play_game {
return min(@_) if @_ == 2;
my $f = \&max;
return play_game(
map {
$f = $f == \&min ? \&max : \&min;
$f->($_->[0], $_->[1]);
} pairs @_
);
}
is(play_game(2, 1, 4, 5, 6, 3, 0, 2), 1);
is(play_game(0, 5, 3, 2), 0);
is(play_game(9, 2, 1, 4, 5, 6, 0, 7, 3, 1, 3, 5, 7, 9, 0, 8), 2);
That is a recursive function that stops
when the length of the list is two.
A core module helps creating pairs
and a variable that is alternately set
to min and max
helps interleaving those two calls.
Lessons learned in week 285
Sun Sep 8 14:16:47 CEST 2024
Making Change is indeed a classic problem and it turned out that it is included in George Pólya's How to Solve It which I actually had on a shelf in my bookcase. The recursive solution presented on the very last two pages of the book could be expressed like this in Perl:
#!/usr/bin/perl
use v5.40;
use Test::More tests => 3;
sub make_change {
my @coins = (1, 5, 10, 25, 50);
return 0 if (my $n = shift) < 0;
return 1 if (my $i = shift // $#coins) == 0;
return make_change($n, $i - 1) + make_change($n - $coins[$i], $i);
}
is(make_change(9), 2);
is(make_change(15), 6);
is(make_change(100), 292);
Like other contributions show, the core idea of computation by adding already known numbers can also be used to construct a table with as many rows and columns as is necessary to look up the answer.
Week 285
Sat Sep 7 15:31:58 CEST 2024
The first task, No Connection, gives rise to a number of questions. How many destinations with no further outgoing connections are there? Are there branches in the list of routes? Are there loops?
Assuming that there is only one route with no outgoing connection, the list of routes could be transformed into two lists of starting points and destinations, and the problem could then be solved by finding the element in the list of destination that does not appear in the list of starting points. This would provide an excellent opportunity to construct a glorious write-only one-liner of nested maps and greps, as well as a chance for optimization by sorting the list of starting points.
Assuming that there are no loops and that each starting point only leads to one destination, the problem could be solved by picking a random starting point and simply walking the routes until a destination with no outgoing connection is reached:
#!/usr/bin/perl
use v5.40;
use Test::More tests => 2;
sub get_no_connection {
my ($c) = my %r = map { $_->[0], $_->[1] } @_;
$c = $r{$c} while $r{$c};
return $c;
}
is(get_no_connection([ 'B', 'C' ], [ 'D', 'B' ], [ 'C', 'A' ]), 'A');
is(get_no_connection([ 'A', 'Z' ]), 'Z');
The second task, Making Change, is a bit trickier and has got the smell of a classic programming problem. I assume that there is an elegant and well known way of solving this problem that any real expert programmer is either familiar with or able to work out. I guess that the same goes for a skilled mathematician and that the solution involves something related to a tree with weighted nodes that can be multiplied or added, integer sequences or set theory.
I have not come across this problem before and I cannot immediately see the elegant way of solving this, so I have to, embarrassingly, resort to solving it by simply starting with a list of coins of as high denominations as possible and substituting each for lower denominations until a list of only pennies is reached.
The first thing to notice is that amounts that are not evenly divisible by five will be given as change in as many ways as the next lower amount that is divisible by five. For example, the amounts 5, 6, 7, 8 and 9 can all be given as change in two ways.
If we try to iteratively substitute coins for those of lower denominations, we will come across the problem of missing certain combinations of change. For example, if we for the amount 15 (a dime and a nickel) substitute the dime for two nickels, we will be able to find further combinations of nickels and pennies, but we will not find the combination of one dime and five pennies.
One way of getting around this problem by adding some depth to the algorithm, and for each substitution make further substitutions on a copy of the original list of coins. This will however introduce a new problem where certain combinations of change are found multiple times. For example, a dime can be split into two nickels, which in turn can be split into either one nickel and five pennies, or five pennies and one nickel, which in turn both can be split into ten nickels. An ugly way of getting around this problem is to keep track of the combinations found so far.
Furthermore, there is the problem of how to substitute one coin for coins of lower denominations. While quarters, dimes and nickels can all be substituted, either directly or indirectly, for all combinations of lower denominations, half-dollars can be substituted in two ways that cannot further be substituted for all combinations of lower denominations. If we split a half-dollar into two quarters, we will miss the combination of five dimes and vice versa.
There is of course also the question of how many ways the amount zero can be given as change.
A little helper function sets up the initial list of coins for a given a value and then starts the actual work of finding all ways of giving change:
#!/usr/bin/perl
use v5.40;
use List::Util qw(first);
use Test::More tests => 3;
my %coins = (
50 => [ [ 25, 25 ], [ 10, 10, 10, 10, 10 ] ],
25 => [ [ 10, 10, 5 ] ],
10 => [ [ 5, 5 ] ],
5 => [ [ 1, 1, 1, 1, 1 ] ],
1 => [ [1] ],
);
sub make_change {
my $n = shift;
my @l;
while ($n > 0) {
my $coin = first { $_ <= $n } sort { $b <=> $a } keys %coins;
push @l, $coin;
$n -= $coin;
}
return f([@l], {});
}
sub f {
my @l = sort @{ $_[0] };
my $h = $_[1];
return if exists $h->{"@l"};
$h->{"@l"} = 1;
foreach my $i (grep { $l[$_] != 1 } 0..$#l) {
foreach (@{ $coins{ $l[$i] } } ) {
my @a = @l;
splice @a, $i, 1, @{$_};
f([@a], $h);
}
}
return keys %$h;
}
is(make_change(9), 2);
is(make_change(15), 6);
is(make_change(100), 292);
Now I cannot wait to learn how to solve this problem in the proper way!