tourney_manager-20070820/0000750000175000017500000000000010662305151014471 5ustar holgerholgertourney_manager-20070820/engine-engine-match.pl0000750000175000017500000001433710662305151020643 0ustar holgerholger#!/usr/bin/perl # $Id: engine-engine-match.pl 341 2006-08-13 19:55:29Z holger $ # # TODO # o time control # o handle more engine output # use warnings; use strict; use IO::Handle; use IO::Select; use IPC::Open3; use Time::HiRes; use Getopt::Long; ############################################################################### # parse command line # my ($opt_fcp, $opt_fd, $opt_scp, $opt_sd); my ($opt_tc, $opt_mps, $opt_inc) = (5, 40, -1); my ($opt_sgf); my $getopt_res = GetOptions( "fcp=s" => \$opt_fcp, "fd=s" => \$opt_fd, "scp=s" => \$opt_scp, "sd=s" => \$opt_sd, "tc=i" => \$opt_tc, "mps=i" => \$opt_mps, "inc=i" => \$opt_inc, "sgf=s" => \$opt_sgf, ); if (!$opt_fcp) { die("you must set fcp"); } if (!$opt_scp) { die("you must set scp"); } ############################################################################### my $first = { id => "first ", cmd => $opt_fcp, dir => $opt_fd, name => $opt_fcp, pingseq => 1, firstmove => 1, }; my $second = { id => "second", cmd => $opt_scp, dir => $opt_sd, name => $opt_scp, pingseq => 1, firstmove => 1, }; ############################################################################### my $start_time = Time::HiRes::time(); start_engine($first); init_engine($first); start_engine($second); init_engine($second); my @moves; my $result = "*"; my $result_comment = "Unknown reason"; my $engine = $first; my $move; my $state = 'START'; my ($ff, $fs) = ('', ''); loop_main: while (1) { # print("loop_main, state = $state\n"); if ($state eq 'START') { send_to_engine($first, "go\n"); $state = 'WAITMOVEFIRST'; } elsif ($state eq 'WAITMOVEFIRST') { if ($ff =~ /^move ([\w-]+)$/) { my $move = $1; push(@moves, $move); send_to_engine($second, "$move\n"); $state = 'WAITMOVESECOND'; } if ($fs =~ /^move ([\w-]+)$/) { logmsg("### error: move out of turn by second\n"); last loop_main; } } elsif ($state eq 'WAITMOVESECOND') { if ($fs =~ /^move ([\w-]+)$/) { my $move = $1; push(@moves, $move); send_to_engine($first, "$move\n"); $state = 'WAITMOVEFIRST'; } if ($ff =~ /^move ([\w-]+)$/) { logmsg("### error: move out of turn by first\n"); last loop_main; } } elsif ($state eq 'RESULT') { if ($opt_sgf) { logmsg("### writing $opt_sgf\n"); write_pgn($opt_sgf); logmsg("### game is over\n"); } last loop_main; } else { die("illegal state: $state"); } ($ff, $fs) = rcve_from_both(); if ($ff =~ /^1-0 {(.*)}/ || $fs =~ /^1-0 {(.*)}/) { $result = '1-0'; $result_comment = $1; $state = 'RESULT'; } elsif ($ff =~ /^0-1 {(.*)}/ || $fs =~ /^0-1 {(.*)}/) { $result = '0-1'; $result_comment = $1; $state = 'RESULT'; } elsif ($ff =~ /^1\/2-1\/2 {(.*)}/ || $fs =~ /^1\/2-1\/2 {(.*)}/) { $result = '1/2-1/2'; $result_comment = $1; $state = 'RESULT'; } } logmsg("### terminating first\n"); send_to_engine($first, "quit\n"); logmsg("### terminating second\n"); send_to_engine($second, "quit\n"); #logmsg("### waiting for first to terminate\n"); #waitpid($first->{pid}, 0); #logmsg("### waiting for second to terminate\n"); #waitpid($second->{pid}, 0); ############################################################################### sub start_engine { my ($engine) = @_; my $cmd = ""; if ($engine->{dir}) { $cmd .= "cd '$engine->{dir}' && "; } $cmd .= $engine->{cmd}; logmsg("### starting $engine->{id}: $cmd\n"); eval { my ($fho, $fhi); $engine->{pid} = open3($fho, $fhi, $fhi, $cmd); $engine->{fho} = $fho; $engine->{fhi} = $fhi; }; if ($@ =~ /^open2:/) { die("open2 failed: $@\n"); } } sub send_to_engine { my ($engine, $cmd) = @_; logmsg(">$engine->{id}: $cmd"); my $fho = $engine->{fho}; $fho->autoflush(1); print($fho $cmd); } sub rcve_from_engine { my ($engine) = @_; my $fhi = $engine->{fhi}; my $line = <$fhi>; logmsg("<$engine->{id}: $line"); return $line; } sub init_engine { my ($engine) = @_; #send_to_engine($engine, "xboard\nprotover 2\n"); send_to_engine($engine, "xboard\n"); send_to_engine($engine, "protover 2\n"); while (1) { my $l = rcve_from_engine($engine); if ($l =~ /done=1/) { last; } } #send_to_engine($engine, "new\nrandom\n"); send_to_engine($engine, "new\n"); send_to_engine($engine, "random\n"); if ($opt_inc < 0) { send_to_engine($engine, "level $opt_mps $opt_tc 0\n"); } else { send_to_engine($engine, "level 0 $opt_tc $opt_inc\n"); } send_to_engine($engine, "post\n"); send_to_engine($engine, "hard\n"); send_to_engine($engine, "easy\n"); ping_engine($engine); send_to_engine($engine, "force\n"); } sub ping_engine { my ($engine) = @_; send_to_engine($engine, "ping $engine->{pingseq}\n"); while (1) { my $l = rcve_from_engine($engine); if ($l =~ /^pong $engine->{pingseq}/) { last; } } $engine->{pingseq}++; } sub rcve_from_both { my ($ff, $fs) = ('', ''); my $sel = new IO::Select($first->{fhi}, $second->{fhi}); my @ready = $sel->can_read(); foreach my $fh (@ready) { if ($fh == $first->{fhi}) { $ff = rcve_from_engine($first); } elsif ($fh == $second->{fhi}) { $fs = rcve_from_engine($second); } } return ($ff, $fs); } ############################################################################### sub write_pgn { my ($pgnfile) = @_; open(FH, ">$pgnfile") or die("$0: Cannot open $pgnfile for writing: $!"); print(FH "[Event \"unknown\"]\n"); print(FH "[Site \"unknown\"]\n"); my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(); printf(FH "[Date \"%4d.%02d.%02d\"]\n", $year+1900, $mon+1, $mday); print(FH "[Round \"unknown\"]\n"); my $fn = $first->{name}; $fn =~ s/\\/\\\\/g; $fn =~ s/"/\\"/g; my $sn = $second->{name}; $sn =~ s/\\/\\\\/g; $sn =~ s/"/\\"/g; print(FH "[White \"$fn\"]\n"); print(FH "[Black \"$sn\"]\n"); print(FH "[Result \"$result\"]\n"); print(FH "\n"); my $i = 0; my $nc = 0; foreach my $m (@moves) { my $s; if ($i%2 == 0) { $s = sprintf("%d. %s ", $i/2 + 1, $m); } else { $s = sprintf("%s ", $m); } print(FH $s); $nc += length($s); if ($nc > 70) { print(FH "\n"); $nc = 0; } $i++; } print(FH "\n"); print(FH "$result {$result_comment}\n"); close(FH); } sub logmsg { my ($msg) = @_; my $now_time = Time::HiRes::time(); STDOUT->autoflush(1); printf("%d %s", ($now_time-$start_time)*1000, $msg); } tourney_manager-20070820/crosstable.pl0000750000175000017500000000222010662305151017166 0ustar holgerholger#!/usr/bin/perl # $Id: crosstable.pl 265 2006-02-07 18:36:59Z holger $ # # Copyright (C) 2005-2006 Holger Ruckdeschel # # 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. # use warnings; use strict; use Getopt::Long; use Crosstable; ############################################################################### my $print_sb = 0; GetOptions("print-sb" => \$print_sb) or die; my @pgnfiles = splice(@ARGV, 0); Crosstable::print({ pgnfiles => \@pgnfiles, print_sb => $print_sb }); tourney_manager-20070820/example.conf0000640000175000017500000000344610662305151017003 0ustar holgerholger# Example configuration file for tourney manager. ############################################################################### # General options ############################################################################### # Path to xboard binary xboard_path = /usr/games/xboard #xboard_path = c:\games\winboard\winboard.exe # General arguments to xboard. xboard_user_args = -autoflag #-adjudicateLossThreshold -700 # Uncomment this if you are using winboard. #winboard = 1 ############################################################################### # Tourney configuration ############################################################################### # Number of games per match. games_per_match = 4 # If set, matches are not played as a whole, but in chunks of games_per_turn # games. # For example, if games_per_match = 8 and games_per_turn = 2, first the # first 2 games of each match are played, then the next 2 games of each # match, and so on. #games_per_turn = 2 # Time controls. If time_increment is set, incremental time controls are # used, and moves_per_session is ignored. If time_increment is unset, or # set to -1, a 'x moves in y minutes' time control is used. time_per_session = 2 #time_increment = 5 moves_per_session = 40 # Tourney type # Available types are: # rr (round-robin, default if nothing is specified) # gauntlet (also set option 'gauntlet_player' below) type = rr # Include engine configuration include example-engines.conf # Select which players should actually play the tournament. If no players # are specified, all known engines are added as players. player = HoiChess player = GNU Chess player = Sjeng player = Crafty # For gauntlets, at least one engine must be specified that should # play the gauntlet matches. gauntlet_player = HoiChess gauntlet_player = Crafty tourney_manager-20070820/README0000640000175000017500000000454010662305151015355 0ustar holgerholger=-=-=-=-=-=-=-=-=-=-=-=-=-= | Xboard Tourney Manager | =-=-=-=-=-=-=-=-=-=-=-=-=-= My favourite working and developing platform is Linux. However, there is (to my knowledge) no program that automatically runs a complete chess engine tournament, like WBTM. So I wrote my own, simple tourney manager, basically to test my chess engine HoiChess. Although initially developed for Linux, the tourney manager, which is written in Perl, now also runs on Windows. The current version can be downloaded at: http://www.hoicher.de/hoichess/tourney_manager If you have any questions or problems, feel free to ask me. Any feedback is welcome. Holger Ruckdeschel Installation ~~~~~~~~~~~~ The tourney manager is written in Perl, and consits of two Perl scripts, as well as two Perl modules: tourney.pl Tourney manager front-end (main program) crosstable.pl Utility script to print a crosstable from a set of .pgn files. Tourney.pm Perl module that implements the actual functionality of the tourney manager. Crosstable.pm Perl module to generate a crosstable from .pgn files. To run the tourney manager, make sure that the two modules are in a place where Perl can find them, i.e. either in the current directory or somewhere in Perl's include path. Look at the documentation of your Perl distribution for more info. You may need to set an environment variable like PERL5LIB or similar. The tourney manager requires one additional Perl module, that is not part of the standard Parl distribution: YAML This module is used to save and load the tourney state. This allows to interrupt and resume a tourney without having to replay all games. Download: http://search.cpan.org/~ingy/YAML-0.39/lib/YAML.pod For Windows, I have had success with the PXPerl distribution (http://www.pxperl.com/?pxperl). This distribution also contains the above mentioned YAML module and is pretty easy to set up. Running Tournaments ~~~~~~~~~~~~~~~~~~~ 1. Create a configuration file. Look at example.conf which is supplied along with the tourney manager. It is rather well commented. 2. Start the tourney manager (tourney.pl). The tourney manager uses an interactive command shell. To start up quickly, the following sequence of commands should be enough: create print start Help about commands is available by 'help' and 'help '. tourney_manager-20070820/ChangeLog0000640000175000017500000000126210662305151016245 0ustar holgerholgerDate 2007-08-19 * Use threads to run multiple games in parallel (for multiprocessor systems). (Use command 'start n' where n is the number of parallel games.) Date 2006-07-25 * Added Perl script 'engine-engine-match.pl', that can act as a simple xboard replacement. Date 2006-06-15 This is the first changelog entry. Any earlier changes are not documented here. * Configuration enhancements: - Allow to include other configuration files, e.g. with engine definitions. - Allow to explicitly select players that should play the tournament. By default, all known engines are added as players. tourney_manager-20070820/example-engines.conf0000640000175000017500000000050410662305151020421 0ustar holgerholger# Example engine configuration file for tourney manager. engine = HoiChess bin = hoichess dir = /tmp args = --hashsize 64M engine = GNU Chess bin = /usr/games/gnuchessx engine = Crafty bin = /usr/games/crafty args = logpath=/tmp engine = Phalanx bin = /usr/games/phalanx args = engine = Sjeng bin = /usr/games/sjeng tourney_manager-20070820/tourney.pl0000750000175000017500000001352610662305151016545 0ustar holgerholger#!/usr/bin/perl # $Id: tourney.pl 430 2007-08-19 19:47:12Z holger $ # # Copyright (C) 2005-2007 Holger Ruckdeschel # # 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. # use warnings; use strict; use File::Basename; use File::Glob ':glob'; use Getopt::Std; use Term::ReadLine; use Tourney; use Crosstable; ############################################################################### my $verbose = 0; my $debug = 0; ############################################################################### # Parse command line ############################################################################### my %opts; getopts('Vvd', \%opts); if (defined($opts{V})) { Tourney::print_version(); exit(0); } if (defined($opts{v})) { $verbose = 1; $Tourney::verbose = 1; } if (defined($opts{d})) { $debug = 1; $Tourney::debug = 1; } ############################################################################### $SIG{'INT'} = 'IGNORE'; my $quit = 0; my %commands = ( help => \&cmd_help, quit => \&cmd_quit, tourney => \&cmd_tourney, clear => \&cmd_clear, create => \&cmd_create, update => \&cmd_update, print => \&cmd_print, start => \&cmd_start, stop => \&cmd_stop, crosstable => \&cmd_crosstable, replay => \&cmd_replay, ); my %command_help = ( ### help => "display help about commands\n", ### quit => "quits tourney manager\n", ### tourney => < Switches to tourney ''. EOF , ### clear => < "initialize tourney, create tourney state\n", ### update => "re-read configuration file, update tourney\n", ### print => "display current tourney state\n", ### start => "starts tourney\n", ### stop => < "print current crosstable of tourney\n", ### replay => < Replay whole match replay Replay single game EOF , ### ); sub shell { print(<' for detailed help about a specific command. EOF ) if (-t STDIN); if (defined($ARGV[0])) { $Tourney::tourney_name = $ARGV[0]; } my $readline; if (-t STDIN) { $readline = new Term::ReadLine($0); } while (!$quit) { my $prompt; if ($Tourney::runner_running) { $prompt = "$Tourney::tourney_name [running]> "; } elsif (Tourney::is_locked()) { $prompt = "$Tourney::tourney_name [locked]> "; } else { $prompt = "$Tourney::tourney_name> "; } my $input; if (-t STDIN) { $input = $readline->readline($prompt); } else { $input = ; } if (!$input) { if (! -t STDIN) { $quit = 1; } next; } chomp($input); process_command($input); } } sub process_command { my ($input) = @_; if (!$input) { return; } my @args = split(/[ \t]+/, $input); if (defined($commands{$args[0]})) { &{$commands{$args[0]}}(@args); } else { print("Unknown command: $args[0]\n"); } } print_version(); print("\n"); shell(); exit(0); ###################################################################### sub cmd_help { if ($_[1]) { if (defined($command_help{$_[1]})) { print("$_[1] -- $command_help{$_[1]}"); } else { print("No help available for command '$_[1]'.\n"); } } else { print_version(); print("\n"); my @c = sort(keys(%commands)); print("Available commands: @c\n"); } } sub cmd_quit { if ($Tourney::runner_running) { print("Runner thread still running. Use 'stop' first.\n"); return; } $quit = 1; } sub cmd_tourney { if ($Tourney::runner_running) { print("Runner thread still running. Use 'stop' first.\n"); return; } if (defined($_[1])) { $Tourney::tourney_name = $_[1]; } print("Current tourney: $Tourney::tourney_name\n"); } sub cmd_clear { my $args = {}; while (defined($_[1])) { if ($_[1] eq '+logs') { $args->{delete_logs} = 1; } elsif ($_[1] eq '+pgns') { $args->{delete_pgns} = 1; } shift; } clear_tourney($args); } sub cmd_create { create_tourney(); } sub cmd_update { update_tourney(); } sub cmd_print { print_tourney(); } sub cmd_start { my $nr_threads = 1; if (defined($_[1])) { $nr_threads = $_[1]; } if (start_tourney($nr_threads)) { # Wait a bit, so that thread's output will not disturb # our input prompt too much. sleep(2); } } sub cmd_stop { shift(@_); stop_tourney(@_); } sub cmd_crosstable { # TODO Perhaps this should also go into Tourney.pm. my @pgnfiles = bsd_glob($Tourney::tourney_name . ".match-*-*.pgn"); Crosstable::print({ pgnfiles => \@pgnfiles }); } sub cmd_replay { if (!defined($_[1])) { print("This command requires at least on argument.\n"); return; } elsif ($_[1] !~ /^\d+$/) { print("Illegal argument: $_[1]\n"); return; } elsif (defined($_[2]) && $_[2] !~ /^\d+$/) { print("Illegal argument: $_[2]\n"); return; } Tourney::replay_game($_[1], $_[2]); } tourney_manager-20070820/TODO0000640000175000017500000000005410662305151015161 0ustar holgerholgerTODO ~~~~ o Write a decent documentation. tourney_manager-20070820/Tourney.pm0000640000175000017500000007677010662305151016516 0ustar holgerholger#!/usr/bin/perl # $Id: Tourney.pm 430 2007-08-19 19:47:12Z holger $ # # Copyright (C) 2005-2007 Holger Ruckdeschel # # 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 Tourney; use Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(verbose debug print_version tourney_name runner_running is_locked clear_tourney print_tourney create_tourney update_tourney replay_game start_tourney stop_tourney ); use warnings; use strict; use Fcntl; use File::Basename; use File::Copy; use File::Glob ':glob'; use IPC::Open3; use List::Util qw(shuffle); use threads; use threads::shared; use YAML qw(DumpFile LoadFile); our $verbose = 0; our $debug = 0; my @svn_rev_tmp = split(/\s+/, '$Rev: 430 $'); my $MODULE_VERSION = '0.' . $svn_rev_tmp[1]; our $tourney_name = "example"; my $configfile; my $statefile; my $lockfile; my $STATE_VERSION = 7; my $state; my $runner_thread; our $runner_running : shared = 0; my @worker_threads; my @worker_running : shared; my $nr_worker_threads = 1; my $intr_now : shared; my $intr_turn : shared; my $skip_match : shared; init(); ############################################################################### # General functions ############################################################################### sub print_version { print( < This program is free software and comes with ABSOLUTELY NO WARRANTY. See the GNU General Public License for more details. EOF ); } sub init { } ############################################################################### # Functions to access saved state ############################################################################### sub init_state { $configfile = "$tourney_name.conf"; $statefile = "$tourney_name.state"; $lockfile = "$tourney_name.lock"; undef $state; $state = { _version => $STATE_VERSION, # status => 'uninitialized', # type => 'uninitialized', settings => {}, engines => {}, players => [], gauntlet_players => [], matches => [], }; if (-s $statefile && load_state()) { return 1; } else { return 0; } } sub save_state { if (! -s $lockfile) { die("save_state(): tourney is not locked.\n"); } # Check if we have really locked the state before overwriting it. open(FH, $lockfile) or die("save_state(): cannot open $lockfile: $!\n"); my $pid = ; close(FH); if ($pid != $$) { die("save_state(): pid in lockfile ($pid) does not match" . " our pid ($$).\n"); } DumpFile($statefile, $state); return 1; } sub load_state { my $s = LoadFile($statefile); my $v = $s->{_version}; if (!defined($v)) { $v = 0; } if ($v != $STATE_VERSION) { print("Error: State version mismatch: state file $statefile" . " is version $v," . " but version $STATE_VERSION is required.\n"); return 0; } $state = $s; print("Loaded tourney state from $statefile (state version $v).\n") if ($debug); return 1; } sub lock_tourney { sysopen(LOCKFILE, $lockfile, O_WRONLY | O_EXCL | O_CREAT) or die("Cannot create lock file $lockfile: $!\n"); print(LOCKFILE $$); close(LOCKFILE); } sub try_lock_tourney { if (-e $lockfile) { print("Tourney is locked ($lockfile exists).\n"); return 0; } else { lock_tourney(); return 1; } } sub unlock_tourney { unlink($lockfile) or die("Cannot unlink lock file $lockfile: $!\n"); } sub backup_state { if (! -s $lockfile) { die("save_state(): tourney is not locked.\n"); } my $i = 0; my $statefile_bak; do { $statefile_bak = "$statefile.$i"; $i++; } while (-e $statefile_bak); copy($statefile, $statefile_bak) or die("Cannot copy $statefile to $statefile_bak: $!\n"); print("Tourney state backed up to $statefile_bak.\n"); } ############################################################################### # Functions to initialize tourney ############################################################################### sub set_defaults { # These are default values. $state->{settings}->{xboard_path} = "xboard"; $state->{settings}->{xboard_user_args} = ""; $state->{settings}->{winboard} = 0; $state->{settings}->{games_per_match} = 1; $state->{settings}->{games_per_turn} = 0; $state->{settings}->{time_per_session} = 5; $state->{settings}->{time_increment} = -1; $state->{settings}->{moves_per_session} = 40; $state->{type} = 'rr'; } sub read_config { my ($configfile) = @_; my $engine_name; my $fh; if (! open($fh, $configfile)) { print("Error: Cannot open $configfile: $!\n"); return 0; } while (<$fh>) { chomp; s/#.*$//; s/^\s*//; s/\s*$//; if (/^$/) { next; } if (/^\s*include\s+(.*)\s*$/) { my $includefile = $1; print("$configfile:$.: include: $includefile\n") if ($debug); my $ret = read_config($includefile); if (!$ret) { return $ret; } next; } if (! /^\s*([^=\s]+)\s*=\s*(.*)\s*$/) { print("$configfile:$.: Error: "); print("Illegal line in config file: $_\n"); return 0; } my $param = $1; my $value = $2; print("$configfile:$.: param='$param', value='$value'\n") if ($debug); if ($param eq "xboard_path" || $param eq "xboard_user_args" || $param eq "winboard") { $state->{settings}->{$param} = $value; } elsif ($param eq "games_per_match" || $param eq "games_per_turn" || $param eq "time_per_session" || $param eq "time_increment" || $param eq "moves_per_session") { if ($value !~ /^\d+$/) { print("$configfile:$.: Error: "); print("Value of parameter '$param' must" . " be a number, not '$value'\n"); return 0; } $state->{settings}->{$param} = $value; } elsif ($param eq "type") { $state->{type} = $value; } elsif ($param eq "player") { push(@{$state->{players}}, $value); } elsif ($param eq "gauntlet_player" || $param eq "gauntlet_engine") { push(@{$state->{gauntlet_players}}, $value); } elsif ($param eq "engine") { $engine_name = $value; # Make sure values are defined even if they're not # in the configuation file. However, don't overwrite # any existing values. if (!defined($state->{engines}->{$engine_name})) { $state->{engines}->{$engine_name} = { name => $engine_name, bin => "/bin/false", dir => ".", args => "", }; } } elsif ($param eq "name" || $param eq "bin" || $param eq "dir" || $param eq "args") { $state->{engines}->{$engine_name}->{$param} = $value; } else { print("$configfile:$.: Error: "); print("Unknown parameter: $param\n"); return 0; } } close($fh); return 1; } sub is_locked { init_state() || return; if (-e $lockfile) { return 1; } else { return 0; } } sub clear_tourney { my ($args) = @_; init_state() || return 0; try_lock_tourney() || return 0; if (-e $statefile) { unlink($statefile) or die("Error: cannot unlink $statefile: $!\n"); for (my $i = 0; ; $i++) { my $f = "$statefile.$i"; if (! -e $f) { last; } unlink($f) or die("Error: cannot unlink $f: $!\n"); } } undef $state; print("State of tourney `$tourney_name' removed.\n"); if ($args->{delete_logs}) { foreach my $f (bsd_glob("$tourney_name.match-*.log*")) { unlink($f) or die("Error: cannot unlink $f: $!\n"); } print("Logfiles of tourney `$tourney_name' removed.\n"); } if ($args->{delete_pgns}) { foreach my $f (bsd_glob("$tourney_name.match-*.pgn*")) { unlink($f) or die("Error: cannot unlink $f: $!\n"); } print("PGN files of tourney `$tourney_name' removed.\n"); } unlock_tourney(); return 1; } sub create_tourney { if (init_state()) { print("Tourney `$tourney_name' already created.\n"); return 0; } try_lock_tourney() || return 0; set_defaults(); if (!read_config($configfile)) { unlock_tourney(); return 0; } # # Create player list # generate_playerlist(); check_playerlist() || return 0; # # Generate matches # if ($state->{type} eq 'rr') { # normal round robin tourney @{$state->{matches}} = rutschsystem(shuffle(@{$state->{players}})); } elsif ($state->{type} eq 'gauntlet') { # first create normal round robin tourney, then remove # all matches where none of the gauntlet players take # part. my @tmp_matches = rutschsystem(shuffle(@{$state->{players}})); foreach my $m (@tmp_matches) { my $ok = 0; foreach my $p (@{$state->{gauntlet_players}}) { if ($p eq $m->{white} || $p eq $m->{black}) { $ok = 1; last; } } if ($ok) { push(@{$state->{matches}}, $m); } } } else { print("Illegal tourney type: $state->{type}\n"); return 0; } # # Set result string # my $gpm = $state->{settings}->{games_per_match}; foreach my $match (@{$state->{matches}}) { if (!defined($match->{result})) { $match->{result} = "." x $gpm; } elsif (length($match->{result}) < $gpm) { $match->{result} .= "." x ($gpm - length($match->{result})); } } # # Misc # if ($state->{settings}->{games_per_turn} <= 0) { $state->{settings}->{games_per_turn} = $state->{settings}->{games_per_match}; } $state->{status} = "ready"; # # Done. # save_state(); unlock_tourney(); print("Tourney `$tourney_name' created.\n"); return 1; } sub update_tourney { if (!init_state()) { print("Tourney `$tourney_name' not yet created.\n"); return 0; } try_lock_tourney() || return 0; # Save old player list and clear it. my @oldplayers = @{$state->{players}}; $state->{players} = []; if (!read_config($configfile)) { unlock_tourney(); return 0; } # # Update player list # generate_playerlist(); check_playerlist() || return 0; # # Determine list of new players # my @allplayers = @{$state->{players}}; my @newplayers; foreach my $p (@allplayers) { if (! grep { $p eq $_ } @oldplayers) { push(@newplayers, $p); print("New player: $p\n"); } } # # Generate matches for new players # # FIXME This will not work correctly if an already existing player # was only added as new gauntlet player. # if ($state->{type} eq 'rr' || $state->{type} eq 'gauntlet') { my @gauntlet_players = @{$state->{gauntlet_players}}; my $playswhite = 1; my $lastmatch = $state->{matches}->[$#{$state->{matches}}]; my $round = $lastmatch->{round} + 1; my $matchnr1 = $lastmatch->{number} + 1; foreach my $np (@newplayers) { foreach my $p (@oldplayers) { if ($p eq $np) { next; } elsif ($state->{type} eq 'gauntlet' && !grep { $_ eq $p || $_ eq $np } @gauntlet_players) { next; } my $white; my $black; if ($playswhite) { $white = $np; $black = $p; } else { $white = $p; $black = $np; } printf("New match: %d. %s -- %s (round %d)\n", $matchnr1, $white, $black, $round); push(@{$state->{matches}}, { round => $round, number => $matchnr1, white => $white, black => $black }); $matchnr1++; $playswhite = !$playswhite; } # Put new player into list of existing players, so # that it will play agains other new players. push(@oldplayers, $np); $round++; } } else { print("Illegal tourney type: $state->{type}\n"); return 0; } # # Set result string # my $gpm = $state->{settings}->{games_per_match}; foreach my $match (@{$state->{matches}}) { if (!defined($match->{result})) { $match->{result} = "." x $gpm; } elsif (length($match->{result}) < $gpm) { $match->{result} .= "." x ($gpm - length($match->{result})); } } # # Done. # backup_state(); $state->{status} = "updated"; save_state(); unlock_tourney(); print("Tourney `$tourney_name' updated.\n"); return 1; } sub rutschsystem { my @players = @_; my $nplayers = @players; my $even = @players%2 == 0; my $nr_rounds = $even ? $nplayers-1 : $nplayers; my @players2 = @players; my @players1 = splice(@players2, 0, $nplayers/2); #print("players1 = @players1\n"); #print("players2 = @players2\n"); my @matches; my $m = 0; for (my $round=1; $round<=$nr_rounds; $round++) { #printf("Round %d:\n", $round); my $nr_boards = ($nplayers-1) / 2; for (my $i=0; $i<$nr_boards; $i++) { my $white; my $black; # With an even number of players, the first board # ($i == 0) must be flipped each round. All other # boards remain fixed (as will the first board when # the number of players is odd), with alternating # positions of white and black. if ($even && $i == 0) { if ($round%2 == 1) { $white = $players1[$i]; $black = $players2[$i]; } else { $white = $players2[$i]; $black = $players1[$i]; } } elsif ($i%2 == 0) { $white = $players1[$i]; $black = $players2[$i]; } else { $white = $players2[$i]; $black = $players1[$i]; } $m++; #print("$m. $white -- $black\n"); push(@matches, { round => $round, number => $m, white => $white, black => $black }); } # With an even number of players, the first player will # always remain at his position. if ($even) { my $tmp = shift(@players1); push(@players2, pop(@players1)); unshift(@players1, shift(@players2)); unshift(@players1, $tmp); } else { push(@players2, pop(@players1)); unshift(@players1, shift(@players2)); } #print("players1 = @players1\n"); #print("players2 = @players2\n"); } return @matches; } ############################################################################### # Print functions ############################################################################### sub print_tourney { init_state() || return; print("Tourney status: $state->{status}\n"); print("\n"); print("Tourney type: $state->{type}\n"); print("\n"); print("Tourney settings:\n"); printf("\tGames per match: %d\n", $state->{settings}->{games_per_match}); printf("\tTime per session: %d min\n", $state->{settings}->{time_per_session}); printf("\tTime increment: %d sec\n", $state->{settings}->{time_increment}) if ($state->{settings}->{time_increment} != -1); printf("\tMoves per session: %d\n", $state->{settings}->{moves_per_session}) if ($state->{settings}->{time_increment} == -1); print("\n"); my $maxlen = get_length_of_longest_engine_name(); my @participants; foreach my $e (@{$state->{players}}) { my $tmp = sprintf("%-${maxlen}s", $state->{engines}->{$e}->{name}); if ($state->{type} eq 'gauntlet' && grep { $_ eq $e; } @{$state->{gauntlet_players}}) { $tmp .= " [gauntlet player]"; } push(@participants, $tmp); } my $nparticipants= @participants; print("Participants: $nparticipants\n"); foreach my $p (sort(@participants)) { print("\t$p\n"); } print("\n"); my $nr_matches = @{$state->{matches}}; print("Number of matches: $nr_matches\n"); print("\n"); my $round = 0; foreach my $match (@{$state->{matches}}) { if ($match->{round} != $round) { $round = $match->{round}; print("Round $round:\n"); } print_match($match); } } sub print_match { my ($match) = @_; my $maxlen = get_length_of_longest_engine_name(); my $result = $match->{result}; my $whitepts = 0; my $blackpts = 0; for (my $i = 0; $i < length($result); $i++) { my $r = substr($result, $i, 1); if ($r eq '1') { $whitepts += 1; } elsif ($r eq '0') { $blackpts += 1; } elsif ($r eq '=') { $whitepts += 0.5; $blackpts += 0.5; } } printf("%4d. %-${maxlen}s -- %-${maxlen}s\t%s (%.1f-%.1f)\n", $match->{number}, $state->{engines}->{$match->{white}}->{name}, $state->{engines}->{$match->{black}}->{name}, $result, $whitepts, $blackpts); } ############################################################################### # Runner thread handling functions ############################################################################### sub start_tourney { ($nr_worker_threads) = @_; if ($runner_running) { print("Runner thread already running.\n"); return 0; } $intr_now = 0; $intr_turn = 0; $skip_match = 0; $runner_running = 1; $runner_thread = threads->new(\&runner); $runner_thread->detach(); return 1; } sub stop_tourney { if (!$runner_running) { print("Runner thread not running.\n"); return; } if (defined($_[0]) && $_[0] eq "turn") { $intr_turn = 1; print("Tourney will be interrupted at end of current turn.\n"); } elsif (defined($_[0]) && $_[0] eq "match") { $skip_match = 1; print("Current match will be skipped after current game has finished.\n"); } else { $intr_now = 1; print("Tourney will be interrupted after current game.\n"); } } sub runner { print("Runner thread started.\n"); run_tourney(); print("Runner thread terminated.\n"); $runner_running = 0; } ############################################################################### # Functions to modify tourney ############################################################################### sub replay_game { init_state() || return; try_lock_tourney() || return; # If 2nd argument is undefined, all games of a match will be replayed. my ($matchnr1, $gamenr1) = @_; # Ugh. We cannot just use '$state->{matches}->[$matchnr1-1]', # because for gauntlet tourneys, the match array isn't dense. my $match; foreach my $m (@{$state->{matches}}) { if ($m->{number} == $matchnr1) { $match = $m; last; } } if (! defined($match)) { print("Error: Illegal match number: $matchnr1\n"); unlock_tourney(); return; } # shortcuts my $gpm = $state->{settings}->{games_per_match}; if (! defined($gamenr1)) { # replay all games for (my $gamenr = 0; $gamenr < $gpm; $gamenr++) { printf("Game %d/%d will be replayed.\n", $matchnr1, $gamenr+1); substr($match->{result}, $gamenr, 1) = '.'; moveaway_logpgn($matchnr1, $gamenr+1); } } else { if ($gamenr1-1 < 0 || $gamenr1-1 >= $gpm) { print("Error: Illegal game number: $gamenr1\n"); unlock_tourney(); return; } # replay single game printf("Game %d/%d will be replayed.\n", $matchnr1, $gamenr1); substr($match->{result}, $gamenr1-1, 1) = '.'; moveaway_logpgn($matchnr1, $gamenr1); } save_state(); unlock_tourney(); } ############################################################################### # Functions to run tourney ############################################################################### sub run_tourney { init_state() || return; try_lock_tourney() || return; $state->{status} = "running"; save_state(); # shortcuts my $gpm = $state->{settings}->{games_per_match}; my $gpt = $state->{settings}->{games_per_turn}; # First clear any bad result codes of unfinished games. foreach my $match (@{$state->{matches}}) { my $matchnr1 = $match->{number}; for (my $gamenr = 0; $gamenr < $gpm; $gamenr++) { my $r = substr($match->{result}, $gamenr, 1); if ($r =~ /[\*ER]/) { printf("Game %d/%d was not finished correctly" . " last time (result '$r')," . " replaying.\n", $matchnr1, $gamenr+1); substr($match->{result}, $gamenr, 1) = '.'; moveaway_logpgn($matchnr1, $gamenr+1); } } } save_state(); # Initialize worker threads. undef @worker_threads; undef @worker_running; for (my $ti = 0; $ti < $nr_worker_threads; $ti++) { push(@worker_threads, undef); push(@worker_running, 0); } # Run games ... my $nr_turns = $gpm / $gpt + 1; for (my $turn = 0; $turn < $nr_turns; $turn++) { foreach my $match (@{$state->{matches}}) { if ($intr_now) { last; } my $matchnr1 = $match->{number}; for (my $gamenr = $turn*$gpt; $gamenr < ($turn+1) * $gpt && $gamenr < $gpm; $gamenr++) { my $r = substr($match->{result}, $gamenr, 1); if ($r =~ /[10=]/) { next; } elsif ($r =~ /[\*ER]/) { printf("Error: game %d/%d has bad result code '$r'.\n", $matchnr1, $gamenr+1); $intr_now = 1; return; } elsif ($r =~ /[\.]/) { # find idle thread my $found = 0; while (!$found) { join_workers(0); if ($intr_now) { last; } for (my $ti = 0; $ti < $nr_worker_threads; $ti++) { if (defined($worker_threads[$ti])) { next; } substr($match->{result}, $gamenr, 1) = 'R'; save_state(); # Start thread. # Ugh. Since &worker returns a list, # we need to create the thread object in list $worker_running[$ti] = 1; ($worker_threads[$ti]) = threads->new(\&worker, $ti, $match, $gamenr); $found = 1; last; } if ($found) { last; } sleep 1; } join_workers(0); } else { printf("Error: game %d/%d has illegal result code" . " '$r'.\n", $matchnr1, $gamenr+1); $intr_now = 1; return; } join_workers(0); if ($intr_now || $skip_match) { last; } } } join_workers(0); if ($intr_turn) { last; } } join_workers(1); # Count failed matches. my $failed_matches = 0; foreach my $match (@{$state->{matches}}) { if ($match->{result} =~ /[E\*]/) { $failed_matches++; } } # Determine tourney status. if ($intr_now || $intr_turn) { $state->{status} = "interrupted"; print("Tourney interrupted.\n"); } elsif ($failed_matches > 0) { $state->{status} = "finished,errors"; print("Tourney finished with errors: "); printf("%d match%s %s not completed correctly.\n", $failed_matches, $failed_matches == 1 ? "" : "es", $failed_matches == 1 ? "was" : "were", $failed_matches == 1 ? "it" : "them"); } else { $state->{status} = "finished"; print("Tourney finished.\n"); } # Finish. save_state(); unlock_tourney(); } sub worker { my ($ti, $match, $gamenr) = @_; my $matchnr1 = $match->{number}; printf("Worker thread %d started (game %d/%d).\n", $ti, $matchnr1, $gamenr+1); my $r = run_game($match, $gamenr); printf("Worker thread %d finished (game %d/%d, result '%s').\n", $ti, $matchnr1, $gamenr+1, $r); $worker_running[$ti] = 0; return ($matchnr1, $gamenr, $r); } sub join_workers { my ($all) = @_; # all or only currently finished workers if ($all) { print("Waiting for all remaining worker threads...\n"); } for (my $ti = 0; $ti < $nr_worker_threads; $ti++) { if (!defined($worker_threads[$ti])) { next; } elsif (!$all && $worker_running[$ti]) { next; } # join thread and get result printf("Waiting for worker thread %d...\n", $ti); my ($matchnr1, $gamenr, $r) = $worker_threads[$ti]->join(); $worker_threads[$ti] = undef; printf("Joined worker thread %d (game %d/%d, result '%s').\n", $ti, $matchnr1, $gamenr+1, $r); # save result foreach my $match (@{$state->{matches}}) { if ($matchnr1 == $match->{number}) { substr($match->{result}, $gamenr, 1) = $r; } } save_state(); } } sub run_game { my ($match, $gamenr) = @_; my $matchnr1 = $match->{number}; # We must alternate between white and black my $w; my $b; if ($gamenr % 2 == 0) { $w = 'white'; $b = 'black'; } else { $w = 'black'; $b = 'white'; } my $white = $match->{$w}; my $black = $match->{$b}; # shortcuts my $white_name = $state->{engines}->{$white}->{name}; my $black_name = $state->{engines}->{$black}->{name}; printf("[%s] Starting game %d/%d: %s vs. %s\n", format_time(time()), $matchnr1, $gamenr+1, $white_name, $black_name); my ($logfile, $pgnfile) = get_logpgn_name($matchnr1, $gamenr+1); # Move away old PGN and log files. if (-e $logfile || -e $pgnfile) { moveaway_logpgn($matchnr1, $gamenr+1); } my $pgntmpfile = "$pgnfile.tmp"; my $xboard_args = "-debug -xexit"; $xboard_args .= " -thinking"; $xboard_args .= " -xponder"; $xboard_args .= " -mg 1"; $xboard_args .= sprintf(" -tc %d -inc %d -mps %d", $state->{settings}->{time_per_session}, $state->{settings}->{time_increment}, $state->{settings}->{moves_per_session}); $xboard_args .= " -sgf $pgntmpfile"; $xboard_args .= sprintf(" -fcp '%s %s' -fd '%s' -scp '%s %s' -sd '%s'", $state->{engines}->{$white}->{bin}, $state->{engines}->{$white}->{args}, $state->{engines}->{$white}->{dir}, $state->{engines}->{$black}->{bin}, $state->{engines}->{$black}->{args}, $state->{engines}->{$black}->{dir}); $xboard_args .= " $state->{settings}->{xboard_user_args}"; # # Run xboard. # my $xboard_path = $state->{settings}->{xboard_path}; my $xboard_command = "$xboard_path $xboard_args"; if ($state->{settings}->{winboard}) { # winboard print("Running winboard: $xboard_command\n") if ($debug); my $ret = system("$xboard_command"); sleep 2; move("winboard.debug", $logfile) or print("Warning: moving winboard.debug to" . " $logfile failed: $!\n"); $ret >>= 8; if ($ret != 0) { printf("Error: winboard exited with $ret.\n"); return 'E'; } } else { # xboard print("Running xboard: $xboard_command\n") if ($debug); my $ret = system("$xboard_command > $logfile 2>&1"); $ret >>= 8; if ($ret != 0) { printf("Error: xboard exited with $ret.\n"); return 'E'; } } # # Get result from PGN file. # TODO update comment # # We silently assume that the PGN is in export format, i.e. # the 'Result' tag appears after the corresponding 'White' # and 'Black' tags. # my $result; if (!open(PGNTMP, $pgntmpfile)) { print("Error: Cannot open $pgntmpfile for reading: $!\n"); return 'E'; } if (!open(PGNFIXED, ">$pgnfile")) { print("Error: Cannot open $pgnfile for writing: $!\n"); return 'E'; } while () { s/\n//; s/\r//; chomp; my $fixedline; if (/^\[White *"?([^"]*)"? *\]/) { if ($white_name ne $1) { print("$pgnfile: White player names" . " don't match: should be" . " '$white_name', but is: '$1'." . " FIXED\n") if ($debug); $fixedline = "[White \"$white_name\"]"; } else { $fixedline = $_; } } elsif (/^\[Black *"?([^"]*)"? *\]/) { if ($black_name ne $1) { print("$pgnfile: Black player names" . " don't match: should be" . " '$black_name', but is: '$1'." . " FIXED\n") if ($debug); $fixedline = "[Black \"$black_name\"]"; } else { $fixedline = $_; } } elsif (/^\[Result *"?([^"]*)"? *\]/) { if (defined($result)) { print("Warning: Result already defined.\n"); } $result = $1; $fixedline = $_; } else { $fixedline = $_; } print(PGNFIXED $fixedline . "\n"); } close(PGNTMP); close(PGNFIXED); unlink($pgntmpfile) or die("cannot unlink $pgntmpfile: $!"); printf("[%s] Game %d/%d finished: %s vs. %s %s\n", format_time(time()), $matchnr1, $gamenr+1, $white_name, $black_name, $result); if ($result eq "1-0") { if ($w eq 'white') { return '1'; } else { return '0'; } } elsif ($result eq "0-1") { if ($w eq 'white') { return '0'; } else { return '1'; } } elsif ($result eq "1/2-1/2") { return '='; } elsif ($result eq "*") { return '*'; } else { print("Error: $pgnfile: Unknown result code: '$result'.\n"); return 'E'; } } ############################################################################### # Utility functions ############################################################################### # # Generate player list. # If no players we selected in the configuration file, add all # known engines as players. # sub generate_playerlist { if (@{$state->{players}} == 0) { print("No players selected, all known engines will be added" . " as players.\n"); push(@{$state->{players}}, sort(keys(%{$state->{engines}}))); } } # # Check player list. # Check if we have an engine configuration for each player. # sub check_playerlist { foreach my $p (@{$state->{players}}) { if (!defined($state->{engines}->{$p})) { print("Error: No engine configuration for" . " player '$p'\n"); return 0; } } return 1; } sub get_logpgn_name { my ($matchnr1, $gamenr1) = @_; my $pgnfile = sprintf("$tourney_name.match-%03d-%03d.pgn", $matchnr1, $gamenr1); my $logfile = sprintf("$tourney_name.match-%03d-%03d.log", $matchnr1, $gamenr1); return ($logfile, $pgnfile); } sub moveaway_logpgn { my ($matchnr1, $gamenr1) = @_; my ($logfile, $pgnfile) = get_logpgn_name($matchnr1, $gamenr1); my $i = 0; my $logfile_old; my $pgnfile_old; do { $logfile_old = "$logfile.$i"; $pgnfile_old = "$pgnfile.$i"; $i++; } while (-e $logfile_old || -e $pgnfile_old); if (-e $logfile) { print("renaming '$logfile' in '$logfile_old'\n") if ($debug); move($logfile, $logfile_old) or die("cannot move '$logfile' to" . " '$logfile_old': $!\n"); } if (-e $pgnfile) { print("renaming '$pgnfile' in '$pgnfile_old'\n") if ($debug); move($pgnfile, $pgnfile_old) or die("cannot move '$pgnfile' to" . " '$pgnfile_old': $!\n"); } } sub get_length_of_longest_engine_name { my $maxlen = 0; foreach my $p (keys(%{$state->{engines}})) { my $l = length($state->{engines}->{$p}->{name}); if ($l > $maxlen) { $maxlen = $l; } } return $maxlen; } # # Try to find out the real name of the engine, # which is reported by 'feature myname="..."'. # sub get_engine_realname { my ($engine) = @_; my $dir = $state->{engines}->{$engine}->{dir}; my $bin = $state->{engines}->{$engine}->{bin}; my $args = $state->{engines}->{$engine}->{args}; my $name; print("get_engine_realname(): dir='$dir', bin='$bin', args='$args'\n") if ($debug); # We must catch SIGPIPE, in case the process created by open3 # failes to start or exists unexpectedly. local $SIG{PIPE} = sub { print("Error: '$bin': $!\n"); }; my $pid; my $batfile; # for windows if ($state->{settings}->{winboard}) { # Because there is no portable way to put multiple commands # in one line, we write then into a .bat file first. $batfile = "$tourney_name.bat"; open(FH, ">$batfile") or die("Error: Cannot open $batfile for writing: $!\n"); print(FH "cd $dir\n"); print(FH "$bin $args\n"); close(FH); eval { $pid = open3(*FHO, *FHI, *FHI, $batfile); }; if ($@ =~ /^open2:/) { die("open2 failed: $@\n"); } # batfile is removed below, after process is terminated. } else { eval { $pid = open3(*FHO, *FHI, *FHI, "cd '$dir' && $bin $args"); }; if ($@ =~ /^open2:/) { die("open2 failed: $@\n"); } } print(FHO "xboard\nprotover 2\n"); print(">$bin: xboard\nprotover 2\n") if ($debug); while () { print("<$bin: $_") if ($debug); chomp; if (/^feature /) { if (s/.*myname=\"([^"]*)\".*/$1/) { $name = $_; last; } elsif (/done=1/) { last; } } elsif (/^Illegal move:.*protover/ || /Error.*protover/) { print("Warning: '$engine' does not support xboard" . " protocol version 2. Expect problems.\n"); last; } } print(FHO "quit\n"); print(">$bin: quit\n") if ($debug); while () { print("<$bin: $_") if ($debug); } close(FHI); close(FHO); kill($pid); waitpid($pid, 0); if ($state->{settings}->{winboard}) { unlink($batfile) or die("cannot unlink $batfile: $!\n"); } if (!defined($name)) { # For engines that don't tell their name with # 'feature myname=...', xboard just uses engine # binary name. $name = basename($bin); print("Warning: Could not find out real name of '$engine'," . " using '$name'\n"); } return $name; } sub format_time { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($_[0]); return sprintf("%02d:%02d", $hour, $min); } ############################################################################### # Module loaded successfully. 1; tourney_manager-20070820/Crosstable.pm0000640000175000017500000001267310662305151017142 0ustar holgerholger#!/usr/bin/perl # $Id: Crosstable.pm 342 2006-08-13 19:56:16Z holger $ # # Copyright (C) 2005 Holger Ruckdeschel # # 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 () { 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