#!/usr/bin/perl

$x = <<EOM;

This is the same as swissJuhnke but allows players to drop out and join in
after the tournament is started. The difference between this and
swissJuhnkeD is that players from the current round are used when
computing SoS instead of players from the first round.


This modifies the typical Swiss System to compute the first tie break
differently. See the posting by Karl Juhnke:
  http://arimaa.com/arimaa/forum/cgi/YaBB.cgi?board=events;action=display;num=1255748924

The basic principles of a Swiss System tournament are:

   1. The number of rounds to be played is declared beforehand.
   2. Two players may play each other only once.
   3. Players are paired with others of the same score, or nearest score.
   4. When possible, a player is given the white pieces as many times
       as he is given the black pieces.
   5. When possible, a player is given the colour other than that he
       was given the previous round.
   6. The final ranking order is determined by the aggregate of points
       won: 1 point for a win, 0.5 point for a draw and 0 point for a
       loss. A player whose opponent fails to appear for a scheduled
       game receives one point.

A plain and simple swiss tournament.

Order the players by score from highest to lowest,
  then by sum of opponent score from highest to lowest
  then by pre-tournament rating from highest to lowest
  then by unique random number assigned at start of round

Player scores 2 for each win, 1 for draw, 0 for loss, 2 for bye.

If there is a an odd number of players the player at the
very bottom of the list gets a bye.

If a pair of players have already played before then they
cannot be paired again.

Pair the players from the top of the list to the bottom
as follows:

If the player is in the top half of the score group and
has not already been paired then
try to pair the player against the player in the bottom half
of the score group starting at the same relative position
in the bottom half as the player is in the top half. If a
pair cannot be made then continue down the list within
the same score group. After reaching the bottom of the
score group then work upwords within the same score group.
If a match cannot be found within the same score group
then work down the list starting from the top of the
next score group.

If the player is in the bottom half of the score group
and has not already been paired then pair the player
against the next player below them in the list and continue
down the list until a pair is found.

Within each pairing the player who has played a color
fewer times plays that color. If both players have played
a color the same number of times then the even numbered
players play white and odd numbered player play black.
If still the same color then the color is assigned randomly.

The number of rounds should be:
  int(log(N)/log(2))+2  where N is the number of players.
or about
  int(1.3*log(N)/log(2))  where N is the number of players.


After the rounds are over order the players as defined
earlier and select the player at the top of the list as
the winner.

Refrences for number of rounds:
http://www.oxfordcroquet.com/tech/appleton/index.asp
http://www.scoutingresources.org.uk/ideabase_swiss.html


EOM

# set this to 1 if players can drop out and if players can join late
#   otherwise set it to 0
$allowDropJoin = 1;

use Tourn;

$e = $ARGV[0];
$action = $ARGV[1];

sub myPrint{
#  print @_;
}

if (! Tourn->exists($e)){
  print "The file [$e] was not found.\n";
  exit;
}

$ev = Tourn->load($e);
if (! $ev){
  print "File [$e] could not be read.\n";
  exit;
}

%e = $ev->getEvent();
#@players = $ev->getPlayers();
#@games = $ev->getGames();
$round = $ev->getRound();
$status = $ev->getRoundStatus($round);

if ($action eq 'players'){
  doPlayers();
  exit;
}
if ($action eq 'games'){
  doGames();
  exit;
}
print "no action given; enter 'players' or 'games' to specify action.\n";
exit;


