Perl Weekly Challenge: Code of Many Colors

Posted on by

Perl Weekly Challenge 388‘s tasks are “Dyck Words” and “Secret Santa”.

Well, normally my brain would work like this: I think “Dyck” sounds like “Dyke”, which reminds me of Dick Van Dyke, and that makes me think…

Then yesterday we all got the news: Dolly Parton died. So let’s enjoy some Santa-adjacent Dolly Parton music: Hard Candy Christmas.

But as I was finishing up, I heard Dolly’s voice in my head:

🎶 Now I know we had no money, but I was rich as I could be 🎶
🎶 With my code of many colors that my mama taught to me 🎶

Task 1: Dyck Words

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")

Approach

Ok, after looking at the problem for a little bit, I realized that the way to solve this is using recursion. Let’s look at the base case: $n = 0. That’s easy: a single empty string. No prefix exists of this string where there are more U‘s than D‘s.

Then we look at $n+1. We know that the strings returned by $n are valid Dyck words, so all we have to do is add the letters U and D to those strings such that they won’t violate the condition of having a prefix where there are more U‘s than D‘s. Fortunately, there are three ways to do this: add UD to the beginning of the string (thus increasing the count of U‘s than D‘s in any prefix equally), add UD to the end of the string (all the prefixes up to length 2n are previously known valid Dyck words, and the prefix of length 2n+1 will have one more U, and the prefix of length 2n+2 will both an additional U and an additional D), or add U to the beginning of the string, and then add D to the end of the string (all prefixes up to 2n+1 will have one more U than D, and 2n+2 will have equal numbers of U‘s and D‘s). If we added a D character before a U character, we would get prefixes where there were more D‘s than U‘s. This will, of course, produce a couple duplicate answers, so we just filter the list to remove duplicates before returning the answer.

Except when I ran this algorithm, I wound up missing one of the words when $n = 4: UUDDUUDD. This is because UDDUUD isn’t a valid Dyke word (adding a U to the beginning and a D to the end), but it is taking one of the Dyck words from $n = 2 (UUDD) and adding itself to either the beginning or the end. In fact, if we took UUDD and split it into UU and DD and added them to the beginning and the end, we’d wind up with UUUUDDDD, which is one of the valid Dyck words already being generated. So I realized the general algorithm isn’t just adding UD to all the Dyck words for $n - 1, it’s looping over values $i from 1 to trunc($n/2), and then getting the list of words for $n - $i and appending the words from $n = $i using my before/after/split method. For $i = 1, it’s just UD I’m splitting and appending. But for $i = 2, I’m also doing to split and append UDUD and UUDD.

Raku

In Raku, because there’s a div operator, I didn’t have to divide and truncate.

sub dyckWords($n) {
  return [""]   if $n == 0; # base cases
  return ["UD"] if $n == 1;
  
  my @new;
  for (1 .. ($n div 2)) -> $i {
    for dyckWords($n - $i) -> $word1 {
      for dyckWords($i) -> $word2 {
        @new.push($word2 ~ $word1);
        @new.push($word1 ~ $word2);
        my $pre  = $word2.substr(0, $i);
        my $post = $word2.substr($i);
        @new.push($pre ~ $word1 ~ $post);
      }
    }
  }
  @new.sort.unique;
}

View the entire Raku script for this task on GitHub.

$ raku/ch-1.raku
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")

Perl

In Perl, I had to import List::AllUtils’ uniq to get unique the values.

use List::AllUtils qw( uniq );

sub dyckWords($n) {
  return ("")   if $n == 0; # base cases
  return ("UD") if $n == 1;
  
  my @new;
  for my $i (1 .. int($n / 2)) {
    for my $word1 (dyckWords($n - $i)) {
      for my $word2 (dyckWords($i)) {
        push @new, $word2 . $word1;
        push @new, $word1 . $word2;
        my $pre  = substr($word2, 0, $i);
        my $post = substr($word2, $i);
        push @new, $pre . $word1 . $post;
      }
    }
  }
  uniq sort @new;
}

View the entire Perl script for this task on GitHub.

Python

In Python, you can make the elements of a list unique by converting the list into a set().

