Peter Campbell Smith

Santa’s letters

Weekly challenge 247 — 11 December 2023

Week 247 - 11 Dec 2023

Task 1

Task — 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',


    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',


    Mr. Anwar -> Mr. Wall
    Mr. Wall -> Mrs. Wall
    Mrs. Wall -> Mr. Anwar


I started this task by assigning the people's nams as the keys to a hash. So here's my first failing: it won't work if two people have identical names.

Then there are some conditions that are perhaps just hinted at. The first is that is probably undesirable, though it isn't stated, for a to give to b, and b to a. So let's try to avoid that if possible: I did it by sorting the list of donors and reverse sorting the recipients.

The next challenge is in the words 'randomly assigned'. My initial solution came up with what looked like random assignments, but repeating the exercise came up with the same again, which is decidedly un-random. So rather than sorting the keys of my %people hash, I gave each hash element a random 3-digit value and then sorted them by value using this:
sort {$people{$b} <=> $people{$a}} keys %people

The reverse sort is then just a case of exchanging $a and $b.

And finally we have the requirement that we try to ensure that members of the same family are not donor and recipient of any gift. I think we are entitled to assume (though not always true in real life) that members of a family have the same, unique last name, so we have first to check that there is no eligible non-family-member and if so then find a family member who hasn't already received a gift. And don't forget that a family name might be something like Jones-O'Hara.

Note that the same-family clause will only apply if there is a family that has more members than all the others combined, for example 5 out of 9 in total.

Merry Christmas everyone!

Try it 

Try running the script with any input:

example: Mr Blue, Mrs Blue, Sir Jo Blue, Miss Red, Prof Red



use v5.26;    # The Weekly Challenge - 2023-12-11
use utf8;     # Week 247 task 1 - Secret santa
use strict;   # Peter Campbell Smith
use warnings; # Blog:

secret_santa('Mr. Wall', 'Mrs. Wall', 'Mr. Anwar', 
    'Mrs. Anwar', 'Mr. Conway', 'Mr. Cross', 
    'Miss Anwar', 'Dr Anwar', 'Lord Anwar');

secret_santa('Rudolph Reindeer', 'Dasher Reindeer', 'Dancer Reindeer',
    'Prancer Reindeer', 'Vixen Reindeer','Comet Reindeer',
    'Cupid Reindeer', 'Donner Reindeer', 'Blitzen Reindeer',
    'Santa Claus', 'Mrs Claus', 'Subordinate Claus');
sub secret_santa {
    my (%people, %recipient, $d, $r, $result, $list, $j);
    # initialise
    $people{$_} = int(rand(899) + 101)  for (@_);
    $list = '   ';
    # find someone with a different surname
    D: for $d (sort {$people{$a} <=> $people{$b}} keys %people) {
        $list .= $d . ($j ++ % 3 == 2 ? qq[,\n   ] : ', ');
        for $r (sort {$people{$b} <=> $people{$a}} keys %people) {
            next if ($d eq $r or $people{$r} == 0);
            if (surname($d) ne surname($r)) {
                $result .= qq[   $d -> $r\n];
                $people{$r} = 0;
                next D;
        # no luck, so try for wih the same one
        for $r (sort {$people{$a} <=> $people{$b}} keys %people) {
            next if ($d eq $r or $people{$r} == 0);
            $result .= qq[   $d -> $r\n];
            $people{$r} = 0;
            next D;
    # show results
    $list =~ s|,[\n ]+$||;
    say qq[\nInput:\n$list];
    say qq[Output:\n] . substr($result, 0, -1);

sub surname {   
    $_[0] =~ m|([-a-zA-Z']*)$|;
    return $1;


   Lord Anwar, Miss Anwar, Mr. Anwar,
   Mr. Cross, Dr Anwar, Mr. Conway,
   Mr. Wall, Mrs. Wall, Mrs. Anwar
   Lord Anwar -> Mrs. Wall
   Miss Anwar -> Mr. Wall
   Mr. Anwar -> Mr. Conway
   Mr. Cross -> Mrs. Anwar
   Dr Anwar -> Mr. Cross
   Mr. Conway -> Dr Anwar
   Mr. Wall -> Mr. Anwar
   Mrs. Wall -> Miss Anwar
   Mrs. Anwar -> Lord Anwar

   Rudolph Reindeer, Comet Reindeer, Dasher Reindeer,
   Prancer Reindeer, Subordinate Claus, Dancer Reindeer,
   Cupid Reindeer, Vixen Reindeer, Santa Claus,
   Mrs Claus, Donner Reindeer, Blitzen Reindeer
   Rudolph Reindeer -> Mrs Claus
   Comet Reindeer -> Santa Claus
   Dasher Reindeer -> Subordinate Claus
   Prancer Reindeer -> Rudolph Reindeer
   Subordinate Claus -> Blitzen Reindeer
   Dancer Reindeer -> Comet Reindeer
   Cupid Reindeer -> Dasher Reindeer
   Vixen Reindeer -> Prancer Reindeer
   Santa Claus -> Donner Reindeer
   Mrs Claus -> Vixen Reindeer
   Donner Reindeer -> Dancer Reindeer
   Blitzen Reindeer -> Cupid Reindeer