# this creates the following global hashes with the usernames as keys: 
#   %score - 2*games won + 1*games drawn
#   %sos - sum of opponents score
#   %played - count of games played between a pair of players; 
#             key is both usernames, like: "$first $second"
#   %byes - count of how many byes the player has received; forfiets are considered byes
sub calcScore{
  my(@g, $g, $p1, $p2, $won, $why, $k, $v);
  my($p, $o, $t);

# go through the games and calculate the score for the players
  @g = $ev->getGamesBeforeRound($round);
  foreach $g (@g){
    ($p1, $p2, $won, $why) = ($g->{1}, $g->{2}, $g->{won}, $g->{why});

# count the pairings
    $played{"$p1 $p2"} += 1;
    if ($p1 eq '-BYE-'){ $byes{$p2} += 1; }
    if ($p2 eq '-BYE-'){ $byes{$p1} += 1; }
# win by forfiet also considered a bye
    if ($why eq 'f'){
      if ($won == 1){ $byes{$p2} += 1; }
      if ($won == 2){ $byes{$p1} += 1; }
    }

# Use this if the tournament does not allow dropping out and late joins
    if (! $allowDropJoin){
      if ($won == 1){ $score{$p1} += 2; }
      if ($won == 2){ $score{$p2} += 2; }
      if ($won eq 'd'){ $score{$p1} += 1; $score{$p2} += 1; }
    }

# Use this if the tournament will allow dropping out and late joins
#   basically it adds 1 point to the score for rounds in which the players
#   did not play; as if they had a draw
    if ($allowDropJoin){
      if ($won == 1){ $score{$p1} += 1; $score{$p2} -= 1; }
      if ($won == 2){ $score{$p2} += 1; $score{$p1} -= 1; }
    }
  }
  if ($allowDropJoin){
    while(($k,$v) = each(%score)){
      $score{$k} = $v + ($round - 1);
    }
  }

# set the score of the -BYE- player to zero, so that it does not get added to sos
  $score{'-BYE-'} = 0;

# before computing the SoS we need to compute the factor used used in the exponent.
# see Karl's posting dated Jan 20, 2010 in the forum for more info:
#    http://arimaa.com/arimaa/forum/cgi/YaBB.cgi?board=events;action=display;num=1262545277;start=30#30  on page 3 and page 4
# note that the 'r' field of the player record must be a rating; otherwise this won't work
  my(@players, $p, $ef, $avg, $std);
#  @players = $ev->getPlayers();
  @players = $ev->getPlayersByRound($round);
  $avg = 0;
  foreach $p (@players){
    $avg += $p->{r};
  }
  $avg = $avg/($#players + 1);
  foreach $p (@players){
    $std += ($p->{r} - $avg)**2;
  }
  $std = sqrt($std/($#players + 1));
  $ef = 0.5 + $std/100;
# probably should check here to make sure $ef got set to a valid number
# save the $std and $ef into the current round so we can see what it is.
  $ev->{rounds}->[$round-1]->{pram_stdev} = $std;
  $ev->{rounds}->[$round-1]->{pram_ef} = $ef;
  $ev->{rounds}->[$round-1]->{pram_avg} = $avg;
  $ev->{rounds}->[$round-1]->{pram_np} = $#players + 1;

# go through each game and calculate sum-of-opponent-score (sos)
#   as proposed by Karl Juhnke; see this thread for details; particularly Nov 13th, 2009 postings
# http://arimaa.com/arimaa/forum/cgi/YaBB.cgi?board=events;action=display;num=1255748924
  foreach $g (@g){
    ($p1, $p2, $won) = ($g->{1}, $g->{2}, $g->{won});
# calc tie breaker for p1
    $p = $score{$p1}/2;
    $o = $score{$p2}/2;
# $round already is one more than number of rounds played, so don't add 1 to it as
#   given by Karl's formula
    $t = 1.0/(1.0+10**($ef*($p-$o)/($round))); 
    $sos{$p1} += $t;
# calc tie breaker for p2
    $p = $score{$p2}/2;
    $o = $score{$p1}/2;
    $t = 1.0/(1.0+10**($ef*($p-$o)/($round)));
    $sos{$p2} += $t;
  }
}



sub doPlayers{

  calcScore();

# get the players from previous round and change their round to this round
#   set the score for each player, sum of opponent score and random number
  @players = $ev->getPlayersByRound($round-1);
  foreach $p (@players){
    my(%p);
    %p = %$p;
    ($rn, $u) = ($p{round}, $p{u});
    $p{round} = $round;
    $p{score} = $score{$u};
    $p{sos} = $sos{$u};
# we use different random numbers in each round; they are set by doGames if not already set
#   if we want to keep the same numbers for the whole tournament then don't clear them here.
#   Clearing them causes doGames to assigne new ones.
    $p{rand} = ''; 
# used to display how the players were sorted
    $p{sos} = sprintf("%.4f", $p{sos});
    $p{orderby} = "$p{score}, $p{sos}, $p{r}, $p{rand}"; 
# the rating should already be assigned
    push(@p, \%p);
  }

# sort the players by; score, sum of opponent score, rating, random, and then username
  @p = sort { $b->{score} <=> $a->{score} ||
              $b->{sos} <=> $a->{sos} ||
              $b->{r} <=> $a->{r} ||
              $b->{rand} <=> $a->{rand} || 
              $b->{u} cmp $a->{u} 
            } @p;

  $ev->deletePlayersByRound($round);
  $ev->addPlayers(\@p);
  $ev->setRoundStatus($round, 'players');
  $ev->save();
  exit;
}


sub doGames{

  calcScore();

# get the players from this round and 
#   set the score for each player, sum of opponent score and random number
  @p = $ev->getPlayersByRound($round);
  foreach $p (@p){
    ($rn, $u) = ($p->{round}, $p->{u});
# find least number of byes a player has; used later to decide who is eligible to get a bye
    if (($byes eq '') || ($byes > $byes{$u})){ $byes = int($byes{$u}); }
    $p->{score} = int($score{$u}); # use int() so that '' will become 0.
    $p->{sos} = $sos{$u};
#print "u is $u, rand of u is $rand{$u}\n";
    if ($p->{rand} eq ''){
      $p->{rand} = int(rand(99999999));;
    }
    $p->{byes} = $byes{$u};
    $p->{paired} = '';
# used to display how the players were sorted
    $p->{sos} = sprintf("%.4f", $p->{sos});
    $p->{orderby} = "$p->{score}, $p->{sos}, $p->{r}, $p->{rand}"; 
# the rating should already be assigned
  }

# sort the players by; score, sum of opponent score, rating, random, and then username
  @p = sort { $b->{score} <=> $a->{score} ||
              $b->{sos} <=> $a->{sos} ||
              $b->{r} <=> $a->{r} ||
              $b->{rand} <=> $a->{rand} || 
              $b->{u} cmp $a->{u} 
            } @p;

  $ev->deletePlayersByRound($round);
  $ev->addPlayers(\@p);
  $ev->save(); # so that even if we can't pair the players we can see what random
               #   numbers were assigned to the players

##############################
# Now pair the players

# clear the games array
  @g = ();

  $t = pairPlayers(-1, \@p, \@g);
  if (! $t){ exit; }
  if ($#g < 0){ exit; }

# we found a pairing; now set the id for each game and also the round number
  @g = reverse(@g); # so that the order of the games will be more familiar
  $id = 1;
  foreach $g (@g){
    $g->{id} = $id;
    $g->{round} = $round;
    $id += 1;
  }

  $ev->deleteGamesByRound($round);
  $ev->addGames(\@g);
  $ev->setRoundStatus($round, 'paired');
  $ev->save();
  exit;

}

sub pairPlayers{
  my($i, $pr, $gr) = @_;
  my($p1i, $p2i, $p1u, $p2u, $j, $k);
  my($t, $x, $ti, $bi, $lpi, $myGroup, $byePass, $group);
  my(%g, @z);

myPrint "i is $i\n";

# if $i is -1 then we check if a bye is needed and find the player to give the bye to
# if $i >= 0 then try to find a pair for the $i player

# If there is an odd number of players the lowest ranked player who is eligible to
#   receive a bye gets a bye. To be eligible the number of byes the player has received
#   should not be more than the least number of byes given to any player.
  $lpi = $#{@$pr}; # last player index
  if ($i == -1){
    if (($lpi+1)%2){
      for($byePass=0;$byePass<2;$byePass++){
        $j = $lpi;
        for(; $j>=0; $j--){
myPrint "  j is $j, byes is $byes, $pr->[$j]->{u} byes is $pr->[$j]->{byes} - $byes{p2} \n";
          if ($pr->[$j]->{byes} <= $byes){ # $byes is a global set to the fewest byes
            $pr->[$j]->{paired} = 1;
            $t = pairPlayers($i+1, $pr, $gr);
            if ($t){
              $g{1} = $pr->[$j]->{u};
              $g{2} = '-BYE-';
              push(@$gr, \%g);
              return 1;
            }
            else{
              $pr->[$j]->{paired} = 0;
            }
          }
        }
        $byes += 1; # try once more with higher number of byes before giving up
      }
      return 0;
    }
    else{
      return pairPlayers($i+1, $pr, $gr);
    }
  }
  else{
# Mark the top and bottom index of different groups based on score
#   use global hashes so that we don't have to recompute them
    if (! defined %topi){
      for($x=0; $x<=$lpi;$x++){
        $group = int($pr->[$x]->{score});
        if ($topi{$group} eq ''){
          $topi{$group} = $x;
        }
        $boti{$group} = $x;
      }
    }

# find the first player
    for(;$i<=$lpi; $i++){
      if ($pr->[$i]->{paired} != 1){
        $p1i = $i;
        $pr->[$i]->{paired} = 1;
        last;
      }
    }
    if ($p1i eq ''){ return 1; } # there are no players left to be paired
    $p1u = $pr->[$p1i]->{u};

myPrint "p1 is $p1u\n";

# try to find the second player
# first try to look in our own group; start at the opponent that is in the
#   bottom half of our group (start at top of the bottom half) and look down from there;
#   then look going up from that position; then look going down
#   starting at the top of the next group.
#   
    $myGroup = $pr->[$p1i]->{score};
    $ti = $topi{$myGroup};
    $bi = $boti{$myGroup};

# Build the z array which has the order of the players we will try to pair with
#    $k = int(($bi - $ti + 1)/2) + $p1i;
    $k = int(($bi - $ti + 1)/2) + $ti; # don't add player 1 index, so we start at the top
myPrint "  k is $k\n";
    $j = $k;
    for(;$j<=$bi;$j++){
      push(@z, $j);
    }
    $j = $k-1;
    if ($j>$bi){ $j = $bi; }
    for(;$j>$p1i;$j--){
      push(@z, $j);
    }
    $j = $bi + 1;
    for(;$j<=$lpi;$j++){
      push(@z, $j);
    }

# Go throught the z array and recursively find a match for the first player
    foreach $j (@z){
myPrint "    checking $j\n";
      if ($pr->[$j]->{paired} == 1){ next; }
      $p2u = $pr->[$j]->{u};
      if ($played{"$p1u $p2u"} + $played{"$p2u $p1u"}){ next; }
      $pr->[$j]->{paired} = 1;
myPrint "      trying $p1u $p2u\n";
      $t = pairPlayers($p1i+1, $pr, $gr);
      if ($t){
        $g{1} = $p1u;
        $g{2} = $p2u;
        push(@$gr, \%g);
        return 1;
      }
      else{
        $pr->[$j]->{paired} = 0;
      }
    }
myPrint "        can't find pair for $p1u\n";
    $pr->[$p1i]->{paired} = 0;
    return 0; # we found a first player, but could not find a second player
  }
}