Secret Santa Overkill

jjatria.gitlab.io/secret-santa-overkill

gitlab.com/jjatria/secret-santa

I love Christmas

I really, really, love Christmas

And presents are a big part

Why presents?

Presents are about the other

What could they want?

What would make them happy?

I also love secret santas

Why secret santas?

My family is big

There's too many "others"

Fewer, more targeted presents

But they're also a lot of fun!

On secret santas

There are many kinds of secret santas

What kind of secret santa are we talking about?

My kind of secret santa

Among loved ones

Each person gets assigned another person

They give them a present

They tell them who they are

My family's secret santa

Originaly done by hand

Names in a bowl

People notified by any means

It wasn't perfect

It wasn't secret
It was error prone
It had the potential for mischief

So in 2010 I took over

Now we get some code?

Kind of

Brief historic review of the code

But this is not a history of a module

This is the history of a programmer

Each version is me doing the best I can

Here we go!

The first version

Done in time for Christmas 2010

Sadly lost, like tears in rain

The first (known) version

All in a single file, a single while

srand();

my @people = qw{ ... };
my @A = (0..$#people);
my $total = 0;
foreach (0..$#A) {
  $total += $_;
}
my $remainder = $total;
my @C;
my $tries = 0;

while (1) {
  if ($tries > 0) {
    print "\ntrying again...\n";
  }
  my $samenumber = 0;
  my $repeatednumber = 0;
  foreach my $giver (0..$#A) {
    if (! $giver == $#A) {
      print "$giver ";
      my $rnd = int(rand(@people));
      print "gives to $rnd\t";
      if ($giver == $rnd) {
        @C = ();
        $samenumber = 1;
        print "they are the same\n";
      }
      foreach (0..$#C) {
        #print "\tchecking (".'$C['.$_."] = $C[$_]) ";
        if ((defined $C[0]) && ($rnd == $C[$_])) {
          @C = ();
          $repeatednumber = 1;
          print "$rnd already got a present\n";
        }
        last if ($repeatednumber == 1);
      }
      if (($samenumber == 1) || ($repeatednumber == 1)) {
        last;
      } else {
        print "OK\n";
        $A[$giver] = $rnd;
        push @C, $rnd;
        $remainder -= $rnd;
      }
    } else {
      print "$giver gives to $remainder\tOK\n";
      $A[$giver] = $remainder;
    }
  }
  if (($samenumber == 1) || ($repeatednumber == 1)) {
    $tries++;
    $remainder = $total;
    next;
  } else {
    print "\n(done in $tries tries)\n\n";
    last;
  }
}

foreach (0..$#A) {
  print $people[$_]."\t gives a (nice) present to \t".$people[$A[$_]]."\n";
}

The earliest version I have is also one of the oldest scripts I have written by me, which is a window to all sorts of embarrasing behaviours. This one in particular is all in a single file, all inside a single while loop, to be honest. I'm not going to try to explain what this does, actually. I tried to figure it out, and realised it was taking way too long.

The first (known) version

Had some really terrible variable names

my @A = ...;
my @C;

The first (known) version

Didn't work

Use of uninitialized value in concatenation (.) or string at ./iss.pl line 66.
mary     gives a (nice) present to
Use of uninitialized value in concatenation (.) or string at ./iss.pl line 66.
pedro    gives a (nice) present to
Use of uninitialized value in concatenation (.) or string at ./iss.pl line 66.
jose     gives a (nice) present to
...

Undated later version (2011?)

Adds options with Getopt::Long
Results printed to files to be sent by mail
Uses functions to separate chunks
- Most of them reinvent the wheel
- Some of them are never used

Version 0.2.1 (2012?)

Adds usage with Pod::Usage
Results automatically sent by email
Inexplicable use CGI at start

Version 0.3 (2013?)

Adds documentation
But it's copied from a different script
Adds considerable user feedback
Uses references for complex data structures
use CGI still right there

git joins the fray

Sat Oct 26 14:23:33 2013 +0900

Changes for Christmas 2014

Added configuration files
Switch input from CSV to JSON
Added mail templates
Re-wrote using OO
- Just a single Person class
Frameworks? Who needs frameworks?

No changes for Christmas 2015

Then came august 2016...

The take-home message

I had been using Perl for ~15 years

But I had always done it alone

15 years later, I was writing 15-year-old Perl

Modernising my code

Started reviewing old projects

Realised they were all rubbish

Secret santa was not the exception

The santa holy grail

All secret santas need exceptions

But I had special requirements:

Conditional exceptions

"A cannot give to B iff ..."

A use case

Meanwhile, back on topic...

Changes for Christmas 2016

Complete re-write!

Classes use Moose
- Person and Sorter classes
Customisation using events

Conditional exceptions

my $santa = SecretSanta->load( $json );

# Register conditions
$santa->on( assign => sub {
  my ($sorter, $source) = @_;
  ...
  $sorter->retry if ...
});

# Sort!
$santa->sort;

profit();

Loading data

[
  {
    "name": "tim",
    "exceptions": [ "tom" ],
    "groups": [ "perl" ],
    "address": "tim@cpan.org"
  },
  ...
]

Avoiding group intersections

$santa->on( assign => sub {
  my ($sorter, $source) = @_;
  foreach my $group ($source->groups) {
    foreach my $friend ($group->members) {

      next if $friend->name eq $source->name;
      if ($friend->target) {
        return $sorter->retry if intersect (
          $source->target->groups,
          $friend->target->groups,
        );
      }
    }
 }
});

Original changes for Christmas 2017

Switch to Moo
Rename to Acme::SecretSanta
Email templates use Mason
Sorting and "dispatching" are roles

Original changes for Christmas 2017

lib
└── Acme
    ├── SecretSanta
    │   ├── Mailer
    │   │   └── Mason.pm
    │   ├── Person.pm
    │   ├── Role
    │   │   ├── Dispatcher.pm
    │   │   └── Sorter.pm
    │   └── Sorter.pm
    └── SecretSanta.pm

Secret Santa Overkill

José Joaquín Atria