Perl Weekly Challenge: Week 388
Challenge 1:
Dyck Words
A Dyck Word of order
$nis a string of length2x$nconsisting of$n‘U’ (Up) characters and$n‘D’ (Down) characters such that no initial prefix of the string contains more ‘D’s than ‘U’s.Write a script to return a list of all valid Dyck words of length
2x$n, sorted in lexicographical (alphabetical) order.
Example 1
Input: $n = 1
Output: ("UD")
Example 2
Input: $n = 2
Output: ("UDUD","UUDD")
Example 3
Input: $n = 3
Output: ("UDUDUD", "UDUUDD", "UUDDUD", "UUDUDD", "UUUDDD")
Example 4
Input: $n = 0
Output: ("")
Example 5
Input: $n = 4
Output: ("UDUDUDUD", "UDUDUUDD", "UDUUDDUD", "UDUUDUDD", "UDUUUDDD",
"UUDDUDUD", "UUDDUUDD", "UUDUDDUD", "UUDUDUDD", "UUDUUDDD",
"UUUDDDUD", "UUUDDUDD", "UUUDUDDD", "UUUUDDDD")
I had never even heard of Dyck words before but after some extensive googling, I think I've come up with a pretty elegant solution to this challenge.
MAIN() is very short. It simply calls the dyckWords() function to create a list
of valid words...
my @words = dyckWords($n, 0, 0, q{});
...sorts them as the spec requires and prints them out in the same format as in the examples.
say q{(}, @words.sort.map({ "\"$_\"" }).join(', '), q{)};
The dyckWords() is a recursive function that does a depth-first search to generate the
list of Dyck words. It takes four parameters: $n from the input, the current
number of 'up' characters (intially 0,) the current number of 'down' characters
(also initially 0,) and the 'prefix' of the current Dyck word which will be
explained later. The prefix is initally an empty string.
sub dyckWords($n, $up, $down, $prefix) {
A recursive function needs a base case. If the length of the prefix
is 2 * $n it means a complete Dyck word has been built so it is returned.
if $prefix.chars == 2 * $n {
return ($prefix);
}
Otherwise an array is defined to hold the found words...
my @words;
...and dyckWords() is called recursively. There are two scenarios of interest.
One is if the number of up characters so far is less than $n. Or in other words,
if the number of Us in the current Dyck word so far is less than half of the final length
of the word. In this case, $up is increased by 1 and a U is appended to the prefix
before dyckWords() is called again.
if $up < $n {
@words.push(| dyckWords($n, $up + 1, $down, $prefix ~ 'U'));
}
The second case is if the number of Ds is less than the number of Us in the current Dyck
word so far. We want an equal number of both so this time $down is increased by 1 and
a D is appended to the prefix before dyckWords() is called again.
if $down < $up {
@words.push(| dyckWords($n, $up, $down + 1, $prefix ~ 'D'));
}
Each recursive branch returns a list of completed words, and .push(| ...) flattens those returned lists into the single @words array.
Finally after the search has been exhausted, we return the complete list of Dyck words.
return @words;
}
The Perl version works exactly the same as in Raku.
sub dyckWords($n, $up, $down, $prefix) {
if (length $prefix == 2 * $n) {
return ($prefix);
}
my @words;
if ($up < $n) {
push @words, dyckWords($n, $up + 1, $down, $prefix . 'U');
}
if ($down < $up) {
push @words, dyckWords($n, $up, $down + 1, $prefix . 'D');
}
return @words;
}
my @words = dyckWords($n, 0, 0, q{});
say q{(}, (join q{, }, map { "\"$_\"" } sort @words), q{)};
Challenge 2:
Secret Santa
A company with
$nemployees is running a Secret Santa exchange. Each employee buys one gift and receives one gift.Write a script to return the total number of valid gift assignments where no employee receives the gift they originally bought (i.e., employee
$imust not be assigned gift$i).
Example 1
Input: $n = 1
Output: 0
Only 1 participant exists. They would have to receive their own gift, which is invalid.
Example 2
Input: $n = 2
Output: 1
Participants 1 and 2 must swap gifts ([2, 1]).
Example 3
Input: $n = 3
Output: 2
The 2 valid gift arrays where array[i] is who person i+1 receives from:
[2, 3, 1]
[3, 1, 2]
Example 4
Input: $n = 4
Output: 9
The 9 valid arrays are:
[2, 1, 4, 3], [2, 3, 4, 1], [2, 4, 1, 3],
[3, 1, 4, 2], [3, 4, 1, 2], [3, 4, 2, 1],
[4, 1, 2, 3], [4, 3, 1, 2], [4, 3, 2, 1],
Example 5
Input: $n = 5
Output: 44
There are 44 valid permutations out of 5! = 120 total possible arrangements.
First we model the participants as a sequence of integers from 1 to $n.
my @participants = 1 .. $n;
We also need to keep track of how many valid secret santa assignments we have found. It is initialized to 0.
my $count = 0;
The key to the solution is found in the spec; the word 'permutation. Raku has
a standard library method called.permutations()which will give us all the
permutations of@participants`.
for (1 .. $n).permutations -> $perm {
However, we can only count a permutation as valid if all of the elements in the
same position in @participants and the permutation are different. We can
check that very quickly and concisely with Z== which compares two arrays element
by element for equality and .all == False which will only have a True value
if all the comparisons are False.
if (@participants Z== @$perm).all == False {
In that case the permutation is valid and we increment $count.
$count++;
}
}
Finally, when all the permutations have been tested, we print $count.
say $count;
Converting the Raku version to Perl requires some work.
my @participants = 1 .. $n;
my $count = 0;
For a start, we need a replacement
for .permutations(). For that I have permute() which I used in previous challenges.
PERMUTATION: for my $perm (permute(@participants)) {
Also we don't have Z== and .all(). I got around this by just looping through
the indices of @participants and comparing the element at each index with the
equivalant in the current permutation. If the two should be equal, (i.e. the participant
is receiving his own gift,) the permutation is invalid and we move on to the next one.
for my $i (keys @participants) {
if ($participants[$i] == $perm->[$i]) {
next PERMUTATION;
}
}
If all the pairs of elements are different, we increment $count.
$count++;
}
say $count;