Perl Weekly Challenge 388.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 388.
Task 1: Dyck Words
Submitted by: Roger Bell_West
A Dyck Word of order $n is a string of length 2x$n consisting 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 consider a function n,m->f(n,m) equal to the number of valid ways in
which I can take n pairs of letters of the form UU UD DU and
DD so that the excess of U’s over D’s is 2m. Take any of those
strings and split off the last pair. It may be UU, in which case
the remaining string would have n-1 pairs and an excess m-1; it
may be DD so the remaining string would have an excess m+1, and it
could be UD or DU, in which case, the remaining string would have
an excess m. Any string with a negative excess would be
invalid. Thus, we have a recursive relation,
f(n,m)=f(n-1,m-1)+2f(n-1,m)+f(n-1,m+1). There is an exception if
m=0, as the left to right count of U’s - D’s should never be
negative, so f(n,0)=f(n-1,0)+f(n-1,1). Furthermore, we have the
boundary conditions f(n,m)=0 if m>n or m<0, and f(0,0)=1. With this
ingredients, we can build a recursive procedure to count how many
valid strings there are. The program fits a two-liner
Examples:
perl -MMemoize -E '
memoize "f";for(@ARGV){say"$_ -> ", f($_,0)}sub f($n,$m){return 0 if $m<0||$m>$n;return
1 if$n==0;--$n;return f($n,0)+f($n,1) if $m==0;f($n,$m-1)+2*f($n,$m)+f($n,$m+1)}
' 1 2 3 0 4
Results:
1 -> 1
2 -> 2
3 -> 5
0 -> 1
4 -> 14
The numbers agree with the results in the problem statement.
Furthermore, I can generate the actual strings using a similar recursive
procedure and appending “UU”, “UD”, “DU” or “DD” to the previously
generated strings, according to the to the desired transition
m-1->m, m->m or m+1->m. The result fits a three-liner.
Examples:
perl -MMemoize -E '
memoize "f";for(@ARGV){say"$_ -> ", join " ",f($_,0)}sub f($n,$m){return()if$m<0||$m>$n;
return("")if$n==0;--$n;return (map{$_."UD"}f($n,0)),(map{$_."DD"}f($n,1))if$m==0;
(map{$_."UU"}f($n,$m-1)),(map{$_."UD",$_."DU"}f($n,$m)),map{$_."DD"}f($n,$m+1)}
' 1 2 3 0 4
Results:
1 -> UD
2 -> UDUD UUDD
3 -> UDUDUD UUDDUD UDUUDD UUUDDD UUDUDD
0 ->
4 -> UDUDUDUD UUDDUDUD UDUUDDUD UUUDDDUD UUDUDDUD
UDUDUUDD UUDDUUDD UDUUUDDD UDUUDUDD UUUDUDDD
UUUDDUDD UUDUUDDD UUDUDUDD UUUUDDDD
I used memoize to avoid unnecessary recalculation of sets of strings.
The full code is:
1 # Perl weekly challenge 388
2 # Task 1: Dyck Words
3 #
4 # See https://wlmb.github.io/2026/08/24/PWC388/#task-1-dyck-words
5 use v5.36;
6 use Memoize;
7 use Text::Wrap qw(wrap $columns);
8 die <<~"FIN" unless @ARGV;
9 Usage: $0 N0 N1...
10 to find all words formed by Nm letters U and Nm letters D
11 so that no prefix has more D's than U's.
12 FIN
13 memoize "dyck";
14 $columns = 60;
15 for(@ARGV){
16 say wrap "", "\t", "$_ -> ", map {"\"". $_ ."\""} dyck($_);
17 }
18
19 sub dyck($n,$m=0){
20 return () if$m<0||$m>$n;
21 return("") if $n==0;
22 return ( map {$_ . "UD"} dyck( $n-1, 0) ),
23 map {$_ . "DD"} dyck( $n-1, 1)
24 if $m == 0;
25 return ( map {$_ . "UU"} dyck($n-1, $m-1) ),
26 ( map {$_ . "UD", $_ . "DU"} dyck($n-1, $m) ),
27 map {$_ . "DD" } dyck($n-1, $m+1);
28 }
Examples:
./ch-1.pl 1 2 3 0 4
Results:
1 -> "UD"
2 -> "UDUD" "UUDD"
3 -> "UDUDUD" "UUDDUD" "UDUUDD" "UUUDDD" "UUDUDD"
0 -> ""
4 -> "UDUDUDUD" "UUDDUDUD" "UDUUDDUD" "UUUDDDUD" "UUDUDDUD"
"UDUDUUDD" "UUDDUUDD" "UDUUUDDD" "UDUUDUDD"
"UUUDUDDD" "UUUDDUDD" "UUDUUDDD" "UUDUDUDD"
"UUUUDDDD"
Task 2: Secret Santa
Submitted by: Roger Bell_West
A company with $n employees 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 $i must 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.
A very lazy solution can be obtained using the derangements function
from the Algorithm::Combinatorics package, which yields all
reorderings of an array so that no element remains in
its place. The code takes a half-liner:
perl -MAlgorithm::Combinatorics=derangements -E '
say "$_ -> ", $x=()=derangements([1..$_]) for @ARGV;
' 1 2 3 4 5
Results:
1 -> 0
2 -> 1
3 -> 2
4 -> 9
5 -> 44
Note the use of the Saturn operator.
For the full code I compute the number of derangements using a
recursive formula d(n)=n*d(n-1)+(-1)**n with initial value d(0)=1,
without computing the actual derangements.
1 # Perl weekly challenge 388
2 # Task 2: Secret Santa
3 #
4 # See https://wlmb.github.io/2026/08/24/PWC388/#task-2-secret-santa
5 use v5.36;
6 use Memoize;
7 sub derange($n){
8 die "Argument should be non-negative: $n" if $n<0;
9 return 1 if $n==0;
10 return $n*derange($n-1)+($n%2==0?1:-1);
11 }
12 die <<~"FIN" unless @ARGV;
13 Usage: $0 N0 N1...
14 to find the number of derangements of Ni elements
15 FIN
16 memoize qw(derange);
17 say "$_ -> ", join " ", derange $_ for @ARGV;
Example:
./ch-2.pl 1 2 3 4 5
Results:
1 -> 0
2 -> 1
3 -> 2
4 -> 9
5 -> 44