Perl Weekly Challenge: Week 382
Challenge 1:
Hamiltonian Cycle
You are given a target number.
Write a script to arrange all the whole numbers from 1 up to the given target number into a circle so that every pair of side-by-side numbers adds up to a perfect square. Please make sure, the last number and the first must also add up to a square.
Example 1
Input: $n = 32
Output: 1, 8, 28, 21, 4, 32, 17, 19, 30, 6, 3, 13, 12, 24, 25, 11, 5, 31, 18, 7,
29, 20, 16, 9, 27, 22, 14, 2, 23, 26, 10, 15
1 + 8 = 9
8 + 28 = 36
28 + 21 = 49
21 + 4 = 25
4 + 32 = 36
32 + 17 = 49
17 + 19 = 36
19 + 30 = 49
so on, all the way through the sequence.
Example 2
Input: $n = 15
Output: ()
No valid circular list of numbers exists.
Example 3
Input: $n = 34
Output: 1, 3, 13, 12, 4, 32, 17, 8, 28, 21, 15, 34, 30, 19, 6, 10, 26, 23, 2, 14,
22, 27, 9, 16, 33, 31, 18, 7, 29, 20, 5, 11, 25, 24
I remembered enough of my university computer science education to know that Hamiltonian cycles are something to do with graph theory but I had to read up on the specifics. Some googling later, I came up with this which might not be the optimal solution but works.
The MAIN() function is very simple. The search() and buildGraph() functions
(to be described below) do all the work.
my @circle = search($n, buildGraph($n));
If a circle was found and it is not empty, it is printed out. Otherwise () is printed.
say @circle.elems ?? @circle.join(q{, }) !! '()';
The buildGraph() function, as the name suggests, builds the graph that will be
checked for Hamiltonian cycles. The graph is represented as an adjacency list in
a hash. The keys of the hash are each integer and the values are the integers
thst can follow.
sub buildGraph($n) {
my %graph;
for 1 .. $n -> $i {
for 1 .. $n -> $j {
if $i == $j {
next;
}
We can optimize and simplify the graph considerably by only adding edges between numbers that can form a square.
if isSquare($i + $j) {
%graph{$i}.push($j);
}
}
}
return %graph;
}
isSquare(), by the way, is the function that checks if a number is a square. It
simply takes the square root of the number (converting to an integer if necessary)
and then squares that. If we end up with the same number we started with, it is
a square.
sub isSquare($x) {
my $r = $x.sqrt.Int;
return $r * $r == $x;
}
search() does a backtracking search for a Hamiltonian cycle. It takes $n and
the graph as parameters.
sub search($n, %graph) {
We fix the starting point as 1.
my @path = (1);
my %used = 1 => 1;
An inner function conducts a depth-first search starting at the current position (i.e. the current integer).
my $dfs = sub ($pos) {
If we are at the last integer, we check if it forms a square with the first integer in order to complete the circle. If there is a circle True or False is returned
based on the result of this check.
if $pos == $n {
# Check last with first
return isSquare(@path[*-1] + @path[0]);
}
For all other integers, we recursively run dfs() with all the next edges in the
graph, making sure they have not already been used.
my $current = @path[*-1];
for @(%graph{$current}) -> $next {
if %used{$next} {
next;
}
%used{$next} = 1;
push @path, $next;
If that call to dfs() returns True, this call can do so as well. In this
way we can propogate the return value up through the chain of recursive calls.
if $dfs($pos + 1) {
return True;
}
Otherwise we clean up and move on to the next edge.
pop @path;
%used{$next}:delete;
}
If we have exhausted all the next edges and failed to grow the path any further,
this is not a Hamiltonian cycle so we return False.
return False;
};
This is the initial call to the dfs() function starting from the first integer,
1. IF after all the recursion it returns True we know @path contains a
full Hamiltonian cycle meeting the specs' criteria so we return it. Otherwise
we return an empty list.
return $dfs(1) ?? @path !! ();
}
Translating the Raku version to Perl was fairly easy and didn't require any extra code. Perls' syntax for references is a bit ungainly but this is a minor irritant at best.
sub isSquare($x) {
my $r = int(sqrt($x));
return $r * $r == $x;
}
sub buildGraph($n) {
my %graph;
for my $i (1 .. $n) {
for my $j (1 .. $n) {
if ($i == $j) {
next;
}
if (isSquare($i + $j)) {
push @{ $graph{$i} }, $j;
}
}
}
return \%graph;
}
sub search($n, $adj) {
my @path = (1);
my %used = (1 => 1);
Using variables defined in an outer subroutine within an inner subroutine causes
warnings about "veriable will not stayed shared..." unless you jump through some
hoops. I had to make $dfs an alias to a package (i.e. global) variable with
our and add the declaration use vars qw/ $dfs /; at the top of the script to
supress all warnings.
our $dfs = sub ($pos) {
if ($pos == $n) {
return isSquare($path[-1] + $path[0]);
}
my $current = $path[-1];
for my $next (@{ $adj->{$current} || [] }) {
if ($used{$next}) {
next;
}
$used{$next} = 1;
push @path, $next;
if ($dfs->($pos + 1)) {
return true;
}
pop @path;
delete $used{$next};
}
return false;
};
return $dfs->(1) ? \@path : undef;
}
my $circle = search($n, buildGraph($n));
say $circle ? (join q{, }, @{$circle}) : '()';
Challenge 2:
Replace Question Mark
You are given a string that contains only 0, 1 and ? characters.
Write a script to generate all possible combinations when replacing the question marks with a zero or one.
Example 1
Input: $str = "01??0"
Output: ("01000", "01010", "01100", "01110")
Example 2
Input: $str = "101"
Output: ("101")
Example 3
Input: $str = "???"
Output: ("000", "001", "010", "011", "100", "101", "110", "111")
Example 4
Input: $str = "1?10"
Output: ("1010", "1110")
Example 5
Input: $str = "1?1?0"
Output: ("10100", "10110", "11100", "11110")
This challenge was considerably easier.
In MAIN(), we first break up $str into a list of individual characters.
my @chars = $str.comb;
We also define storage for any combinations we might find.
my @combinations;
The generate() function does all the work. It will be explained below.
generate(q{}, 0, @chars, @combinations);
Finally all the combinations (if any) are printed out. This code is slightly more complex so the output matches the style of the spec.
say q{(}, @combinations.map({ "\"$_\"" }).join(q{, }), q{)};
The generate() function takes 4 paramters. The first is the prefix of
a combination in progress. In the call to generate() in MAIN(), this is
initially an empty string. The second is the index of our current position in
@chars; initially, this is 0. The third and fourth are @chars and @combinations.
sub generate($prefix, $index, @chars, @combinations) {
If we have reached the last character in @chars, the combination is complete;
we can add it to @combinations and return.
if $index == @chars.elems {
@combinations.push($prefix);
return;
}
Other we examine the current character.
my $char = @chars[$index];
If it is a question mark, there are two possibilities; it can be replaced by 0
or 1. We recursively call generate() for the next character two times with each of the two possibilites added to the current combination
if $char eq '?' {
generate($prefix ~ '0', $index + 1, @chars, @combinations);
generate($prefix ~ '1', $index + 1, @chars, @combinations);
}
Otherwise the current character is appended to our combination in progress and
call generate() again to deal with the next character.
else {
generate($prefix ~ $char, $index + 1, @chars, @combinations);
}
}
Once again there was little difficulty in translating from Raku to Perl.
sub generate($prefix, $index, $chars, $combinations) {
if ($index == @{$chars}) {
push @{$combinations}, $prefix;
return;
}
my $char = $chars->[$index];
if ($char eq '?') {
generate($prefix . '0', $index + 1, $chars, $combinations);
generate($prefix . '1', $index + 1, $chars, $combinations);
}
else {
generate($prefix . $char, $index + 1, $chars, $combinations);
}
}
my @chars = split //, $str;
my @combinations;
generate('', 0, \@chars, \@combinations);
say q{(}, (join q{, }, map { "\"$_\"" } @combinations), q{)};