def dyck_words(n):
  if n == 0: return [""]
  if n == 1: return ["UD"]
  new = []
  for i in range(1, int(n/2)+1):
    for word1 in dyck_words(n - i):
      for word2 in dyck_words(i):
        new.append(word2 + word1)
        new.append(word1 + word2)
        new.append(word2[0:i] + word1 + word2[i:])
  return sorted(set(new))

View the entire Python script for this task on GitHub.

Elixir

And in Elixir, you use Enum.uniq/1.

def dyck_words(n) when n == 0, do: [""]
def dyck_words(n) when n == 1, do: ["UD"]
def dyck_words(n) do
  Enum.reduce(1..Integer.floor_div(n,2), [], fn i, new ->
    Enum.reduce(dyck_words(n - i), new, fn word1, new ->
      Enum.reduce(dyck_words(i), new, fn word2, new ->
        pre  = String.slice(word2, 0, i)
        post = String.slice(word2, i, i*2)
        new ++ [
          word2 <> word1,
          word1 <> word2,
          pre <> word1 <> post
        ]
      end)
    end)
  end)
  |> Enum.sort |> Enum.uniq
end

View the entire Elixir script for this task on GitHub.

Task 2: Secret Santa

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.

Approach

The most straightforward way is to just calculate the permutations of numbers from 1..$n and then remove the invalid permutations. In three of the languages I’m writing in, there’s a library function to generate the permutations.

I’m sure there’s a mathematical way to do this where we calculate the number of permutations there are where the ith element of the permutation isn’t i, and then subtract number that from n!, but I’m tired and the math part of my brain is rusty.

Raku

In Raku, it’s Any’s .permutations.

sub secretSanta($n) {
  my @valid;
  for (1 .. $n).permutations -> @perm {
    my $is_valid = 1;
    for 0 .. $n-1 -> $i {
      if (@perm[$i] == $i+1) {
        $is_valid = 0;
        last;
      }
    }
    @valid.push(@perm) if $is_valid;
  }
  @valid.elems;
}

View the entire Raku script for this task on GitHub.

$ raku/ch-2.raku
Example 1:
Input: $n = 1
Output: 0

Example 2:
Input: $n = 2
Output: 1

Example 3:
Input: $n = 3
Output: 2

Example 4:
Input: $n = 4
Output: 9

Example 5:
Input: $n = 5
Output: 44

Perl

In Perl, it’s Algorithm::Combinatorics’ permutations.

use Algorithm::Combinatorics qw(permutations);

sub secretSanta($n) {
  my @valid;
  my $iter = permutations([1 .. $n]);
  while (my $perm = $iter->next) {
    my $is_valid = 1;
    for my $i ( 0 .. $n-1 ) {
      if (@$perm[$i] == $i+1) {
        $is_valid = 0;
        last;
      }
    }
    push @valid, $perm if $is_valid;
  }
  scalar @valid;
}

View the entire Perl script for this task on GitHub.

Python

In Python, it’s the permutations function from itertools.

from itertools import permutations

def secret_santa(n):
  valid = []
  for perm in permutations(list(range(1, n+1))):
    is_valid = 1
    for i in range(n):
      if perm[i] == i+1:
        is_valid = 0
        continue
    if is_valid: valid.append(perm)
  return len(valid)

View the entire Python script for this task on GitHub.

Elixir

Elixir doesn’t have a built-in permutations function, but back in PWC 344 I discovered it’s incredibly easy to roll your own. I could have just put Range.to_list(1 .. n) in where I have the variable nums on line 13, but that would make the line length long enough you’d have to scroll horizontally in this blog, so I assigned it to a variable instead.

defp permutations([]), do: [[]]

defp permutations(list) do
  for head <- list, rest <- permutations(list -- [head]),
    do: [head|rest]
end

def secret_santa(n) do
  nums = Range.to_list(1 .. n)
  Enum.reduce(permutations(nums), [], fn perm, valid ->
    is_valid = Enum.reduce_while(0 .. n-1, 1, fn i, _ ->
      if Enum.at(perm, i) == i+1,
        do: {:halt, 0},
        else: {:cont, 1}
    end)
    if is_valid == 1, do: valid ++ [perm], else: valid
  end)
  |> length
end

View the entire Elixir script for this task on GitHub.

Here’s all my solutions in GitHub: https://github.com/packy/perlweeklychallenge-club/tree/challenge-388-packy-anderson/challenge-388/packy-anderson

Leave a Reply