Bug #62502 for Games-Tournament-Swiss: c6others issue

As for persisting data, I'm using YAML::Dump for dumping the result of the previous round which is inserted into PostgreSQL table.

 

Here is the code which repeats this issue.

 

----------------------------------------------------------------------------------------------

#!/usr/bin/perl -w

use Games::Tournament::Swiss::Config;
my $SWISS = Games::Tournament::Swiss::Config->new;
my $SWISS_ROLES = [$SWISS->roles];
my $SWISS_SCORES = { win => 1, loss => 0, draw => 0.5, absent => 0, bye => 1 };
my $SWISS_FIRSTROUND = $SWISS->firstround;
my $SWISS_ALGORITHM = 'Games::Tournament::Swiss::Procedure::FIDE';
my $SWISS_ABBREV = { W => 'White', B => 'Black', 1 => 'Win', 0 => 'Loss', 0.5 => 'Draw', '=' => 'Draw'};

$SWISS->frisk($SWISS_SCORES, $SWISS_ROLES, $SWISS_FIRSTROUND, $SWISS_ALGORITHM, $SWISS_ABBREV);

$Games::Tournament::Swiss::Config::firstround = $SWISS_FIRSTROUND;
%Games::Tournament::Swiss::Config::scores = %$SWISS_SCORES;
@Games::Tournament::Swiss::Config::roles = @$SWISS_ROLES;
$Games::Tournament::Swiss::Config::algorithm = $SWISS_ALGORITHM;

require Games::Tournament::Swiss;
require Games::Tournament::Contestant::Swiss;
require Games::Tournament::Card;

my $players = {
1 => {id => 100, name => 'Player1', rating => 1518},
2 => {id => 200, name => 'Player2', rating => 1508},
3 => {id => 300, name => 'Player3', rating => 1500},
4 => {id => 400, name => 'Player4', rating => 1496}, ### we will watch his games, he must always win!!!
5 => {id => 500, name => 'Player5', rating => 1489},
6 => {id => 600, name => 'Player6', rating => 1480},
7 => {id => 700, name => 'Player7', rating => 1453},
8 => {id => 800, name => 'Player8', rating => 1336},
9 => {id => 900, name => 'Player9', rating => 1300}
};

my $my_player = $players->{4};

my $firstround = $SWISS_FIRSTROUND;
my $tourney;

for my $round (1..4) {
    &go_tourney({round => $round, rounds => 5});
    };

sub go_tourney {
my $r = shift;
my $rounds = $r->{rounds};
my $round = $r->{round};
my @entrants;

if ($round < 2) {
    foreach my $pnum (keys %{$players}) {
        my $c = Games::Tournament::Contestant::Swiss->new(id => $players->{$pnum}->{id}, pairingNumber => $pnum, name => $players->{$pnum}->{name}, rating => $players->{$pnum}->{rating}, score => 0);
        push @entrants, $c;
        undef $c;
        };
    $tourney = Games::Tournament::Swiss->new();
    $tourney->entrants(\@entrants);
    $tourney->round(0);
    $tourney->rounds($rounds);
    $tourney->assignPairingNumbers;
    my @prefplayers = sort {$a->pairingNumber <=> $b->pairingNumber} @{$tourney->entrants};
    my $half =  int(@prefplayers / 2);
    for my $i (0..$#prefplayers) {
        $prefplayers[$i]->preference->difference(0);
        if ($i == $#prefplayers && ($i+1) % 2) {
            $prefplayers[$i]->preference->sign("");
            last;
            };
        if ($i <= $half - 1) {
            my $sign1 = ($i % 2) ? 'White' : 'Black';
            $prefplayers[$i]->preference->sign($sign1);
            }
        else {
            my $sign2 = ($prefplayers[$i - $half]->preference->sign eq 'White') ? 'Black' : 'White';
            $prefplayers[$i]->preference->sign($sign2);
            };
        };
    $tourney->entrants(\@prefplayers);
    };

my %brackets = $tourney->formBrackets;
my $pairing = $tourney->pairing( \%brackets );
my $paired = $pairing->matchPlayers;
my $matches = $paired->{matches};
my @games;

for my $bracket ( reverse sort keys %$matches ) {
    my $bracketmatches = $matches->{$bracket};
    push @games, grep { $_ if ref eq 'Games::Tournament::Card' } @$bracketmatches;
    };

$tourney->round($round);
$tourney->publishCards(@games);

### Playing games
for my $game (@games) {
    if ($game->contestants->{Bye}) {
        $game->result({Bye => "Bye"});
        next;
        };
    my $w = $game->contestants->{White};
    next unless ($w && $w->isa('Games::Tournament::Contestant'));
    my $b = $game->contestants->{Black};
    next unless ($b && $b->isa('Games::Tournament::Contestant'));
    my $white_id = $w->id || next;
    my $black_id = $b->id || next;
    my $result = {};
    ### Checking player's ID
    if ($white_id == $my_player->{id}) {
        $result = {Black => 'Loss', White => 'Win'};
        }
    elsif ($black_id == $my_player->{id}) {
        $result = {Black => 'Win', White => 'Loss'};
        }
    else {
        $result = {Black => 'Win', White => 'Loss'}; ### Black must win otherwise
        };
    $game->result($result);
    };
$tourney->collectCards(@games);

### Updating scores
for my $player (@{$tourney->entrants}) {
    my $score = 0;
    for my $round (keys %{$player->scores}) {
        my $score_val = lc $player->scores->{$round} || "";
        next if (! $score_val);
        $score += $SWISS_SCORES->{$score_val} if (defined $SWISS_SCORES->{$score_val});
        };
    $player->score($score) if ($score);
    };

return 1;
};

I have installed Swiss Master 5.5.

It shows the following pairings for Round 4:

 

Player 4 - Player2

Player7 - Player8

Player5 - Player3

Player9 - Player6

 

Player1 -> bye.