diff --git a/lib/Synergy/Rototron2.pm b/lib/Synergy/Rototron2.pm new file mode 100644 index 00000000..e2dc1895 --- /dev/null +++ b/lib/Synergy/Rototron2.pm @@ -0,0 +1,290 @@ +use v5.28.0; +use warnings; +package Synergy::Rototron2; + +use Moose; +use experimental qw(lexical_subs signatures); + +use JSON::MaybeXS; +use Path::Tiny; + +use DateTime (); + +# This tiny bit of code and comment brought in from Rototron1. It's still +# useful to know the week-since-epoch of a date, for a rotating random +# tie-breaker. The big goal in Rototron2 is just to get to ties a lot less +# often. +# +# Let's talk about the epoch here. It's the first Monday before this program +# existed. To compute who handles what in a given week, we compute the week +# number, with this week as week zero. Everything else is a rotation through +# that. +# +# We may very well change this later. -- rjbs, 2019-01-30 +my $EPOCH = 1548633600; +my sub week_of_date ($dt) { int( ($dt->epoch - $EPOCH) / (86400 * 7) ) } + +package Synergy::Rototron2::Rotor { + use Moose; + use experimental qw(lexical_subs signatures); + + use List::Util qw(any max min); + + use Synergy::Logger '$Logger'; + + has ident => (is => 'ro', isa => 'Str', required => 1); + has name => (is => 'ro', isa => 'Str', required => 1); + + # a map from { date => username } + has schedule => ( + reader => '_schedule', + default => sub { {} }, + traits => [ 'Hash' ], + ); + + sub person_scheduled_on ($self, $dt) { + return $self->_schedule->{$dt->ymd}; + } + + sub fatigue_for ($self, $person) { + my $schedule = $self->_schedule; + + # This variable is here for testing. -- rjbs, 2022-09-17 + my $min = $Synergy::Rototron2::FATIGUE_BACKSTOP + // DateTime->now(time_zone => 'UTC')->subtract(days => 90)->ymd; + my @keys = grep {; $_ gt $min } keys %$schedule; + + return scalar grep {; $schedule->{$_} eq $person } @keys; + } + + sub include_weekends { 0 } + + # a user has "availability_on($date)" method + # { + # username => $preference, + # ... + # } + # + # a person's fatigue is the count of keys in the schedule where the key is a + # date in the last 90d and the value is the username + has people_preferences => ( + required => 1, + traits => [ 'Hash' ], + handles => { people_preferences => 'elements' }, + ); + + sub _schedule_dates ($self, $input_dates, $arg) { + local $Logger = $Logger->proxy({ + proxy_prefix => "rotor " . $self->ident . ": ", + }); + + $Logger->log([ + "scheduling from %s to %s", + $input_dates->[0]->ymd, + $input_dates->[-1]->ymd, + ]); + + my @dates = @$input_dates; + unless ($self->include_weekends) { + @dates = grep {; $_->day_of_week < 6 } @dates; + } + + my $other_rotors = $arg->{other_rotors}; + my $availability_checker = $arg->{availability_checker}; + + my %person_preferences = $self->people_preferences; + + my %has_other_duty; + for my $date (@dates) { + for my $rotor ($arg->{other_rotors}->@*) { + if (my $username = $rotor->person_scheduled_on($date)) { + $has_other_duty{$username} = 1; + } + } + } + + my %preference_group; + for my $username (keys %person_preferences) { + my $level = $person_preferences{$username}; + + if ($has_other_duty{$username}) { + # if any user in the group has duty on any other rotor, locally + # increase their preference number + $level++; + + $Logger->log([ + "bumping %s to preference %s, already on a rotation this period", + $username, + $level, + ]); + } + + $preference_group{$level} //= []; + push $preference_group{$level}->@*, $username; + } + + LEVEL: for my $level (sort {; $a <=> $b } keys %preference_group) { + my @people = $preference_group{$level}->@*; + + $Logger->log([ + "%s, level %s, people: %s", + $self->ident, + $level, + \@people + ]); + + my %days_available; + my %daycount_available; + for my $person (@people) { + my @days = grep {; $availability_checker->($person, $_) } @dates; + + $days_available{$person} = \@days; + $daycount_available{$person} = @days; + } + + $Logger->log([ 'availability: %s', \%daycount_available ]); + + my ($most_days) = max values %daycount_available; + + unless ($most_days) { + $Logger->log([ + 'nobody at level %s available, will try next level', + $level, + ]); + + next LEVEL; + } + + my @candidates = sort grep {; $daycount_available{$_} == $most_days } + keys %daycount_available; + + $Logger->log([ 'most available candidates: %s', \@candidates ]); + + # if set size > 1 + # pick users with minimum fatigue + + my %fatigue_for; + for my $person (@candidates) { + $fatigue_for{$person} = $self->fatigue_for($person); + } + + $Logger->log([ 'fatigue levels: %s', \%fatigue_for ]); + + my ($least_fatigue) = min values %fatigue_for; + + @candidates = sort grep {; $fatigue_for{$_} == $least_fatigue } + keys %daycount_available; + + $Logger->log([ 'least fatigued candidates: %s', \@candidates ]); + + # Here, we assume that all dates in range have the same week. + # -- rjbs, 2022-09-17 + my $winner = $candidates[ week_of_date($dates[0]) % @candidates ]; + + if ($winner) { + my @can_work = $days_available{ $winner}->@*; + $Logger->log([ + 'and the winner is: %s who will work %s', + $winner, + [ map {; $_->ymd } @can_work ], + ]); + + $self->_commit_user($winner, \@can_work); + + if (@dates != @can_work) { + my %scheduled = map {; $_ => 1 } @can_work; + my @unscheduled = grep {; ! $scheduled{$_} } @dates; + + $Logger->log([ + "couldn't schedule all days, so will try again on: %s", + [ map {; $_->ymd } @unscheduled ], + ]); + + return $self->_schedule_dates([ grep {; ! $scheduled{$_} } @dates ], $arg); + } + + # We did it! All dates scheduled. + return; + } + + $Logger->log([ "no success at level %s", $level ]); + } + + $Logger->log("failed to schedule!"); + + return; + } + + sub _commit_user ($self, $person, $dates) { + my $schedule = $self->_schedule; + + for my $ymd (map {; $_->ymd } @$dates) { + if (my $already = $schedule->{ $ymd }) { + my $ident = $self->ident; + confess "rotor $ident already scheduled on $ymd for $already"; + } + + $self->_schedule->{ $ymd } = $person; + } + + return; + } + + sub _uncommit_dates ($self, $dates) { + my $schedule = $self->_schedule; + + for my $ymd (map {; $_->ymd } @$dates) { + delete $schedule->{ $ymd }; + } + + return; + } + + __PACKAGE__->meta->make_immutable; + no Moose; +} + +has rotors => ( + isa => 'ArrayRef', + required => 1, + traits => [ 'Array' ], + handles => { rotors => 'elements' }, +); + +# TODO Replace this with something like (or exactly) the Rototron1 availability +# checker! -- rjbs, 2022-09-17 +has availability_checker => ( + is => 'ro', + required => 1, +); + +sub schedule_range ($self, $start_date, $and_next) { + my %rotors = map {; $_->ident, $_ } $self->rotors; + + my @dates = ( + $start_date, + map {; $start_date->clone->add(days => $_) } (1 .. $and_next), + ); + + # This "sort" is bogus, nothing should actually matter based on naming of + # things, but for now, trying to keep it semi-simple and definitely + # deterministic. -- rjbs, 2022-09-17 + for my $ident (sort keys %rotors) { + # This "delete local" is less bogus, but deserves a raised eyebrow. Each + # rotor wants to be able to say "Aiden is already doing the dishes, let + # them skip taking out the trash this week" when possible, so knowing the + # other rotors is useful. Probably this should be dumped into some kind of + # availability helper, but I dunno yet. -- rjbs, 2022-09-17 + my $rotor = delete local $rotors{$ident}; + $rotor->_schedule_dates(\@dates, { + other_rotors => [ values %rotors ], + availability_checker => $self->availability_checker, + }); + } + + return; +} + +__PACKAGE__->meta->make_immutable; +no Moose; +1; diff --git a/rototron.json b/rototron.json new file mode 100644 index 00000000..a4089adf --- /dev/null +++ b/rototron.json @@ -0,0 +1,50 @@ +{ + "rotors": { + "triage_au": { + "staff": { "region": "au", "team": "triage" }, + "description": "AU Escalation", + "calendar_id": "bf2ba255-08d1-4c64-a46a-cb39da6706ae", + "time_zone" : "Australia/Sydney", + "exclude_dow": [ 6, 7 ] + }, + "triage_us": { + "staff": { "region": "us", "team": "triage" }, + "description": "US Escalation", + "calendar_id": "bf2ba255-08d1-4c64-a46a-cb39da6706ae", + "time_zone" : "America/New_York", + "exclude_dow": [ 6, 7 ] + }, + "kitchen": { + "staff": { "team": "kitchen" }, + "description": "Kitchen Patrol", + "calendar_id": "bf2ba255-08d1-4c64-a46a-cb39da6706ae", + "exclude_dow": [ 6, 7 ] + }, + "bathroom": { + "staff": { "team": "bathroom" }, + "description": "Bathroom Brigade", + "calendar_id": "bf2ba255-08d1-4c64-a46a-cb39da6706ae", + "exclude_dow": [ 6, 7 ] + } + }, + "staff": [ + { "username": "alice", "name": "Alice Z.", "region": "au", "teams": [ "bathroom", "triage" ] }, + { "username": "bob", "name": "Bob Y.", "region": "us", "teams": [ "bathroom", "triage" ] }, + { "username": "chuck", "name": "Chuck X.", "region": "au", "teams": [ "bathroom", "kitchen", "triage" ] }, + { "username": "diane", "name": "Diane W.", "region": "us", "teams": [ "bathroom", "kitchen" ] }, + { "username": "edna", "name": "Edna V.", "region": "au", "teams": [ ] }, + { "username": "frank", "name": "Frank U.", "region": "us", "teams": [ ] }, + { "username": "gilda", "name": "Gilda T.", "region": "au", "teams": [ "kitchen", "triage" ] }, + { "username": "henry", "name": "Henry S.", "region": "us", "teams": [ "kitchen", "triage" ] }, + { "username": "igor", "name": "Igor R.", "region": "au", "teams": [ "bathroom", "triage" ] }, + { "username": "jenny", "name": "Jenny Q.", "region": "us", "teams": [ "bathroom" ] }, + { "username": "kate", "name": "Kate P.", "region": "au", "teams": [ "bathroom", "kitchen" ] }, + { "username": "lars", "name": "Lars O.", "region": "us", "teams": [ "bathroom", "kitchen" ] }, + { "username": "minh", "name": "Minh N.", "region": "au", "teams": [ "triage" ] }, + { "username": "ned", "name": "Ned M.", "region": "us", "teams": [ "triage" ] }, + { "username": "otto", "name": "Otto L.", "region": "au", "teams": [ "kitchen", "triage" ] }, + { "username": "peg", "name": "Peg K.", "region": "us", "teams": [ "kitchen" ] }, + { "username": "quinn", "name": "Quinn J.", "region": "au", "teams": [ "bathroom" ] } + { "username": "rusty", "name": "Rusty I.", "region": "us", "teams": [ "bathroom" ] } + ] +} diff --git a/t/rototron2.t b/t/rototron2.t new file mode 100644 index 00000000..10b204ff --- /dev/null +++ b/t/rototron2.t @@ -0,0 +1,87 @@ +#!perl +use v5.28.0; +use warnings; +use experimental 'signatures'; + +use lib 'lib', 't/lib'; + +use Synergy::Rototron2; +use Test::More; + +use Synergy::Logger::Test '$Logger'; + +my $ezra_rotor = Synergy::Rototron2::Rotor->new({ + name => 'be ezra', + ident => 'ezra', + people_preferences => { + ezra => 1, + whitney => 99, + } +}); + +my $lunch_rotor = Synergy::Rototron2::Rotor->new({ + name => 'order lunch', + ident => 'lunch', + people_preferences => { + hayden => 1, # almost always this person! + bailey => 2, + dana => 2, + finley => 2, + kim => 2, + } +}); + +my $sweep_rotor = Synergy::Rototron2::Rotor->new({ + name => 'sweep the floor', + ident => 'sweep', + people_preferences => { + aiden => 1, + bailey => 1, + chaz => 1, + dana => 1, + ezra => 2, # fallback sweepist + } +}); + +my $trash_rotor = Synergy::Rototron2::Rotor->new({ + name => 'take out the trash', + ident => 'trash', + people_preferences => { + aiden => 2, # fallback trash taker-outer + chaz => 1, + ezra => 1, + finley => 1, + grey => 1, + } +}); + +my $rototron = Synergy::Rototron2->new({ + rotors => [ $ezra_rotor, $sweep_rotor, $trash_rotor, $lunch_rotor ], + availability_checker => sub ($person, $dt) { + # Happy Birthday, Ezra! + return if $person eq 'ezra' && $dt->ymd eq '2022-01-11'; + + return 1; + }, +}); + +my sub ymd ($year, $month, $day) { + return DateTime->new( + time_zone => 'UTC', + year => $year, + month => $month, + day => $day, + ); +} + +my $first_monday = ymd(2022, 1, 3); + +$Synergy::Rototron2::FATIGUE_BACKSTOP = '2022-01-01'; + +# Basic setup, everybody is bright eyed and bushy tailed. +$rototron->schedule_range($first_monday, 6); + +# Now we should see fatigue. +$rototron->schedule_range($first_monday->clone->add(days => 7), 6); + +done_testing;