When the tasks have “letter” and “Santa”, there’s only one thing that came to my mind: Wakko Warner.
Onward to Perl Weekly Challenge 247!
Task 1: Secret Santa
Secret Santa is a Christmas tradition in which members of a group are randomly assigned a person to whom they give a gift.
You are given a list of names. Write a script that tries to team persons from different families.
Example 1
The givers are randomly chosen but don't share family names with the receivers.
Input: @names = ('Mr. Wall',
'Mrs. Wall',
'Mr. Anwar',
'Mrs. Anwar',
'Mr. Conway',
'Mr. Cross',
);
Output:
Mr. Conway -> Mr. Wall
Mr. Anwar -> Mrs. Wall
Mrs. Wall -> Mr. Anwar
Mr. Cross -> Mrs. Anwar
Mr. Wall -> Mr. Conway
Mrs. Anwar -> Mr. Cross
Example 2
One gift is given to a family member.
Input: @names = ('Mr. Wall',
'Mrs. Wall',
'Mr. Anwar',
);
Output:
Mr. Anwar -> Mr. Wall
Mr. Wall -> Mrs. Wall
Mrs. Wall -> Mr. Anwar
Approach
Ok, so this is like last week where we’re randomly picking elements from a list, but there are two added twists: when picking the gift recipient for person X, we always want to exclude person X from the result (so nobody is giving a gift to themselves), and we prefer to select a gift recipient who has a different family name. But we also want to make sure nobody is getting gifts from more that one person.
Honestly, I keep going back and forth about how to do this. Excluding the person from giving a gift to themselves is easy, but coming up with the most efficient way to exclude family members if possible could be solved many different ways. I’m thinking that what I’ll do is maintain a list of recipients, and, for each giver, call a routine that a) removes the giver from the list, and b) removes family members from the list. If after removing family members from the list, the list is empty, family members will be added back.
Raku
And when I started testing my approach, I discovered there was a problem: sometimes, I would pick all the possible recipients for other people, leaving the list with only the giver as a possible recipient:
Output:
Mr. Cross ->
Mr. Wall -> Mr. Conway
Mr. Anwar -> Mrs. Wall
Mrs. Anwar -> Mr. Wall
Mr. Conway -> Mrs. Anwar
Mrs. Wall -> Mr. Anwar
So maybe I need to ensure that everyone gets assigned to someone else FIRST, and then worry about family names. Or… I could just accept that this happens occasionally and rather than adjust my algorithm to prevent it from happening, just add a check to make sure that everyone was assigned a gift recipient, and if not, just re-do my entire list.
Yeah, I’m doing that.
sub findRecipient($giver, %recipients) {
# since %recipients is passed by reference, we can't
# modify it, so let's make a copy with the giver removed
my @recipients = %recipients.keys.grep({ !/$giver/ });
# split on whitespace and take the last element
# to get the "family name"
my $family_name = split(" ", $giver)[*-1];
# now, make a potential recipient hash
# excluding family members
my @non_family_members =
@recipients.grep({ !/$family_name/ });
if (@non_family_members > 0) {
return @non_family_members.pick;
}
else {
return @recipients.pick;
}
}
sub secretSanta(@names) {
# let's use a hash to hold the giver/recipient pairings
my %results;
# put our work in a labelled loop
ASSIGN_RECIPIENTS: loop {
# convert the array of names into a hash with names as keys
my %available_recipients = @names.map: * => 1;
# now go through each of the names and find a
# recipient for them
for @names -> $giver {
my $recipient =
findRecipient($giver, %available_recipients);
# occasionally, we assign recipients so in the last
# iteration of the for loop the only available
# recipient is $giver. When that happens, the easiest
# way to fix things is to just re-do the entire list
redo ASSIGN_RECIPIENTS if ! defined $recipient;
%results{$giver} = $recipient;
%available_recipients{$recipient}:delete;
}
last; # exit the labelled loop
}
return %results;
}
View the entire Raku script for this task on GitHub.
Perl
For the Perl implementation, I’m finally giving in and using Perl’s function signatures (as I noted last week, they’ve been the default since Perl 5.36, so why shouldn’t I use them?) and to take the place of Raku’s pick, I’m using List::Util’s sample function.
use List::Util qw( sample );
sub findRecipient($giver, $recipients) {
# since $recipients is a reference to a hash, we can't
# modify it, so let's make a copy with the giver removed
my @recipients = grep { !/$giver/ } keys %$recipients;
# split on whitespace and take the last element
# to get the "family name"
my $family_name = (split /\s+/, $giver)[-1];
# now, make a potential recipient hash
# excluding family members
my @non_family_members =
grep { !/$family_name/ } @recipients;
if (@non_family_members > 0) {
return sample(1, @non_family_members);
}
else {
return sample(1, @recipients);
}
}
sub secretSanta(@names) {
# let's use a hash to hold the giver/recipient pairings
my %results;
# put our work in a labelled loop
ASSIGN_RECIPIENTS: while () {
# convert the array of names into a hash with names as keys
my %available_recipients = map { $_ => 1 } @names;
# now go through each of the names and find a
# recipient for them
foreach my $giver ( @names ) {
my $recipient =
findRecipient($giver, \%available_recipients);
# occasionally, we assign recipients so in the last
# iteration of the for loop the only available
# recipient is $giver. When that happens, the easiest
# way to fix things is to just re-do the entire list
redo ASSIGN_RECIPIENTS if ! defined $recipient;
$results{$giver} = $recipient;
delete $available_recipients{$recipient};
}
last; # exit the labelled loop
}
return %results;
}
I wound up using while () as a standing for Raku’s loop (even though loop is analogous to Perl’s for, using for in Perl to do an unbounded loop would be for (;;), and I just like the while form better).
View the entire Perl script for this task on GitHub.
Python
Python doesn’t have named loops, so it was just easier to set a variable if we encountered our error condition and, if it’s set to True, recursively call the function again.
from random import sample
import re
def findRecipient(giver, recipients):
# exclude the giver from the recipient list
possible_recipients = [
name for name in recipients if name != giver
]
# if there are no possible recipients, bail early
if len(recipients) == 0:
return None
# split on whitespace and take the last element
# to get the "family name"
family_name = re.compile((giver.split())[-1])
# now, make a potential recipient list
# excluding family members
non_family_members = [
name for name in possible_recipients \
if not family_name.search(name)
]
# sample() returns a LIST, so just return the first elem
if len(non_family_members) > 0:
return sample(non_family_members, 1)[0]
else:
return sample(recipients, 1)[0]
def secretSanta(names):
# let's use a dictionary to hold the giver/recipient
# pairings
results = {}
# copy the names into a new list
available_recipients = names.copy()
# now go through each of the names and find a
# recipient for them
must_redo = False
for giver in names:
recipient = findRecipient(giver, available_recipients)
if recipient is None:
must_redo = True
results[giver] = recipient
available_recipients.remove(recipient)
if must_redo:
return secretSanta(names)
else:
return results
View the entire Python script for this task on GitHub.
Task 2: Most Frequent Letter Pair
You are given a string S of lower case letters 'a'..'z'.
Write a script that finds the pair of consecutive letters in S that appears most frequently. If there is more than one such pair, chose the one that is the lexicographically first.
Example 1
Input: $s = 'abcdbca'
Output: 'bc'
'bc' appears twice in `$s`
Example 2
Input: $s = 'cdeabeabfcdfabgcd'
Output: 'ab'
'ab' and 'cd' both appear three times in $s and 'ab' is lexicographically smaller than 'cd'.
Approach
This feels fairly straightforward: take the first two characters of the string, count them as a pair. Discard the first character from the string, then repeat the process with the new first two characters of the string, until there’s only one character in the string left. A hash is perfect for keeping track of the pairs we’ve counted.
The wrinkle is that we need to handle when more than one pair has the same count.
Having to sort on frequency and then some natural order reminds me of the second task in PWC 233.
Raku
use Lingua::Conjunction;
use Lingua::EN::Numbers;
sub pairCount($string) {
my $s = $string; # make a copy so we can modify it
my %count;
while ($s.chars > 1) {
my $pair = substr($s, 0..1); # the first two characters
%count{$pair}++; # count the pair
$s = substr($s, 1, *); # remove the first character
}
return %count;
}
sub mostFrequentPair($s) {
# count the letter pairs
my %pairs = pairCount($s);
# sort the pairs by their counts
my @sorted = %pairs.keys.sort: {
# sort by count first
%pairs{$^b} <=> %pairs{$^a}
||
# then by lexicographical order
$^a cmp $^b
};
my @max_pair = shift(@sorted); # pull off first value
my $max_count = %pairs{@max_pair[0]}; # get it's count
while ( %pairs{@sorted[0]} == $max_count ) {
# there are pairs on the sorted list that have the
# same count, so let's put them on the list, too
@max_pair.append( shift(@sorted) );
}
my $explain;
# set aside the pair that sorted to the top
my $first_pair = @max_pair[0];
# now quote all the pairs
@max_pair = @max_pair.map: { qq{'$_'} };
# make the count an english word
my $count = ($max_count == 1) ?? 'once' # 🎶
!! ($max_count == 2) ?? 'twice' # 🎶
!! cardinal($max_count) ~ ' times'; # a lady 🎶
# and format the explanation
if (@max_pair == 1) {
$explain = "'$first_pair' appears $count in \$s";
}
else {
my $str = qq{|list| appear $count in \$s and }
~ qq{'$first_pair' is lexicographically smallest.};
$explain = conjunction @max_pair, :$str;
}
return $first_pair, $explain;
}
View the entire Raku script for this task on GitHub.
Perl
use Lingua::EN::Inflexion qw( noun wordlist );
sub pairCount($s) {
my %count;
while (length($s) > 1) {
my $pair = substr($s, 0, 2); # the first two characters
$count{$pair}++; # count the pair
$s = substr($s, 1); # remove the first character
}
return %count;
}
sub mostFrequentPair($s) {
# count the letter pairs
my %pairs = pairCount($s);
# sort the pairs by their
my @sorted = sort {
# sort by count first
$pairs{$b} <=> $pairs{$a}
||
# then by lexicographical order
$a cmp $b
} keys %pairs;
my @max_pair = shift(@sorted); # pull off first value
my $max_count = $pairs{$max_pair[0]}; # get it's count
while ( $pairs{$sorted[0]} == $max_count ) {
# there are pairs on the sorted list that have the
# same count, so let's put them on the list, too
push @max_pair, shift(@sorted);
}
my $explain;
# set aside the pair that sorted to the top
my $first_pair = $max_pair[0];
# now quote all the pairs
my $pair_list = wordlist( map { qq{'$_'} } @max_pair );
# make the count an english word
my $count = ($max_count == 1) ? 'once' # 🎶
: ($max_count == 2) ? 'twice' # 🎶
: noun($max_count)->cardinal . ' times'; # a lady 🎶
# and format the explanation
if (@max_pair == 1) {
$explain = "'$first_pair' appears $count in \$s";
}
else {
$explain = $pair_list . " appear $count in \$s and "
. "'$first_pair' is lexicographically smallest.";
}
return $first_pair, $explain;
}
View the entire Perl script for this task on GitHub.
Python
The last time I needed to do English conjunctions in Python back in PWC 233, I didn’t bother looking for a module to load; I just rolled my own. I’ve borrowed that function here. I’ve also re-uses the Counter type in the collections module I discovered back in PWC 234, and Savoir-faire Linux’s num2words module I used in PWC 237.
I did a bit of searching on how to sort on multiple criteria, and I came across what the Python documentation called the Decorate-Sort-Undecorate idiom: create a list of tuples having the values you want to sort on, then sort the list of tuples, then re-create the list from the sorted tuples. But while I was reading it, I realized that I knew this technique, just under a different name: it’s a Schwartzian Transformation.
from collections import Counter
from num2words import num2words
def conjunction(words):
if len(words) < 2:
return(words)
elif len(words) == 2:
return(f'{words[0]} and {words[1]}')
else:
last = words.pop(-1)
l = ', '.join(words)
return(f'{l}, and {last}')
def pairCount(s):
# instantiate a counter object
count = Counter()
while (len(s) > 1):
pair = s[0:2] # the first two characters
count[pair] += 1 # count the pair
s = s[1:] # remove the first character
# convert it back to a dict now that we're done counting
return dict(count)
def mostFrequentPair(s):
# count the letter pairs
pairs = pairCount(s)
# sort the pairs by their counts
# use the Decorate-Sort-Undecorate idiom
# to convert the dict into a list
decorated = [ (pairs[p], p) for p in pairs.keys() ]
sorted_tuples = sorted(
decorated,
# the - before the first element sorts descending
key=lambda k: (-k[0], k[1])
)
sorted_pairs = [ t[1] for t in sorted_tuples ]
max_pair = []
# pull off first value from the sorted pairs
max_pair.append( sorted_pairs.pop(0) )
# get it's count
max_count = pairs[ max_pair[0] ]
while pairs[ sorted_pairs[0] ] == max_count:
# there are pairs on the sorted list that have the
# same count, so let's put them on the list, too
max_pair.append( sorted_pairs.pop(0) )
# set aside the pair that sorted to the top
first_pair = max_pair[0]
# make the count an english word
count = (
'once' if (max_count == 1) else # 🎶
'twice' if (max_count == 2) else # 🎶
num2words(max_count) + ' times' # a lady 🎶
)
# and format the explanation
if len(max_pair) == 1:
explain = f"'{first_pair}' appears {count} in \$s"
else:
# quote all the pairs
max_pair = [ f"'{x}'" for x in max_pair]
explain = f"{conjunction(max_pair)} appear {count} in "
explain += f"$s and '{first_pair}' is "
explain += "lexicographically smallest."
return first_pair, explain
View the entire Python script for this task on GitHub.
Here’s all my solutions in GItHub: https://github.com/packy/perlweeklychallenge-club/tree/master/challenge-247/packy-anderson
I wanted to see if anybody else had a better solution to restarting the Secret Santa solution if it ran out of possible assignments (basically where the only remaining recipient is also the only gifter who doesn’t have a recipient, meaning they’d be giving a gift to themselves).
On Facebook, the solutions I saw did either the same thing I did, or ignored the problem entirely by choosing a random number seed such that the problem didn’t occur. So I went looking for solutions in the commits to the master archive.
Choroba (https://github.com/choroba) had a decent one:
https://github.com/choroba/perlweeklychallenge-club/blob/f6b060850716e80d482c0c847eae7dde5fae54fd/challenge-247/e-choroba/perl/ch-1.pl
He’s sacrificing some randomness but he winds up with an algorithm that doesn’t produce the same results each time, so it’s probably random enough. What he does is first he divides the names into families, then he counts how many people are in those families, then he sorts the names so the people with no other family members in the gift exchange are first, and those with family members follow. The variation in order happens because there’s no sorting by last name: in the first example, Cross and Conway are always first but not always in the same order, and then the Anwars and the Walls are next (and always grouped together), but not in the same order.
Then it builds a list of recipients by chopping the first list in half and swapping the halves. This mixes up the recipients enough that nobody’s in the same position in both lists (thus preventing someone giving a gift to themselves) and if there’s a large enough list, the likelihood of gifts being given within the same family is low.