Perl Weekly Challenge: Week 300
Challenge 1:
Beautiful Arrangement
You are given a positive integer,
$int.Write a script to return the number of beautiful arrangements that you can construct.
A permutation of n integers, 1-indexed, is considered a beautiful arrangement
if for every i (1 <= i <= n) either of the following is true:
1) perm[i] is divisible by i
2) i is divisible by perm[i]
Example 1
Input: $n = 2
Output: 2
1st arrangement: [1, 2]
perm[1] is divisible by i = 1
perm[2] is divisible by i = 2
2nd arrangement: [2, 1]
perm[1] is divisible by i = 1
i=2 is divisible by perm[2] = 1
Example 2
Input: $n = 1
Output: 1
Example 3
Input: $n = 10
Output: 700
I was reading up on algorithms and learned (or rather relearned because I'm sure I did this sort of thing in university many years ago) that a backtracking algorithm is good for combinatorial problems such as this.
The main function is extremely simple. All it does is recursively call the backtrack()
function with the $int which is our input and an initial position of 1.
say backtrack($int, 1);
This is backtrack().
sub backtrack($int, $pos) {
We create an array initialized with a number of False values equal to the value of $int plus 1, indicating that no numbers have been used yet. By declaring it a state variable, we ensure that the
array will retain its state across recursive calls.
state @used = False xx ($int + 1);
This variable will hold how many Beautiful Arrangements have been constructed.
my $count = 0;
Every recursive function needs a 'halting conditionso it does not go on forever. In this case,
if the current position is greater than$int`, it means a Beautiful Arrangement has been found so
1 is returned.
if $pos > $int {
return 1;
}
Now we iterate over the range 1 to $int...
for 1 .. $int -> $i {
...and if the number $i has not been @used and the current position is divisible by $i or $i is
divisible by the current position, we mark $i as @used, and recursively call backtrack() with the
next position, adding its' result to $count. Then we unmark it again.
if !@used[$i] && ($i %% $pos || $pos %% $i) {
@used[$i] = True;
$count += backtrack($int, $pos + 1);
@used[$i] = False;
}
}
Finally we should have the total number of Beautiful Arrangements in $count which we return for output.
return $count;
}
For the Perl version, we will be making use of the new, experimental true and false builtins
so these 2 lines are needed at the top of the script.
use builtin qw/ true false /;
no warnings 'experimental::builtin';
This is what backtrack() looks like:
sub backtrack($int, $pos) {
state @used = false x ($int + 1);
my $count = 0;
if ($pos > $int) {
return 1;
}
for my $i (1 .. $int) {
Because we dont have the %% operator in Perl, we have to explicitly check if
numbers are evenly divisble.
if (!$used[$i] && ($i % $pos == 0 || $pos % $i == 0)) {
$used[$i] = true;
$count += backtrack($int, $pos + 1);
$used[$i] = false;
}
}
return $count;
}
Challenge 2:
Nested Array
You are given an array of integers,
@intsof lengthncontaining permutation of the numbers in the range `[0, n - 1].Write a script to build a set,
set[i] = ints[i], ints[ints[i]], ints[ints[ints[i]]], ..., subjected to the following rules:
1. The first element in set[i] starts with the selection of elements ints[i].
2. The next element in set[i] should be ints[ints[i]], and then ints[ints[ints[i]]], and so on.
3. We stop adding right before a duplicate element occurs in set[i].
Return the longest length of a set
set[i].
Example 1
Input: @ints = (5, 4, 0, 3, 1, 6, 2)
Output: 4
ints[0] = 5
ints[1] = 4
ints[2] = 0
ints[3] = 3
ints[4] = 1
ints[5] = 6
ints[6] = 2
One of the longest sets set[k]:
set[0] = {ints[0], ints[5], ints[6], ints[2]} = {5, 6, 2, 0}
Example 2
Input: @ints = (0, 1, 2)
Output: 1
Once again, MAIN() is very short.
say longestSet(@ints);
The longestSet() function takes the list of @ints as its' paramaeters.
sub longestSet(@ints) {
First storage is set up for the length of the longest set.
my $maxLength = 0;
Then we iterate over the list of @ints with $i as the index of the current element,
and $val as its' value.
for @ints.kv -> $i, $val {
We create a hash to keep track of the indices that have been visited.
my %seen;
The current index is initialized to the starting index for this iteration.
my $current = $i;
And the current length of the set is initialized to 9.
my $length = 0;
Now until the current index is revisited...
while !%seen{$current} {
...we mark it as visited...
%seen{$current} = True;
...move to the next index as determined by the value of the current element...
$current = @ints[$current];
...and increase the length of the set.
$length++;
}
By now we have a set. If it is longer than the current longest set, it becaomes the new longest set.
if $length > $maxLength {
$maxLength = $length;
}
}
The length of the longest set is returned for output.
return $maxLength;
}
This is the Perl version. It also uses the experimental true and false builtins.
sub longestSet(@ints) {
my $maxLength = 0;
For the longest time I didn't think Perl had anything like Raku's .kv() method then during
a previous challenge, I discovered each() which, though it is hard to guess from the name, does the
same thing.
while (my ($i, $val) = each @ints) {
my %seen;
my $current = $i;
my $length = 0;
while (!$seen{$current}) {
$seen{$current} = true;
$current = $ints[$current];
$length++;
}
if ($length > $maxLength) {
$maxLength = $length;
}
}
return $maxLength;
}