#!/usr/bin/perl

# Copyright (C) 2008 John J. Chew, III <jjchew@math.utoronto.ca>
# All Rights Reserved

package TSH::Command::TeamRoundRobin;

use strict;
use warnings;

use TSH::PairingCommand;
use TSH::Utility;
use TSH::Division::Team;
use TSH::Division::Pairing::Berger;

our (@ISA) = qw(TSH::PairingCommand);
our @Pairings;
our @Starts;

=pod

=head1 NAME

TSH::Command::TeamRoundRobin - implement the C<tsh> TeamRoundRobin command

=head1 SYNOPSIS

  my $command = new TSH::Command::TeamRoundRobin;
  my $argsp = $command->ArgumentTypes();
  my $helptext = $command->Help();
  my (@names) = $command->Names();
  $command->Run($tournament, @parsed_arguments);
  
=head1 ABSTRACT

TSH::Command::TeamRoundRobin is a subclass of TSH::PairingCommand.

=cut

=head1 DESCRIPTION

=over 4

=cut

sub initialise ($$$$);
sub new ($);
sub Run ($$@);

=item $parserp->initialise()

Used internally to (re)initialise the object.

=cut

sub initialise ($$$$) {
  my $this = shift;
  my $path = shift;
  my $namesp = shift;
  my $argtypesp = shift;

  $this->{'help'} = <<'EOF';
Use the TeamRoundRobin command to manually add a set of full team 
"round robin" pairings
to a division, where each player plays every player on every other
team.  
If the last paired round is only partially paired, the round robins 
will be constructed using the players left unpaired in that round;
otherwise the full division will be paired.
If you specify an integer before the
division name, each pairing will be repeated that number of times.
EOF
  $this->{'names'} = [qw(trr teamroundrobin)];
  $this->{'argtypes'} = [qw(OptionalInteger Division)];
# print "names=@$namesp argtypes=@$argtypesp\n";

  return $this;
  }

sub new ($) { return TSH::Utility::new(@_); }

=item $command->Run($tournament, @parsed_args)

Should run the command in the context of the given
tournament with the specified parsed arguments.

=cut

