tourney-manager 20070820-4 / usr / share / tourney-manager / Crosstable.pm

#!/usr/bin/perl
# $Id: Crosstable.pm 342 2006-08-13 19:56:16Z holger $
#
# Copyright (C) 2005 Holger Ruckdeschel <holger@hoicher.de>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
# MA 02110-1301, USA.
#

package Crosstable;

use warnings;
use strict;

###############################################################################

my %results;
my %scores;
my %nr_games;
my %sb_rating;
my @players;

my $print_sb = 0;

sub print {
	my ($args) = @_;

	my @pgnfiles = @{$args->{pgnfiles}};

	# Must clear these, in case of multiple calls to print(). We should
	# better rewrite this module into an object-oriented style.
	undef %results;
	undef %scores;
	undef %nr_games;
	undef %sb_rating;
	undef @players;
	
	foreach my $f (@pgnfiles) {
		open(FH, $f) or die("cannot open $f: $!\n");

		while (!eof(FH)) {
			read_game();
		}

		close(FH);
	}
	
	@players = keys(%nr_games);
	
	calculate_sb();
	rank_players();
	print_crosstable();
}

###############################################################################

#
# Read one game from input
#
sub read_game {
	my $white;
	my $black;
	my $result;

	while (<FH>) {
		s/\n//;
		s/\r//;
		chomp;

		if (s/^\[White *"(.*)" *\]/$1/) {
			$white = $_;
		} elsif (s/^\[Black *"(.*)" *\]/$1/) {
			$black = $_;
		} elsif (s/^\[Result *"(.*)" *\]/$1/) {
			$result = $_;
		}

		if (defined($white) && defined($black) && defined($result)) {
			#print("$white -- $black\t$result\n");
		
			$nr_games{$white}++;
			$nr_games{$black}++;
		
			if ($result eq "1-0") {
				$results{$white}{$black} .= "1";
				$results{$black}{$white} .= "0";
				$scores{$white} += 1;
				$scores{$black} += 0;
			} elsif ($result eq "0-1") {
				$results{$white}{$black} .= "0";
				$results{$black}{$white} .= "1";
				$scores{$white} += 0;
				$scores{$black} += 1;
			} elsif ($result eq "1/2-1/2") {
				$results{$white}{$black} .= "=";
				$results{$black}{$white} .= "=";
				$scores{$white} += 0.5;
				$scores{$black} += 0.5;
			} elsif ($result eq "*") {
				$results{$white}{$black} .= "*";
				$results{$black}{$white} .= "*";
				$scores{$white} += 0;
				$scores{$black} += 0;
			} else {
				print("Warning: Unknown result code in game"
					. " $white vs. $black: '$result'\n");
			}
			
			last;
		}
	}
}

#
# Calculate S-B rating of each player
# 
sub calculate_sb {
	foreach my $p1 (@players) {
		$sb_rating{$p1} = 0;
		foreach my $p2 (keys(%{$results{$p1}})) {
			for (my $i=0; $i<length($results{$p1}{$p2}); $i++) {
				my $code = substr($results{$p1}{$p2}, $i, 1);
				if ($code eq '1') {
					$sb_rating{$p1} += $scores{$p2};
				} elsif ($code eq '=') {
					$sb_rating{$p1} += $scores{$p2} / 2;
				}
			}
		}
	}
}

#
# Sort the list of players by rank.
# 
sub rank_players {
	@players = sort {
		if ($scores{$a} > $scores{$b}) {
			return -1;
		} elsif ($scores{$a} < $scores{$b}) {
			return 1;
		} elsif ($sb_rating{$a} > $sb_rating{$b}) {
			$print_sb = 1;
			return -1;
		} elsif ($sb_rating{$a} < $sb_rating{$b}) {
			$print_sb = 1;
			return 1;
		} else {
			# TODO	
			$print_sb = 1;
			print("Warning: Ranking between $a and $b"
					. " not fully solved.\n");
			return 0;
		}
	} @players;
}

#
# Actually print the crosstable.
#
sub print_crosstable {
	# Find the maximum number of games between any two players.
	my $maxgames = 0;
	foreach my $p1 (keys(%results)) {
		foreach my $p2 (keys(%{$results{$p1}})) {
			my $n = length($results{$p1}{$p2});
			if ($n > $maxgames) {
				$maxgames = $n;
			}
			
			if (defined($results{$p2}{$p1})) {
				$n = length($results{$p2}{$p1});
				if ($n > $maxgames) {
					$maxgames = $n;
				}
			}
		}
	}

	# Find the length of the longest name
	my $maxlen = 0;
	foreach my $p (@players) {
		my $l = length($p);
		if ($l > $maxlen) {
			$maxlen = $l;
		}
	}	

	# Print header
	if ($print_sb) {
		print(" " x ($maxlen+3) . "      Score     S-B    ");
	} else {
		print(" " x ($maxlen+3) . "      Score    ");
	}
	foreach my $player2 (@players) {
		my $pl2 = $player2;
		$pl2 =~ s/(.{1,$maxgames}).*/$1/;
		printf("%-${maxgames}s  ", $pl2);
	}
	print("\n");

	# Print one line for each player: <name> <score> <result> ...
	my $rank = 0;
	foreach my $player1 (@players) {
		$rank++;
		if ($print_sb) {
			printf("%2d %-${maxlen}s  %6.1f/%2d  %6.1f    ",
					$rank, $player1, 
					$scores{$player1},
					$nr_games{$player1},
					$sb_rating{$player1});
		} else {
			printf("%2d %-${maxlen}s  %6.1f/%2d    ",
					$rank, $player1, 
					$scores{$player1},
					$nr_games{$player1});
		}

		foreach my $player2 (@players) {
			if ($player1 eq $player2) {
				print("X" x $maxgames . "  ");
			} else {
				my $res = $results{$player1}{$player2};
				if (defined($res)) {
					print("$res");
				} else {
					$res = "";
				}
				print("." x ($maxgames - length($res)) . "  ");
			}
		}
		print("\n");
		
	}
}


###############################################################################
# Module loaded successfully.
1;