Perl Weekly Challenge: Week 247
Challenge 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
This challenge required a bit of thought and I'm not 100% sure I got it right but it seems to work for the examples at least.
Rather than provide a way to enter lists of names, I just hardcoded the ones from the examples into my solution. so let's ignore
the MAIN() function which basically just calls the heart of the solution, a function called secretSanta() which takes a list of names as its sole parameter.
sub secretSanta(@list) {
A hash is created to store the pairs of gift givers and receivers.
my %pairs;
The .pick() method randomly selects one or more elements from a list. Specifying * selects all the elements in effect
shuffling the lists. Because @list being a parameter is immutable, it cannot be shuffled in place so the shuffled version is assigned to a new list with the much more descriptive name @names.
my @names = @list.pick(*);
What happens next depends on how many people are taking part in Seret Santa. If it is an even number i.e. all couples, we can hope to achieve the specs' criterion of "team persons from different families." If it is an odd number, there will have to be an instance where one person gives a gift to a family member.
Let's look at the odd case first.
if @names.elems % 2 { # odd number of participants
The first name will be the key in the %pairs hash (representing the gift giver) and the next consecutive name will be the
value of that key (representing the gift receiver.) We continue through the names list like this until we've made as many pairs as possible.
for 0 .. @names.elems - 2 -> $i {
%pairs{@names[$i]} = @names[$i + 1];
}
Afterwards, there will be one name left over. He becomes a giver and the first name in the list becomes his gift receiver.
%pairs{@names[*-1]} = @names[0];
For the even case the procedure is a little different.
} else { # even number of participants
As long as there are names in the list we make pairs as before but...
while @names.elems {
...in order to keep family members from being secret Santas for each other we have to keep track of surnames (real life is a lot more complicated than this but it will suffice for the example input.) So we split each name in the pair into first and surnames. As the first name isn't needed we don't bother storing it only the surname.
my ($, $surname1) = @names[0].words;
my ($, $surname2) = @names[1].words;
If the two surnames are the same, this is not a pair we want so the names are shuffled again.
if $surname1 eq $surname2 {
@names = @names.pick(*);
} else {
If it is a valid pair, both members are added to %pairs as givers to each other. Actually the spec doesn't say it has
to be a symmetric exchange but that's how I've seen Secret Santa done in practice.
%pairs{@names[0]} = @names[1];
%pairs{@names[1]} = @names[0];
Finally, the two names are removed from the list so they don't get used again.
splice @names, 0, 2;
}
}
}
Finally the %pairs hash is returned. In MAIN() its' contents will be printed out.
return %pairs;
}
This is the Perl version of SecretSanta().
sub secretSanta {
my @names = @_;
my %pairs;
In order to randomize the list of names I used shuffle() from the List::Util module. So the code needs use List::Util qw/ shuffle /; at the top of the script.
@names = shuffle(@names);
if (scalar @names % 2) { # odd number of participants
for my $i (0 .. scalar @names - 2) {
$pairs{$names[$i]} = $names[$i + 1];
}
$pairs{$names[-1]} = $names[0];
} else { # even number of participants
while (scalar @names) {
my ($title1, $surname1) = split q{ }, $names[0];
my ($title2, $surname2) = split q{ }, $names[1];
if ($surname1 eq $surname2) {
@names = shuffle(@names);
} else {
$pairs{$names[0]} = $names[1];
$pairs{$names[1]} = $names[0];
splice @names, 0, 2;
}
}
}
return %pairs;
}
Challenge 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'.
This one was a lot easier.
First we split the input (taken from the command line) into characters and store them in an array.
my @chars = $s.comb;
Then we set up a hash to store pairs of consecutive characters as keys and the number of times the pair occurs as values.
my %pairs;
Then we just need to iterate through the array gathering pairs of consecutive characters and adding them to the hash.
for 1 .. @chars.end -> $i {
%pairs{(@chars[$i - 1], @chars[$i]).join}++;
}
Finally, we sort the keys of the hash by the size of their corresponding values. If there should be a tie, the keys are sorted in alphabetic order. The first element of the sorted keys is printed.
say %pairs.keys.sort({ %pairs{$^b} <=> %pairs{$^a} || $^a cmp $^b })[0];
The Perl version works the same way.
my @chars = split //, shift @ARGV;
my %pairs;
for my $i (1 .. scalar @chars - 1) {
$pairs{join q{}, ($chars[$i - 1], $chars[$i])}++;
}
say [sort { $pairs{$b} <=> $pairs{$a} || $a cmp $b } keys %pairs]->[0];