sub Run ($$@) { 
  my $this = shift;
  my $tournament = shift;
  my $dp = pop @_;
  my $count = @_ ? pop @_ : 1;
  $this->{'trr_tournament'} = $tournament;

  my $round0 = $dp->FirstUnpairedRound0();
  my $psp = $dp->GetUnpairedRound($round0);
  my $teamhashp = TSH::Division::Team::GroupByTeam($psp);
  my @teams = map { $teamhashp->{$_} } sort keys %$teamhashp;
  if (@teams < 2) {
    $tournament->TellUser('etrrsmall');
    return;
    }
  my $team_size = scalar(@{$teams[0]});
  my $min_team_size = $team_size;
  for my $a_team (@teams[1..$#teams]) {
    my $a_team_size = scalar(@$a_team);
    if ($a_team_size < $min_team_size) { $min_team_size = $a_team_size; }
    if ($a_team_size > $team_size) { $team_size = $a_team_size; }
    }
  if ($team_size - $min_team_size > 1) {
    $tournament->TellUser('etrruneven');
    return;
    }
  my $success = @teams % 2 
    ? $this->PairOddTeams(\@teams, $count, $round0, $team_size, $min_team_size)
    : $this->PairEvenTeams(\@teams, $count, $round0, $team_size, $min_team_size);

  if ($success) {
    $tournament->TellUser('idone');
    $dp->Dirty(1);
    $this->Processor()->Flush();
    }
  }

sub PairEvenTeams ($$$$$$) {
  my $this = shift;
  my $teamsp = shift;
  my $count = shift;
  my $round0 = shift;
  my $team_size = shift;
  my $min_team_size = shift;
  my $swap = int(rand(2));
  my $dp = $teamsp->[0][0]->Division();
  my $tournament = $dp->Tournament();
  my (@sorted_teams) = map { [ TSH::Player::SortByInitialStanding @$_ ] } @$teamsp;
# warn "Team 0: " . join(';', map { $_->Name() } @{$teamsp->[0]});
  $tournament->TellUser('itrrok', $dp->{'name'});
  my $nteams = scalar(@sorted_teams);
  my $config = $tournament->Config();
  my $config_order = $config->Value('round_robin_order');
  my $random = $config_order ? 0 : $config->Value('random') > 0.5;

  for my $phase (1..$nteams-1) {
    my (@table) = @{TSH::Division::Pairing::Berger::ComputeBergerRound({
      'assign_firsts' => 1,
      'first_opponent' => $nteams - $phase + 1,
      'player_count' => $nteams,
      'random' => $random,
      })};
    my $swap;
    while (@table) {
      my (@t) = map { $sorted_teams[$_-1] } (shift @table, pop @table);
      if (defined $swap) { 
	$swap = 1 - $swap; 
	if ($swap) { @t[0,1] = @t[1,0]; }
	}
      else { $swap = 1; }
      $this->PairTwoTeams({
	'dp' => $dp,
	'team1' => $t[0],
	'team2' => $t[1],
	'team_size' => $team_size,
	'round0' => $round0 + ($phase-1) * $team_size,
	'count' => $count,
	});
      }
    }
  return 1;
  }

sub PairOddTeams ($$$$$$) {
  my $this = shift;
  my $teamsp = shift;
  my $count = shift;
  my $round0 = shift;
  my $team_size = shift;
  my $min_team_size = shift;
  my $tournament = $teamsp->[0][0]->Division()->Tournament();
  $tournament->TellUser('etrrunodd');
  return 0;
  }

sub PairTwoTeams ($$) {
  my $this = shift;
  my $optionsp = shift;
  my $count = $optionsp->{'count'};
  my $dp = $optionsp->{'dp'};
  my $round0 = $optionsp->{'round0'};
  my $team1p = $optionsp->{'team1'};
  my $team2p = $optionsp->{'team2'};
  my $team_size = $optionsp->{'team_size'};
# warn join(' ', map { $_->{'id'} } @$team1p);
# warn join(' ', map { $_->{'id'} } @$team2p);
  my $config = $this->{'trr_tournament'}->Config();
  my $config_order = $config->Value('round_robin_order');
  if (my $order = ($config_order && (@$config_order == 2 * $team_size))) {
    warn "Reordering team players as per config round_robin_order: @$config_order.\n";
    warn "Before: " . join('; ', map { $_ && $_->Name() } @$team1p) . '. ' . join('; ', map { $_->Name() } @$team2p) . '.';
    $team1p = [grep { defined $_ } @$team1p[map { $_-1 } @$config_order[0..$team_size-1]]];
    $team2p = [grep { defined $_ } @$team2p[map { $_-1 } @$config_order[$team_size..2*$team_size-1]]];
    warn "After: " . join('; ', map { $_ && $_->Name() } @$team1p) . '. ' . join('; ', map { $_->Name() } @$team2p) . '.';
    }
  for my $i (0..$team_size-1) {
    for my $k (1..$count) {
      for my $j (0..$team_size-1) {
	my $p1 = $team1p->[$j];
	my $p2 = $team2p->[($team_size*2-1-$i+$j) % $team_size];
        my $pn1 = $p1 ? $p1->ID() : 0;
        my $pn2 = $p2 ? $p2->ID() : 0;
#	warn "$i;$k;$j;$pn1;$pn2";
	$dp->Pair($pn1, $pn2, $round0, 0);
        }
      $dp->GetUnpairedRound($round0++); # side-effect: assign byes to inactive players
      }
    }
  }

=back

=cut

=head1 BUGS

- T teams, P players per team
- (T-1)*P rounds
- in each P-round phase, two teams are chosen from a team RR schedule, and all their players face each other
- if T is odd, split teams in half, each team plays two others from consecutive RR schedules

- will pair past max_rounds!

None known.

=cut

1;
