#!/usr/bin/perl -w ## tsh - tournament shell ## Copyright (C) 1998-2003 by John J. Chew, III. # TODO default values for command parameters? # TODO division data complete message and trigger # TODO self-formatting PS output # TODO persistent tables through etc/tables # TODO 'webupdate' command # TODO bios.txt interface, photos on pairings # TODO virtual scorecards on web # TODO printing support # TODO finish documenting diagnostic messages # TODO finish switching ' " to ‘ etc. in documentation # TODO finish adding active/inactive support (P1324, KOTH, RoundRobin, DoClark) # TODO mark players active/inactive # TODO additional Gibsonization warnings with Fontes pairings # TODO Gibsonization on spread # TODO pair using firsts and seconds # TODO extend support for 9999 = no score yet ## Version history # # 2.910 BAT # config gibson (alpha testing, warnings only) # config max_rounds # timestamps on data entry # ROTO # reserved table code updated # first/second forecasts are purged before data is synched # config no_text_files # config html_directory # can now autopair using p1324 # fixed a bug that prevented calculating ratings of unrated players # 2.900 BAT # Some errors now have numbers. # 2.850 NSSC # Fixed a bug with RoundStanding introduced in 2.800 # 2.840 NSSC # Fixed a bug introduced in 2.800 (?) where missing pairs were duplicated # 2.830 NSSC # Slightly more readable and conformant HTML code # 2.820 NSSC # Corrected determination of firsts and seconds # 2.810 NSSC # WC and SC automatically measure max player name width # $config'assign_firsts # @config'external_path # %config'externals # $config'max_name_length # $config'name_format # MISSING and SP show "draws" if players must draw # 'off' extension field for '.t' files # partial support for active/inactive players # hooks for external commands # 2.800 NSSC # ES prompts with current scorecard before each command # added FIRST and SECOND subcommands to ES # MISSING and SP show p12 order if available # added "config track_firsts" configuration option to track 1sts & 2nds # Partially paired divisions can still be completed with autopair # Added tsh.config 'config' command # P1324 automatically assigns byes # KOTH automatically assigns byes # NS automatically assigns byes # BYE command replaced by PAIR and A # SP command doesn't list everyone if there aren't any pairings # PAIR command only reports changes # un-documented deprecated commands: SW PRESW PSW PPSW # added ES subcommand to A (goes into edit mode on last-entered score) # recorrected ES bug that sometimes discarded changes # corrected diagnostics emitted by UPR command # corrected documentation of P1324 command # InitFontes doesn't emit spurious errors with <8 players in division # several command argument parsers rewritten # RoundStandings reports results in partial current round correctly # division name doesn't have to be omitted in 1-division events # randomization of orderings made less so for stable table assignments # some spurious warnings deleted # support for new generalized .t files # HTML output from pairings command # 2.740 Newsday SSC # 'PairMany' command debugged # 2.730 Newsday SSC # 'ShowPair' command reports more problems # 2.720 Newsday SSC # 'PairMany' command # 2.710 Newsday SSC # Player names may include nonterminal numerals # 2.700 Newsday SSC # HTML output from standings command # 2.600 Oshawa 2005 # 'RoundRobin' command # 'RATings' command # 2.500 MWMST 2004 # trying to autopair a round twice doesn't crash tsh.pl # 2.400 Albany 2004 # fixed 'wc -f #' # autopair works at start of tournament # missing lists divisions in alphabetical order # 'm' synonym for 'missing' in score entry mode # 2.300 BAT 2004 # autopair # editscores emits updated scorecard # 2.210 Montreal QC 2004-03 club tournament # suppressed a spurious error message # 2.200 Cambridge ON 2004 # "cambridge pairings" # 2.100 CNSC 2003 # Addscore gives updated cumes as a check # 2.000 MWMST 2003 # 'missing' lists missing data in score entry mode # teed log files have '.doc' extension, no embedded spaces # 1.900 CWSCQT 2003 # added ShowPairings -p as kludge to work with make-rr.pl # 1.800 Albany 2003 # scorecard shows opp ratings # unpairround reports on problem players # table numbers can be arbitrary strings # entering a division name changes divisions in score entry mode # ShowWallChart -f r lists beginning with round r only # 1.700 Boston 2003 # EditScore added # NewSwiss code added, first manually paired player can be 0 for an unscored bye pairing # 1.600 Boston 2001 # InitFontes works for any number of players, not just 4n and 4n+2 # 1.500 Toronto 2001 # 1.400 Boston 2001 # 1.300 Danbury 2001 # 1.200 incorporates 2000 CNSC changes # 1.103 version used at 1999 Toronto SCRABBLE Tournament # 1.000 first release ## libraries use strict; unshift(@::INC, "$::ENV{'HOME'}/lib/perl") if defined $::ENV{'HOME'}; use Carp; use Fcntl ':flock'; use FileHandle; use Symbol; # require 'dawg.pl'; sub lock_failed ($) { my $reason = shift; print <<"EOF"; System call failed: $reason You should not run more than one copy of tsh using the same tsh.config configuration file at the same time. tsh uses a "lock file" called tsh.lock to keep track of when it is running. This copy of tsh was unable to get access to the lock file. The most likely reason for this is that tsh is already in use. EOF exit 1; } # Before we do anything else, check for another instance running BEGIN { my $error; $global'lockfh = new FileHandle 'tsh.lock', O_CREAT | O_RDWR or die "Can't open tsh.lock - check to make sure tsh isn't already running.\n"; flock($global'lockfh, LOCK_EX | LOCK_NB) or lock_failed 'flock'; seek($global'lockfh, 0, 0) or die "Can't rewind tsh.lock - something is seriously wrong.\n"; truncate($global'lockfh, 0) or die "Can't truncate tsh.lock - something is seriously wrong.\n"; print $global'lockfh "$$\n" or die "Can't update tsh.lock - something is seriously wrong.\n"; } END { flock($global'lockfh, LOCK_UN) or die "Can't unlock tsh.lock - something is seriously wrong.\n"; close($global'lockfh) or die "Can't close tsh.lock - something is seriously wrong.\n"; } ## global constants if ($^O eq 'MacOS') { $config'backup_directory = ':old:'; $config'html_directory = ':html'; } else { $config'backup_directory = './old/'; $config'html_directory = './html/'; } for my $dir ($config'backup_directory, $config'html_directory) { -e $dir || mkdir $dir || warn "Can't create $dir: $!\n"; } $config'max_name_length = 22; $config'name_format = '%-22s'; @config'external_path = qw(./bin ../bin); my $gkVersion = '2.910'; ## prototypes sub CheckAutoPair ($$); sub CheckGibson ($$$); sub CheckRoundHasResults ($$); sub ChooseBye ($$$); sub CloseLogs (\%); sub CmdAddScore ($$); sub CmdBye ($$); sub CmdCambridgePair ($$); sub CmdDeleteScore ($$); sub CmdEditScore ($$); sub CmdEval ($$); sub CmdExternal ($$); sub CmdHelp ($$); sub CmdInitFontes ($$); sub CmdKOTH ($$); sub CmdLook ($$); sub CmdMissing ($$); sub CmdNewSwiss ($$); sub CmdPair ($$); sub CmdPair1324 ($$); sub CmdPairMany ($$); sub CmdPartialSwiss ($$); sub CmdPreSwiss ($$); sub CmdPrePreSwiss ($$); sub CmdQuit ($$); sub CmdRandomScores ($$); sub CmdRatings ($$); sub CmdResultsByRound ($$); sub CmdRoto ($$); sub CmdRoundRobin ($$); sub CmdRoundStandings ($$); sub CmdShowWallChart ($$); sub CmdShowScoreCard ($$); sub CmdStandings ($$); sub CmdSwiss ($$); sub CmdUnpairRound ($$); sub CountByes ($); sub DefineExternal ($$$); sub DoClark (\%$); sub DoNewSwiss ($$$); sub DoSwiss ($$$$;$); sub FormatPairing ($$$;$); sub GetAllPlayers ($); sub GetRegularUnpaired ($$); sub GetUnpaired ($;$); sub GetUnpairedRound ($$); sub lint (); sub Main (); sub MakePlayerMap (); sub log_wc ($); sub OpenLogs ($$$); sub ParseArgs ($$); sub ParseDivisionName ($$); sub ParseInteger ($$$$$); sub ParseNothing ($$); sub ParseNRounds ($$); sub ParseRepeats ($$); sub ParseRoundNumber ($$); sub Prompt (); sub ReadConfig (); sub ReadDivision (\%); sub ReadDivisions (); sub Recursive_Swiss ($$); sub ReopenConsole (); sub ReportHeader ($$); sub ReportTrailer (); sub ResolvePairings ($$); sub SortByStanding ($@); sub SpliceInactive (\@;$); sub SynchDivision ($); sub SynchFirsts ($); sub TaggedName ($); sub UpdateDivisions ($); sub WriteDivision ($); sub WriteLog (\%$$); ## data structures # %gDivision maps division names to division data hashes # division data hashes contain the following: # # data array of player data, 1-based indexing # file filename of .t file # maxp highest round number that has pairings data (0-based) # maxs highest round number that has score data (0-based) # maxs_player the name of a player who has a score in round maxs # name division name # # player data (in $gDivision{$div}{data}) is a list mapping # 1-based player ID to a hash mapping: # # division pointer to division # etc supplementary player data (see below) # id player ID (1-based) # not sure this is still here # name player name # opp provisional opponent used within pairing routines # p1 number of firsts (starts) # p2 number of seconds (replies) # p3 number of indeterminates (starts/replies) # pairings list of opponent IDs by round (0-based by round, 1-based IDs) # ratedgames number of rated games # ratedwins number of rated wins # rating pre-tournament rating # repeats data structure tracking repeat pairings # rnd pseudorandom value used to break ties in standings # rspread cumulative spread by round # rwins cumulative wins by round # scores list of this player's scores by round (0-based) # spread cumulative spread # tspread temporary spread variable used by some routines # twins temporary wins variable used by some routines # wins number of wins # # supplementary player data # # off exists if player is inactive, single value indicates # type of byes (-50/0/50) to be assigned # p12 0-based list, 1 if went first, 2 if second, 0 if neither (bye), # 3 if must draw, 4 if indeterminate ## global variables %global'commands = ( 'a' => \&CmdAddScore, 'addscore' => \&CmdAddScore, 'bye' => \&CmdBye, 'camp' => \&CmdCambridgePair, 'cambridgepair' => \&CmdCambridgePair, 'deletescore' => \&CmdDeleteScore, 'delete' => \&CmdDeleteScore, 'done' => \&CmdQuit, 'es' => \&CmdEditScore, 'editscore' => \&CmdEditScore, 'exit' => \&CmdQuit, 'eval' => \&CmdEval, 'help' => \&CmdHelp, 'koth' => \&CmdKOTH, 'if' => \&CmdInitFontes, 'initfontes' => \&CmdInitFontes, 'l' => \&CmdLook, 'look' => \&CmdLook, 'missing' => \&CmdMissing, 'ns' => \&CmdNewSwiss, 'newswiss' => \&CmdNewSwiss, 'pair' => \&CmdPair, 'pairmany' => \&CmdPairMany, 'p1324' => \&CmdPair1324, 'pair1324' => \&CmdPair1324, 'partialswiss' => \&CmdPartialSwiss, 'pm' => \&CmdPairMany, 'ppsw' => \&CmdPrePreSwiss, 'prepreswiss' => \&CmdPrePreSwiss, 'presw' => \&CmdPreSwiss, 'preswiss' => \&CmdPreSwiss, 'psw' => \&CmdPartialSwiss, 'q' => \&CmdQuit, 'quit' => \&CmdQuit, 'rand' => \&CmdRandomScores, 'rat' => \&CmdRatings, 'rate' => \&CmdRatings, 'ratings' => \&CmdRatings, 'rbr' => \&CmdResultsByRound, 'roundrobin' => \&CmdRoundRobin, 'rr' => \&CmdRoundRobin, 'resultsbyround' => \&CmdResultsByRound, 'rs' => \&CmdRoundStandings, 'roto' => \&CmdRoto, 'roundstandings' => \&CmdRoundStandings, 'randomscores' => \&CmdRandomScores, 'sc' => \&CmdShowScoreCard, 'showscorecard' => \&CmdShowScoreCard, 'sp' => \&CmdShowPairings, 'showpair' => \&CmdShowPairings, 'showpairs' => \&CmdShowPairings, 'showpairings' => \&CmdShowPairings, 'showwallchart' => \&CmdShowWallChart, 'st' => \&CmdStandings, 'standings' => \&CmdStandings, 'sw' => \&CmdSwiss, 'swiss' => \&CmdSwiss, 'upr' => \&CmdUnpairRound, 'unpairround' => \&CmdUnpairRound, 'wc' => \&CmdShowWallChart, '?' => \&CmdHelp, ';' => \&CmdEval, ); %global'player_name_to_id = (); my %gDivision; my $gKeyRound = undef; my $gNDivisions; my (@gPrompt) = ('tsh> '); sub bystanding { # die ("Incomplete player $a->{'name'} ($a):\n ".join(', ',keys %$a)."\n") # unless defined $a->{'wins'} && defined $a->{'spread'} # && defined $a->{'rating'} && defined $a->{'rnd'}; confess unless defined $gKeyRound; local($^W) = 0; # TODO: should check previous rounds if no data yet for gKeyRoundw $gKeyRound >= 0 ? ((defined ($b->{'rwins'}[$gKeyRound]) ? $b->{'rwins'}[$gKeyRound] : $b->{'wins'})<=>(defined ($a->{'rwins'}[$gKeyRound]) ? $a->{'rwins'}[$gKeyRound] : $a->{'wins'}) || ((defined ($b->{'rspread'}[$gKeyRound]) ? $b->{'rspread'}[$gKeyRound] : $b->{'spread'})<=>(defined $a->{'rspread'}[$gKeyRound] ? $a->{'rspread'}[$gKeyRound] : $a->{'spread'})) || $b->{'rating'}<=>$a->{'rating'} || $b->{'rnd'}<=>$a->{'rnd'}) : ($b->{rating}<=>$a->{rating} || $b->{rnd} <=> $a->{rnd}) ; } sub by_current_standing { $b->{wins} <=> $a->{wins} || $b->{spread} <=> $a->{spread} || $b->{rating} <=> $a->{rating} || $b->{rnd} <=> $a->{rnd}; } sub by_initial_standing { $b->{rating} <=> $a->{rating} || $b->{rnd} <=> $a->{rnd}; } sub CheckAutoPair ($$) { my $dp = shift; my $round = shift; my $datap = $dp->{'data'}; my $round0 = $round - 1; # internally, rounds are zero-based # print "Checking AutoPair.\n"; # first look to see if there are any unpaired # TODO: check to see if this duplicates one of the sub Get...s my @unpaired; for my $p (@$datap[1..$#$datap]) { push(@unpaired, $p) if $p && !defined $p->{'pairings'}[$round0]; } return unless @unpaired; my $apdp = $config'autopair{uc $dp->{'name'}}[$round]; return unless $apdp; my (@apd) = @{$apdp}; my $sr = shift @apd; my $sr0 = $sr - 1; # check to see if all results are in for the source round if ($sr) { for my $p (@unpaired) { unless (defined $p->{'scores'}[$sr0]) { print "Can't yet autopair division $dp->{'name'} round $round:\n- missing a score for $p->{'name'} (and maybe others) in round $sr. (Message E001)\n"; return 0; } } } my $system = $apd[0]; # check to see we aren't going too far ahead if ($round0 != $dp->{'minp'} + 1) { # everyone has at least minp pairings my $mp1 = $dp->{'minp'} + 1 + 1; print "Can't autopair round $round; next round to pair is $mp1. (Message E002)\n"; return 0; } print "Auto-pairing. (Message I003)\n"; # TODO: dispatch this using the regular command dispatch system if ($system =~ /^(?:if|koth|ns|newswiss|p1324|pair1324|roundrobin|rr)$/i) { my $sub = $global'commands{lc $system}; unless ($sub) { print "Can't dispatch autopair for $system.\n"; return 0; } &$sub(\@apd, "@apd"); } else { die "Unknown pairing system '$system'"; } } sub CheckGibson ($$$) { my $dp = shift; my $sr0 = shift; my $round0 = shift; unless ($config'max_rounds) { print "Can't do Gibson check without 'config max_rounds = ?'.\n"; return -1; } my (@sorted) = SortByStanding $sr0, @{GetUnpairedRound $dp, $round0}; # TODO: handle triple Gibsons # Note that this does not catch all Gibson situations. In particular, # if you are using Fontes pairings, players may complain that a Gibson # situation in Round N has arisen as a result of a Round N-1 game, # when Round N pairings have been computed based on Round N-2 standings my $rounds_left = $config'max_rounds - ($sr0+1); my (@spread, @wins); for my $i (0..2) { my $pp = $sorted[$i]; $spread[$i] = defined $pp->{'rspread'}[$sr0] ? $pp->{'rspread'}[$sr0] : $pp->{'spread'}; $wins[$i] = defined $pp->{'rwins'}[$sr0] ? $pp->{'rwins'}[$sr0] : $pp->{'wins'}; } # Note that we do not yet support Gibsoning on spread. if ($wins[0] - $wins[1] > $rounds_left) { printf "%s (%d %+d) needs to be Gibsonized with respect to %s (%d %+d).\n", (TaggedName $sorted[0]), $wins[0], $spread[0], (TaggedName $sorted[1]), $wins[1], $spread[1], ; return 1; } elsif ($wins[1] - $wins[2] > $rounds_left) { printf "%s (%d %+d) and %s (%d %+d) need to be Gibsonized with respect to %s (%d %+d).\n", (TaggedName $sorted[0]), $wins[0], $spread[0], (TaggedName $sorted[1]), $wins[1], $spread[1], (TaggedName $sorted[2]), $wins[2], $spread[2], ; return 2; } return 0; } sub CheckRoundHasResults ($$) { my $sr0 = shift; my $dp = shift; if ($sr0 > $dp->{'maxs'}) { my $sr = $sr0+1; print "You don't have round $sr results yet.\n"; return 0; } return 1; } # ChooseBye $dp, $round0, $sr0 # # Assign a bye in division $dp, round $round0+1, based on round $sr0+1 standings sub ChooseBye ($$$) { my $dp = shift; my $round0 = shift; my $sr0 = shift; my $datap = $dp->{'data'}; # look for lowest ranked player with minimum byes my $minbyes = CountByes $dp; my $p = (SortByStanding $sr0, GetAllPlayers $dp)[-1] or die "Tried to choose a bye but couldn't find any players?!"; $p->{'pairings'}[$round0] = 0; # warn "Not sure assigning bye score is a good idea.\n"; # $p->{'scores'}[$round0] = 50; print "Gave a bye to $p->{'name'}.\n"; # print join(',', %$p), "\n"; # We have to call SynchDivision to update maxp SynchDivision $dp; # This is always called before a pairing system call, so we don't # have to WriteDivision } sub CloseLogs (\%) { my $fhsp = shift; WriteLog %$fhsp, '', ''; { my ($text, $html) = ReportTrailer; WriteLog %$fhsp, $text, $html; } close($fhsp->{'text'}) unless $config'no_text_files; close($fhsp->{'html'}); close($fhsp->{'subhtml'}); } sub CmdAddScore ($$) { my($argvp, $args) = @_; my ($round, $dp) = ParseArgs $argvp, [qw(round division)]; return 0 unless defined $dp; if ($round == 0) { print "Can't add scores for round 0.\n"; return 0; } my $datap = $dp->{'data'}; my %dirty = (); my $lastpn1 = 1; while (1) { print "[$dp->{'name'}${round}]:pn1 ps1 pn2 ps2? "; local($_) = scalar(); s/\s+$//; if (defined $gDivision{lc $_}) { $dp = $gDivision{lc $_}; $datap = $dp->{'data'}; last unless defined $datap; next; } elsif (/^(?:m|missing)$/i) { CmdMissing ['AddScore', $round], ''; next; } elsif (/^(?:es|editscore)$/i) { UpdateDivisions \%dirty; CmdEditScore ['AddScore', $dp->{'name'}, $lastpn1, $round], ''; next; } last if /[^-\d\s]/; my (@words) = split; if (@words == 2) { my ($pn1, $ps1) = @words; if ($pn1 < 1 || $pn1 > $#$datap) { print "There is no player #$pn1.\n"; next; } my $pp1 = $datap->[$pn1]; my $opp1 = $pp1->{'pairings'}[$round-1]; unless ((defined $opp1) && $opp1 == 0) { print "$pp1->{'name'} did not have a bye in round $round.\n"; next; } if ($pp1->{'scores'}[$round-1] && $pp1->{'scores'}[$round-1] != 9999) { print "$pp1->{'name'} already has a score ($pp1->{'scores'}[$round-1]).\n"; next; } { my $wlt = (($ps1 <=> 0) + 1) / 2; printf "#%d %s %+d (%.1f %+d).\n", $pp1->{id}, $pp1->{name}, $ps1, $pp1->{wins} + $wlt, $pp1->{spread} + $ps1, ; } $lastpn1 = $pn1; $dirty{$dp->{name}}++; $pp1->{'etc'}{'time'} = [time]; $pp1->{'scores'}[$round-1] = $ps1; next; } last unless @words == 4; my ($pn1, $ps1, $pn2, $ps2) = @words; if ($pn1 < 1 || $pn1 > $#$datap) { print "There is no player #$pn1.\n"; next; } if ($pn2 < 1 || $pn2 > $#$datap) { print "There is no player #$pn2.\n"; next; } my $pp1 = $datap->[$pn1]; my $pp2 = $datap->[$pn2]; if ($pp1->{'pairings'}[$round-1] ne $pn2) { print "$pp1->{'name'} and $pp2->{'name'} did not play each other in round $round.\n"; next; } if ($pp1->{'scores'}[$round-1] && $pp1->{'scores'}[$round-1] != 9999) { print "$pp1->{'name'} already has a score.\n"; next; } if ($pp2->{'scores'}[$round-1] && $pp2->{'scores'}[$round-1] != 9999) { print "$pp2->{'name'} already has a score.\n"; next; } if ($config'track_firsts) { my $p12p = $pp1->{'etc'}{'p12'}; my $old = $p12p->[$round-1]; if ($old && $old == 2) { print "$pp1->{'name'} was supposed to go second. (Message E004)\n"; } $p12p->[$round-1] = 1; $p12p = $pp2->{'etc'}{'p12'}; $old = $p12p->[$round-1]; if ($old && $old == 1) { print "$pp2->{'name'} was supposed to go first. (Message E005)\n"; } $p12p->[$round-1] = 2; } { my $spread = $ps1 - $ps2; my $wlt = (($spread <=> 0) + 1) / 2; printf "#%d %s %d (%.1f %+d) - #%d %s %d (%.1f %+d).\n", $pp1->{id}, $pp1->{name}, $ps1, $pp1->{wins} + $wlt, $pp1->{spread} + $spread, $pp2->{id}, $pp2->{name}, $ps2, $pp2->{wins} + 1 - $wlt, $pp2->{spread} - $spread, ; } $lastpn1 = $pn1; $dirty{$dp->{name}}++; $pp1->{'etc'}{'time'} = $pp2->{'etc'}{'time'} = [time]; $pp1->{'scores'}[$round-1] = $ps1; $pp2->{'scores'}[$round-1] = $ps2; } UpdateDivisions \%dirty; 0; } # TODO: fix pairings for opponents of bye player sub CmdBye ($$) { my ($argvp, $args) = @_; my $usage = "Usage: BYE p1 score round [division]\n"; my ($p1, $score, $round, $dp) = ParseArgs $argvp, [qw(player-number score round division)]; return 0 unless defined $dp; my $datap = $dp->{'data'}; print "The BYE command has replaced by PAIR and A.\n"; $round--; $^W = 0; my $p1pair = $datap->[$p1]{'pairings'}; printf "%s used to be paired to %s\n", (TaggedName $datap->[$p1]), (TaggedName $datap->[$p1pair->[$round]]) if $p1pair->[$round]; $^W = 1; $p1pair->[$round] = 0; $datap->[$p1]{'scores'}[$round] = $score; SynchDivision $dp; WriteDivision $dp; 0; } # Semi-fixed seven-round pairings used in Cambridge ON sub CmdCambridgePair ($$) { my ($argvp, $args) = @_; my ($dp) = ParseArgs $argvp, [qw(division)]; return 0 unless defined $dp; if ($dp->{'maxp'} != -1) { print "Division already has pairings.\n"; return 0; } print "Calculating Cambridge pairings for Division $dp->{'name'}.\n"; my $datap = $dp->{'data'}; if ($#$datap == 6) { for my $i (6,5,4,3,2) { DoClark %$dp, $i; } } elsif ($#$datap == 8) { for my $i (8,7,6,5,4,3,2) { DoClark %$dp, $i; } } elsif ($#$datap == 10) { for my $i (10,8,7,5,4,2) { DoClark %$dp, $i; } } elsif ($#$datap == 12) { for my $i (12,10,8,6,4,2) { DoClark %$dp, $i; } } elsif ($#$datap == 14) { for my $i (14,12,10,8,4,2) { DoClark %$dp, $i; } } elsif ($#$datap == 16) { for my $i (16,14,11,8,5,2) { DoClark %$dp, $i; } } elsif ($#$datap == 18) { for my $i (18,15,12,9,6,3) { DoClark %$dp, $i; } } elsif ($#$datap == 20) { for my $i (20,17,14,11,8,5){ DoClark %$dp, $i; } } elsif ($#$datap == 22) { for my $i (22,18,14,10,6,2){ DoClark %$dp, $i; } } # my generalisation elsif ($#$datap % 2 == 0 && $#$datap > 22) { my $delta = int($#$datap / 6); my $opp1 = $#$datap; for my $i (1..6) { DoClark %$dp, $opp1; $opp1 -= $delta; } } else { print "Don't know how to do Cambridge pairings for this division size.\n"; } SynchDivision $dp; WriteDivision $dp; 0; } # TODO: should permit deleting byes sub CmdDeleteScore ($$) { my($argvp, $args) = @_; my ($pn1, $s1, $pn2, $s2, $round, $dp) = ParseArgs $argvp, [qw(player-number score player-number score round division)]; return 0 unless defined $dp; my $pp1 = $dp->{'data'}[$pn1]; my $pp2 = $dp->{'data'}[$pn2]; if ($pp1->{'pairings'}[$round-1] ne $pn2) { print "$pp1->{'name'} and $pp2->{'name'} did not play each other in round $round.\n"; return 0; } if ($pp1->{'scores'}[$round-1] != $s1) { print "$pp1->{'name'}'s score was $pp1->{'scores'}[$round-1], not $s1.\n"; return 0; } if ($pp2->{'scores'}[$round-1] != $s2) { print "$pp2->{'name'}'s score was $pp2->{'scores'}[$round-1], not $s2.\n"; return 0; } if ($#{$pp1->{'scores'}} == $round-1) { pop @{$pp1->{'scores'}}; } else { print "Warning: that wasn't $pp1->{'name'}'s most recent score.\n"; $pp1->{'scores'}[$round-1] = 0; } if ($#{$pp2->{'scores'}} == $round-1) { pop @{$pp2->{'scores'}}; } else { print "Warning: that wasn't $pp2->{'name'}'s most recent score.\n"; $pp2->{'scores'}[$round-1] = 0; } print "Deleted scores.\n"; SynchDivision $dp; WriteDivision $dp; 0; } sub CmdEditScore ($$) { my ($argvp, $args) = @_; my ($dp, $id, $round) = ParseArgs $argvp, [qw(division player-number round)]; return 0 unless defined $round; my $datap = $dp->{'data'}; my $p = $datap->[$id]; unless (defined $p) { print "No such player: $id.\n"; return 0; } unless (defined $p->{'scores'}[$round-1]) { print "Player doesn't yet have scores in round $round.\n"; return 0; } my %dirty; while (1) { CmdShowScoreCard ['sc', $dp->{'name'}, $id], "sc $dp->{'name'} $id"; my $oppid = $p->{'pairings'}[$round-1]; if (!defined $oppid) { print "$p->{'name'} has no opponent in round $round.\n"; last; } my $opp = $datap->[$oppid]; my $ms = $p->{'scores'}[$round-1] || 0; my $os = $oppid && $opp->{'scores'}[$round-1] || 0; print "Enter: D div, R round, P player, FIRST, SECOND or corrected score(s).\n"; if ($oppid) { my $vs = FormatPairing $dp, $round-1, $id, 'half'; print "$p->{'name'} ($dp->{'name'}$id) R$round [$ms $os $vs] "; } else { print "$p->{'name'} ($dp->{'name'}$id) R$round [bye scoring $ms] "; } local($_) = scalar(); s/^\s+//; s/\s+$//; if (/^d\s+(\S+)$/) { my $newdp = $gDivision{lc $1}; if (defined $newdp) { $dp = $newdp; $datap = $dp->{'data'}; $p = $datap->[$id]; $p = $datap->[$id = 1] unless defined $p; unless (defined $p->{'scores'}[$round-1]) { print "No corresponding scores in division $dp->{'name'}\n"; return 0; } } else { print "No such division.\n"; } } elsif (/^r\s+([1-9]\d*)$/) { $round = $1; } elsif (/^p\s+([1-9]\d*)$/) { my $newid = $1; my $newp = $datap->[$newid]; if (!defined $newp) { print "No such player.\n"; } elsif (!defined $newp->{'scores'}[$round-1]) { print "Player has no scores in round $round.\n"; } else { $p = $newp; $id = $newid; } } elsif (/^(first|second)$/i) { unless ($oppid) { print "Player had a bye, went neither first nor second.\n"; next; } for my $etcp ($p->{'etc'}, $opp->{'etc'}) { if ($#{$etcp->{'p12'}} < $round-1) { print "Please record earlier firsts and seconds first.\n"; next; } } if (/^first$/i) { $p->{'etc'}{'p12'}[$round-1] = 1; $opp->{'etc'}{'p12'}[$round-1] = 2; } else { $p->{'etc'}{'p12'}[$round-1] = 2; $opp->{'etc'}{'p12'}[$round-1] = 1; } $dirty{$dp->{name}}++; } elsif ($oppid && /^(-?\d+)\s+(-?\d+)$/) { $p->{'scores'}[$round-1] = $1; $opp->{'scores'}[$round-1] = $2 if $oppid; $dirty{$dp->{name}}++; } elsif ((!$oppid) && /^(-?\d+)$/) { $p->{'scores'}[$round-1] = $1; $dirty{$dp->{name}}++; } else { last; } } UpdateDivisions \%dirty; 0; } sub CmdEval ($$) { my($argvp, $args) = @_; $args =~ s/^(;|eval)\s//i; print join("\n", eval $args); print "\n\$\@: '$@'\n"; 0; } sub CmdExternal ($$) { my($argvp, $args) = @_; my $arg0 = $argvp->[0]; my $cmdp = $config'externals{$arg0}; if (defined $cmdp) { my $args = $cmdp->{'args'}; my (@argv) = ParseArgs $argvp, $args; pop @argv; # there's a '1' at the end, from ParseNothing # TODO: everyone else should use the new global'parse_error too return 0 if $global'parse_error; for my $arg (@argv) { $arg = $arg->{file} if ref($arg) eq 'TSH::Division'; } system $cmdp->{file}, @argv; } } sub CmdHelp ($$) { print <<'EOS'; Commands Available: Addscore r d add new scores BYE p1 s1 r d register a bye CAMbridgePair d set up seven-round pairings for Cambridge ON DELETEscore p1 s1 p2 s2 r d delete scores EditScore d p1 r begin editing scores EVAL code evaluate arbitary perl code HELP print this message InitFontes nr d fixed-pair division for nr rounds to boot Fontes pairings KOTH rpt sr d add king-of-the-hill pairings Look word look up 'word' in dictionary MISSING r list players for whom score is missing in round r NewSwiss rpt sr d New Swiss-pair division using round sr results PAIR p1 p2 r d manually pair p1 and p2 together Pair1324 rpt sr d pair 1-3, 2-4, 5-7, 6-8 etc. PairMany r d make several pairings changes at once Quit quit RANDomscores d give each player a random score (for testing) RATings d show division standings with ratings estimates ResultsByRound r1-r2 d rank players based only on rounds r1-r2 ROTO r report roto standings (if any) as of round r RoundRobin d add a full round robin to a division RoundStandings r d show standings after given round showScoreCard d p1 show correct scorecard for checking ShowPair r d show pairings STandings d show current standings showWallChart d show correct wall chart for checking UnPairRound r d delete pairings Notes: - You can type the whole command name or just the part in caps - 'd' stands for a division name, 'r' for a round number - 'sr' stands for a 'source round' on which pairings are to be based - 'p1' and 'p2' are player numbers, 's1' and 's2' are scores - 'rpt' specifies how many times two players can repeat pairings EOS 0; } sub CmdInitFontes ($$) { my ($argvp, $args) = @_; my ($nrounds, $dp) = ParseArgs $argvp, [qw(nrounds division)]; return 0 unless defined $dp; if ($dp->{'maxp'} != -1) { print "Can't do pre-Fontes pairings, division already has some pairings.\n"; return 0; } print "Calculating initial pre-Fontes pairings for Division $dp->{'name'}.\n"; # calculate pairings if ($nrounds == 3) { my @rrs = (); my $sortedp = GetUnpaired $dp; SpliceInactive @$sortedp, 3; @$sortedp = sort by_initial_standing @$sortedp; my $np = $#$sortedp + 1; if ($np < 4) { print "$np is not enough players: must have at least four.\n"; return 0; } if ($np % 4) { # players don't divide exactly into quads my @oddballs; my @formats; if ($np % 4 == 1) { # number of players is 1 (mod 4) # pick five players one from each quintile # TODO: think about avoiding giving byes to top seeds for (my $section=4; $section>=0; $section--) { push(@oddballs, splice(@$sortedp, int($np*($section+rand(1))/5),1)); } @formats = ([3,4,undef,0,1],[1,0,3,2,undef],[undef,2,1,4,3]); } elsif ($np % 4 == 2) { # number of players is 2 (mod 4) # pick six players one from each sextile for (my $section=5; $section>=0; $section--) { push(@oddballs, splice(@$sortedp, int($np*($section+rand(1))/6),1)); } @formats = ([5,2,1,4,3,0],[3,4,5,0,1,2],[1,0,3,2,5,4]); } elsif ($np % 4 == 3) { # number of players is 3 (mod 4) # TODO: think about avoiding giving byes to top seeds # pick three players one from each third for (my $section=2; $section>=0; $section--) { push(@oddballs, splice(@$sortedp, int($np*($section+rand(1))/3),1)); } @formats = ([2,undef,0],[1,0,undef],[undef,2,1]); } # print "[", join(',', map($_->{'id'}, @oddballs)), "]\n"; for my $format (@formats) { for my $i (0..$#$format) { my $opp = $format->[$i]; $opp = defined $opp ? $oddballs[$opp]{'id'} : 0; push(@{$oddballs[$i]{'pairings'}}, $opp); } } } # at this point, number of remaining players in @$sortedp is divisible by four. if ($#$sortedp % 4 != 3) { die "Assertion failed."; } # repeatedly pick one random player from each quartile for (my $n4 = int(@$sortedp/4); $n4 > 0; $n4--) { my @rr = (); # print "sortedp:[", join(',', map($_->{'id'}, @$sortedp)), "]\n"; for (my $quartile = 3; $quartile >= 0; $quartile--) { push(@rr, splice(@$sortedp, $quartile*$n4 + rand($n4), 1)); } push(@rrs, \@rr); } # assign pairings for my $rr (@rrs) { # print "[", join(',', map($_->{'id'}, @$rr)), "]\n"; if ($#$rr == 3) { # RR4 gets paired 14.23, 13.24, 12.34 for my $format ([3,2,1,0],[2,3,0,1],[1,0,3,2]) { for my $i (0..3) { push(@{$rr->[$i]{'pairings'}}, $rr->[$format->[$i]]{'id'}); } } } } SynchDivision($dp); WriteDivision($dp); } else { print "The only implemented number of rounds so far is 3, not $nrounds.\n"; } return 0; } sub CmdKOTH ($$) { my($argvp, $args) = @_; my ($repeats, $sr, $dp) = ParseArgs $argvp, [qw(repeats based-on-round division)]; return 0 unless defined $dp; my $sr0 = $sr-1; CheckRoundHasResults $sr0, $dp or return 0; print "Calculating King-Of-The-Hill pairings for Division $dp->{'name'} based on round $sr.\n"; my $sortedp = (GetRegularUnpaired $dp, $sr0); unless (@$sortedp) { print "No players can be paired.\n"; return 0; } die "Assertion failed" unless @$sortedp % 2 == 0; @$sortedp = SortByStanding $sr0, @$sortedp; { my $n = $#$sortedp; for my $i (0..$n) { my $p = $sortedp->[$i]; my @pref = (); for my $j (1..$n) { { my $k = $i+$j; my $opp = $sortedp->[$k]; push (@pref, $opp) if $k <= $n && $p->{'repeats'}[$opp->{'id'}] <= $repeats; } { my $k = $i-$j; my $opp = $sortedp->[$k]; push (@pref, $opp) if $k >=0 && $p->{'repeats'}[$opp->{'id'}] <= $repeats; } } # for $j $p->{'pref'} = \@pref; } # for $i } # my $n if (ResolvePairings $dp, $sortedp) { SynchDivision $dp; WriteDivision $dp; } 0; } sub CmdLook ($$) { my ($argvp) = @_; shift @$argvp; print "The word lookup feature is not enabled in this copy.\n"; my $ok = 1; # for my $word (@$argvp) { # if (&dawg'check(*TWL98, lc $word)) { print "'$word' is acceptable.\n"; } # else { print "'$word' is not acceptable.\n"; $ok = 0; } # } # printf "The play is%s acceptable.\n", $ok ? '' : ' not'; 0; } # TODO: should report table number (this involves orthogonalizing a function that maps (d,p,r) to (b,t) sub CmdMissing ($$) { my($argvp, $args) = @_; my ($round) = ParseArgs $argvp, [qw(round)]; return 0 unless defined $round; my $round0 = $round-1; for my $dp (sort { $a->{'name'} cmp $b->{'name'} } values %gDivision) { my @done = (); my $datap = $dp->{'data'}; for my $i (1..$#$datap) { next if $done[$i]; if (!defined $datap->[$i]{'scores'}[$round0]) { my $opp = $datap->[$i]{'pairings'}[$round0]; if ($opp) { unless (defined $datap->[$opp]{'scores'}[$round0]) { print FormatPairing $dp, $round0, $i; } $done[$opp] = 1; } else { print TaggedName $datap->[$i]; } print "\n"; } } } 0; } sub CmdNewSwiss ($$) { my($argvp, $args) = @_; my ($repeats, $sr, $dp) = ParseArgs $argvp, [qw(repeats based-on-round division)]; return 0 unless defined $dp; my $sr0 = $sr-1; CheckRoundHasResults $sr0, $dp or return 0; print "Calculating Swiss pairings for Division $dp->{'name'} based on round $sr, $repeats repeats allowed.\n"; DoNewSwiss $dp, $repeats, $sr0; 0; } # TODO: fix pairings for opponents of repaired players sub CmdPair ($$) { my ($argvp, $args) = @_; my ($p1, $p2, $round, $dp) = ParseArgs $argvp, [qw(player-number-or-0 player-number round division)]; return 0 unless defined $dp; my $datap = $dp->{'data'}; for my $p ($p1,$p2) { unless ($p <= $#$datap) { print "No such player: $p\n"; return 0; } } $round--; my $p1pair = $datap->[$p1]{'pairings'} if $p1; my $p2pair = $datap->[$p2]{'pairings'} if $p2; printf "%s used to be paired to %s\n", (TaggedName $datap->[$p1]), (TaggedName $datap->[$p1pair->[$round]]) if $p1 && defined $p1pair->[$round] && $p2 != $p1pair->[$round]; printf "%s used to be paired to %s\n", (TaggedName $datap->[$p2]), (TaggedName $datap->[$p2pair->[$round]]) if defined $p2pair->[$round] && $p1 != $p2pair->[$round]; $p1pair->[$round] = $p2 if $p1; $p2pair->[$round] = $p1 if $p2; SynchDivision $dp; WriteDivision $dp; 0; } sub CmdPair1324 ($$) { my($argvp, $args) = @_; my ($repeats, $sr, $dp) = ParseArgs $argvp, [qw(repeats based-on-round division)]; return 0 unless defined $dp; my $sr0 = $sr - 1; CheckRoundHasResults $sr0, $dp or return 0; print "Calculating 1324 pairings for Division $dp->{'name'} based on round $sr.\n"; my $sortedp = (GetRegularUnpaired $dp, $sr0); unless (@$sortedp) { print "No players can be paired.\n"; return 0; } die "Assertion failed" unless @$sortedp % 2 == 0; @$sortedp = SortByStanding $sr0, @$sortedp; { my $n = $#$sortedp; for my $i (0..$n) { my $p = $sortedp->[$i]; my @pref = (); for my $j (2,1,3..$n) { { my $k = $i+$j; my $opp = $sortedp->[$k]; push (@pref, $opp) if $k <= $n && $p->{'repeats'}[$opp->{'id'}] <= $repeats; } { my $k = $i-$j; my $opp = $sortedp->[$k]; push (@pref, $opp) if $k >=0 && $p->{'repeats'}[$opp->{'id'}] <= $repeats; } } # for $j $p->{'pref'} = \@pref; } # for $i } # my $n if (ResolvePairings $dp, $sortedp) { SynchDivision $dp; WriteDivision $dp; } 0; } # TODO: fix pairings for opponents of repaired players sub CmdPairMany ($$) { my ($argvp, $args) = @_; my ($round, $dp) = ParseArgs $argvp, [qw(round division)]; return 0 unless defined $dp; my $datap = $dp->{'data'}; my %dirty = (); while (1) { print "[$dp->{'name'}${round}]:pn1 pn2? "; local($_) = scalar(); s/\s+$//; if (defined $gDivision{lc $_}) { $dp = $gDivision{lc $_}; $datap = $dp->{'data'}; last unless defined $datap; next; } elsif (/^\s*r\s*(\d+)\s*$/i) { $round = $1; next; } last if /[^-\d\s]/; my (@pns) = split; last if @pns != 2; my $errors = 0; for my $i (0..1) { my $pn = $pns[$i]; my $oppn = $pns[1-$i]; if ($pn > $#$datap) { print "There is no player #$pn.\n"; $errors++; next; } next unless $pn; my $pp = $datap->[$pn]; my $oldoppn = $pp->{'pairings'}[$round-1]; if (defined $oldoppn) { next if $oldoppn == $oppn; print "#$pn $pp->{'name'} used to be paired to #$oldoppn $datap->[$oldoppn]{'name'}\n" } $dirty{$dp->{name}}++; $pp->{'pairings'}[$round-1] = $oppn; } { printf "#%d %s (%.1f %+d) - #%d %s (%.1f %+d).\n", $datap->[$pns[0]]{id}, $datap->[$pns[0]]{name}, $datap->[$pns[0]]{wins}, $datap->[$pns[0]]{spread}, $datap->[$pns[1]]{id}, $datap->[$pns[1]]{name}, $datap->[$pns[1]]{wins}, $datap->[$pns[1]]{spread}, ; } } UpdateDivisions \%dirty; 0; } sub CmdPartialSwiss ($$) { my($argvp, $args) = @_; print "WARNING: deprecated\n"; shift @$argvp; my $usage = "Usage: Swiss repeats p1 p2 division-name\n"; my $repeats = shift @$argvp; unless (defined $repeats && $repeats =~ /^\d+$/) { print $usage; return 0; } my $p1 = shift @$argvp; unless (defined $p1 && $p1 =~ /^\d+$/ && $p1 >= 1) { print $usage; return 0; } my $p2 = shift @$argvp; unless (defined $p2 && $p2 =~ /^\d+$/ && $p2 >= $p1) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; my $datap = $dp->{'data'}; unless ($p2 <= $#$datap) { print $usage; return 0; } DoSwiss $dp, $repeats, $p1, $p2; 0; } # Swiss based on round n-3, not n-1 sub CmdPrePreSwiss ($$) { my($argvp, $args) = @_; print "WARNING: deprecated\n"; shift @$argvp; my $usage = "Usage: PrePreSWiss repeats division-name\n"; my $repeats = shift @$argvp; unless (defined $repeats && $repeats =~ /^\d+$/) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; DoSwiss $dp, $repeats, 1, $#{$dp->{'data'}}, 2; 0; } # Swiss based on round n-2, not n-1 sub CmdPreSwiss ($$) { my($argvp, $args) = @_; print "WARNING: deprecated\n"; shift @$argvp; my $usage = "Usage: PRESWiss repeats division-name\n"; my $repeats = shift @$argvp; unless (defined $repeats && $repeats =~ /^\d+$/) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; DoSwiss $dp, $repeats, 1, $#{$dp->{'data'}}, 1; 0; } sub CmdQuit ($$) { print "tsh quits.\n"; 1; } sub CmdRandomScores ($$) { my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: RandomScores division-name...\n"; do { { my $dp = (ParseDivisionName $argvp, $usage); next unless defined $dp; print "Adding random scores to division $dp->{'name'}.\n"; for my $p (@{$dp->{'data'}}) { if (defined $p) { push(@{$p->{'scores'}}, int(200+$p->{'rating'}/20+rand(100))); printf "%s: @{$p->{'scores'}}\n", (TaggedName $p); } } SynchDivision $dp; WriteDivision $dp; } } while ($#$argvp>=0); 0; } sub CmdRatings ($$) { my($argvp, $args) = @_; my ($dp) = ParseArgs $argvp, [qw(division)]; return 0 unless defined $dp; my $datap = $dp->{'data'}; # prepare CalculateRatings arguments - ugh my (@ps); for my $id1 (1..$#$datap) { my $id0 = $id1-1; my $pdp = $datap->[$id1]; $ps[$id0] = { 'ewins' => $pdp->{'ratedwins'}, 'name' => $pdp->{'name'}, 'oldr' => $pdp->{'rating'}, 'opps' => [ map { $_-1 } @{$pdp->{'pairings'}} ], 'rgames' => $pdp->{'ratedgames'}, 'scores' => $pdp->{'scores'}, 'totalg' => 100, 'id' => $pdp->{'id'}, }; } # TODO: support split ratings, specified on tsh.config for my $lib (qw(ratings ratings2)) { eval 'require "$lib.pl"'; if ($@) { print "I can't find the $lib.pl library, so I can't do ratings.\n"; return 0; } } &ratings2'CalculateRatings(\@ps, 'oldr', 1, 'newr', 10000, 'ewins'); my $ms1 = $dp->{'maxs'}+1; my $fhsp = OpenLogs $dp, 'ratings', $ms1; WriteLog %$fhsp, "Rank Won-Lost Spread OldR NewR Delta Player\n\n", <<'EOF'; Rank Won-Lost Spread Old
Rating New
Rating Rating
Change Name EOF my $lastw = -1; my $lasts = 0; my $rank = 0; my $i = 0; for my $p (sort by_current_standing @$datap[1..$#$datap]) { next if defined $p->{'etc'}{'off'}; my $wins = $p->{'wins'}; my $spread = $p->{'spread'}; $i++; if ($wins != $lastw || $spread != $lasts) { $lastw = $wins; $lasts = $spread; $rank = $i; } my $newr = $ps[$p->{'id'}-1]{'newr'}; my (@fields) = ($rank, $wins, $#{$p->{'scores'}}+1-$wins, $spread, $p->{'rating'}, $newr, $newr-$p->{'rating'}, (TaggedName $p)); WriteLog %$fhsp, sprintf("%4d %4.1f-%4.1f %+5d %4d %4d %+5d %s\n", @fields), sprintf(<<'EOF', @fields); %d %4.1f-%4.1f %+d %d %d %+d %s EOF } CloseLogs %$fhsp; 0; } # TODO: convert to using ParseArgs sub CmdResultsByRound ($$) { my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: ResultsByRound r1[-r2] div\n"; my $rounds = shift @$argvp; unless (defined $rounds) { print $usage; return 0; } my @rounds = split(/-/, $rounds, 2); $rounds[1] = $rounds[0] if $#rounds == 0; my $dp = (ParseDivisionName $argvp, $usage); unless (defined $dp && $#$argvp == -1) { print $usage; return 0; } if ($rounds[0] == $rounds[1]) { print "Standings Based only on Results of Round $rounds[0]: Division $dp->{name}\n"; } else { print "Standings Based only on Results of Rounds $rounds[0]-$rounds[1]: Division $dp->{name}\n"; } print "\n"; print "Wins Spread Rtng Player\n\n"; $rounds[0]--; $rounds[1]--; my $datap = $dp->{data}; for my $p (@$datap[1..$#$datap]) { $p->{twins} = $p->{tspread} = 0; my $pairingsp = $p->{pairings}; for my $r ($rounds[0]..$rounds[1]) { my $opp = $pairingsp->[$r]; my $oppscore = $opp ? $datap->[$opp]{'scores'}[$r] : 0; my $thisSpread = $p->{'scores'}[$r] - $oppscore; $p->{tspread} += $thisSpread; $p->{twins} += (1 + ($thisSpread <=> 0))/2; } } for my $p (sort { $b->{twins}<=>$a->{twins} || $b->{tspread}<=>$a->{tspread} } @$datap[1..$#$datap]) { printf "%4.1d %+5d %4d %s\n", $p->{twins}, $p->{tspread}, $p->{rating}, (TaggedName $p) unless $p->{name} =~ /^bye /; } 0; } sub CmdRoundRobin ($$) { my ($argvp, $args) = @_; my ($dp) = ParseArgs $argvp, [qw(division)]; return 0 unless defined $dp; my $datap = $dp->{'data'}; my $nplayers = $#$datap; # check that division is not partially paired { my $unpaired = GetUnpaired $dp, 'can be empty'; my $nunpaired = $#$unpaired+1; if ($nunpaired > 0 && $nunpaired != $nplayers) { print "Can't add a round robin to a division whose last round is partially paired.\n"; print "$nunpaired/$nplayers unpaired.\n"; return 0; } } # SpliceInactive @$unpaired, $nplayers-1; print "Calculating round robin pairings for Division $dp->{'name'}.\n"; # add pairings information one round at a time my $schedule_size = $nplayers + ($nplayers % 2); for (my $oppi = $schedule_size; $oppi > 1; $oppi--) { DoClark %$dp, $oppi; } SynchDivision $dp; WriteDivision $dp; 0; } sub CmdRoto ($$) { my($argvp, $args) = @_; my ($round) = ParseArgs $argvp, [qw(based-on-round)]; return 0 unless defined $round; my $round0 = $round - 1; unless ($config'rotofile) { print "No roto file defined.\n"; return 0; } MakePlayerMap; my $fh = gensym; unless (open($fh, "<$config'rotofile")) { print "Can't load $config'rotofile.\n"; return 0; } local($/) = "\n\n"; my @teams; while (<$fh>) { s/^\n+//; my (@lines) = split(/\n/); my %players; my (%data); for my $line (@lines) { next unless $line =~ /\S/; my ($command, $args) = split(/\s+/, $line, 2); if ($command eq 'owner') { if ($data{'owner'}) { print "Team $. has two owners ($data{'owner'} and $args)\n"; return 0; } $data{'owner'} = $args; } elsif ($command eq 'player') { my $did = $global'player_name_to_id{$args}; if (!defined $did) { print "Team $. has an unknown player: $args\n"; return 0; } if ($players{$did}++) { print "Team $. has a duplicate player: $args\n"; return 0; } my ($divname, $id) = $did =~ /^(.)(.*)/; my $p = $gDivision{lc $divname}{'data'}[$id]; unless ($p) { print "Can't find player $did.\n"; return 0; } push(@{$data{'players'}}, $p); $data{'wins'} += $p->{'twins'} = defined $p->{'rwins'}[$round0] ? $p->{'rwins'}[$round0] : $p->{'wins'} ; $data{'spread'} += $p->{'tspread'} = defined $p->{'rspread'}[$round0] ? $p->{'rspread'}[$round0] : $p->{'spread'} ; $p->{'twins'} =~ s/\.5/+/; } else { print "Can't make sense of: $line\n"; return 0; } } push(@teams, \%data ) if %data; } my $fhsp = OpenLogs undef, 'roto', $round; WriteLog %$fhsp, sprintf("%3s " . '%5s ' . "%-30s %s\n", ' W ', ' Sprd', 'Owner', (' ' x 19) . 'Team'), "Wins" . 'Spread' . "OwnerTeam\n"; for my $team (sort { $b->{'wins'} <=> $a->{'wins'} || $b->{'spread'} <=> $a->{'spread'} || $a->{'owner'} cmp $b->{'owner'} } @teams) { my $teamwins = $team->{'wins'}; $teamwins =~ s/\.5/+/ or $teamwins .= ' '; WriteLog %$fhsp, sprintf("%3s %+5d %-27.27s%6s%6s%6s%6s%6s%6s\n", $teamwins, $team->{'spread'}, $team->{'owner'}, map { sprintf("%3s%1s%03d", $_->{'twins'}, uc($_->{'division'}{'name'}), $_->{'id'}, ) } @{$team->{'players'}}), sprintf("%s" . '%+d' . "%s" . ("%s" x 6) . "\n", $teamwins, $team->{'spread'}, $team->{'owner'}, map { # $_->{'twins'} . ' ' . (TaggedName $_) my $s = TaggedName $_; if ($s =~ /(.*) \((.*)\)/) { $s = sprintf("%s
%s %s %+d\n", $1, $2, $_->{'twins'}, $_->{'tspread'}); } $s; } @{$team->{'players'}}), ; } CloseLogs %$fhsp; 0; } sub CmdRoundStandings ($$) { my($argvp, $args) = @_; my ($round, $dp) = ParseArgs $argvp, [qw(based-on-round division)]; return 0 unless defined $dp; my $round0 = $round - 1; CheckRoundHasResults $round0, $dp or return 0; print "Round $round Standings: Division $dp->{'name'}.\n"; print "\n"; print "Rank Won-Lost Spread Rtng Player\n\n"; my $datap = $dp->{'data'}; my $lastw = -1; my $lasts = 0; my $rank = 0; my $i = 0; my (@sorted) = SortByStanding $round0, GetAllPlayers $dp; for my $p (@sorted) { my $wins; my $losses; my $spread; next if defined $p->{'etc'}{'off'}; if ($round0 < 0) { $wins = $losses = $spread = 0; } elsif (defined ($wins = $p->{'rwins'}[$round0])) { $losses = $round0 + 1 - $wins; $spread = $p->{'rspread'}[$round0]; } else { $wins = $p->{'wins'}; $losses = $#{$p->{'rwins'}} + 1 - $wins; $spread = $p->{'spread'}; } $i++; if ($wins != $lastw || $spread != $lasts) { $lastw = $wins; $lasts = $spread; $rank = $i; } printf "%4d %4.1f-%4.1f %+5d %4d %s\n", $rank, $wins, $losses, $spread, $p->{'rating'}, (TaggedName $p) unless $p->{name} =~ /^bye /; } 0; } # TODO: fold opt_p into ParseArgs sub CmdShowPairings ($$) { my($argvp, $args) = @_; my $opt_p = 0; if (@$argvp && $argvp->[0] eq '-p') { shift @$argvp; $opt_p = 1; } my ($round, $dp) = ParseArgs $argvp, [qw(round division)]; return 0 unless defined $dp; my $datap = $dp->{'data'}; my $round0 = $round-1; CheckAutoPair $dp, $round; if ($round0 > $dp->{'maxp'} ) { print "No pairings yet for division $dp->{'name'} round $round.\n"; return 0; } if ($opt_p) { print '['; print join(',', map { $_->{'pairings'}[$round0]-1 } @$datap[1..$#$datap]); print "]\n"; return 0; } my $fhsp = OpenLogs $dp, 'pairings', $round; # sample config line: perl $config'tables{'A'} = [1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]; # (for 20 2-board tables) my $tables = $config'tables{$dp->{'name'}}; # sample config line: perl $config'reserved{'P'}[13] = 4; # (to permanently station disabled player #13 in division P at board 4) my $reserved = $config'reserved{$dp->{'name'}}; if (defined $tables) { WriteLog %$fhsp, 'Table ', 'Table'; my $shortage = length(sprintf($config'table_format, ''))-3; die "table format must be at least three characters wide\n" if $shortage < 0; WriteLog %$fhsp, (' ' x $shortage), ''; } WriteLog %$fhsp, "Board Players\n", <<'EOF'; Board Who Plays Whom EOF { my %done; my %reserved; my @unreserved; my @errors; my @sorted; { my $sr0 = $round - 2; $sr0 = 0 if $sr0 < 0; $sr0 = $dp->{maxs} if $sr0 > $dp->{maxs}; @sorted = SortByStanding $sr0, GetAllPlayers $dp; } for my $p (@sorted) { next if defined $p->{'etc'}{'off'}; my $opp = $p->{'pairings'}[$round0]; if (!defined $opp) { WriteLog %$fhsp, '', ''; WriteLog %$fhsp, sprintf(" $config'table_format ", ''), ' ' if defined $tables; WriteLog %$fhsp, sprintf(" %s: UNPAIRED.\n", (TaggedName $p)), 'UNPAIRED' . (TaggedName $p) . ''; WriteLog %$fhsp, '', ''; } elsif ($opp == 0) { WriteLog %$fhsp, '', ''; WriteLog %$fhsp, sprintf(" $config'table_format ", ''), ' ' if defined $tables; WriteLog %$fhsp, sprintf(" %s: BYE.\n", (TaggedName $p)), 'BYE' . (TaggedName $p) . ''; WriteLog %$fhsp, '', ''; $done{$p->{id}} = 1; } elsif (!$done{$opp}) { if ($done{$p->{id}}++) { push(@errors, "Can't list #$p->{id} $p->{name} as paired to #$opp $datap->[$opp]{name} because #$p->{id} already has an opponent.\n"); next; } else { $done{$opp}++; } if (defined $reserved && defined $reserved->[$p->{'id'}]) { $reserved{$reserved->[$p->{'id'}]} = [$p, $datap->[$opp]]; } elsif (defined $reserved && defined $reserved->[$opp]) { $reserved{$reserved->[$opp]} = [$datap->[$opp], $p]; } else { push (@unreserved, [$p, $datap->[$opp]]); } } elsif (!$done{$p->{id}}) { push(@errors, "Can't list #$p->{id} $p->{name} as paired to #$opp $datap->[$opp]{name} because #$opp already has an opponent.\n"); } } # for $p { my $board = 0; for my $b (@unreserved) { my ($p, $opp) = @$b; # skip until we find a vacant board while (defined $reserved{$board+1}) { $board++; } WriteLog %$fhsp, '', ''; WriteLog %$fhsp, sprintf(" $config'table_format ", $tables->[$board]), "$tables->[$board]" if defined $tables; my $vs = FormatPairing $dp, $round0, $p->{id}; unless ($vs) { WriteLog %$fhsp, "Lost track of $p->{name}", "Lost track of $p->{name}"; next; } my $vshtml = $vs; $vshtml =~ s/\*(?:starts|draws)\*/$&<\/span>/; WriteLog %$fhsp, sprintf(" %3d %s.\n", $board+1, $vs), '' . ($board+1) . "$vshtml\n" ; $board++; } for my $b (sort { $a <=> $b } keys %reserved) { my ($p, $opp) = @{$reserved{$b}}; my $board = $reserved->[$p->{'id'}] - 1; die "Oops!" unless defined $board; WriteLog %$fhsp, '', ''; WriteLog %$fhsp, sprintf(" $config'table_format ", $tables->[$board]), "$tables->[$board]" if defined $tables; my $vs = FormatPairing $dp, $round0, $p->{id}; my $vshtml = $vs; $vshtml =~ s/\*(?:starts|draws)\*/$&<\/span>/; WriteLog %$fhsp, sprintf(" %3d %s.\n", $board+1, $vs), '' . ($board+1) . "$vshtml"; ; } } CloseLogs %$fhsp; print @errors; } 0; } sub CmdShowScoreCard ($$) { my($argvp, $args) = @_; my ($dp, $pn) = ParseArgs $argvp, [qw(division player-number)]; return 0 unless defined $pn; my $datap = $dp->{'data'}; my $p = $datap->[$pn]; unless (defined $p) { print "No such player: $pn.\n"; return 0; } # print header print "Player Scorecard: ", (TaggedName $p), " ($p->{'rating'})"; print " INACTIVE" if defined $p->{'etc'}{'off'}; print "\n"; if ($p->{'etc'}{'time'}) { my $age = int((time - $p->{'etc'}{'time'}[0])/60); if ($age < 200) { my $s = $age == 1 ? '' : 's'; print "- Last score was entered $age minute$s ago.\n"; } } print "Rnd "; print "1/2 " if $config'track_firsts; printf "Opp Rtng $config'name_format Won-Lost For Agn Sprd CumSp\n", 'Opponent name'; # print one line for each paired or played round my $pairingsp = $p->{'pairings'}; my $scoresp = $p->{'scores'}; my $max = $#$pairingsp > $#$scoresp ? $#$pairingsp : $#$scoresp; my $cume = 0; my $games = 0; my $wins = 0; for my $i (0..$max) { my $oid = $pairingsp->[$i]; my $opp = $datap->[$oid]; my $score = $scoresp->[$i]; printf "%3d ", $i+1; if ($config'track_firsts) { my $p12 = $p->{'etc'}{'p12'}[$i]; print !defined $p12 ? ' ' : ' ' . ('- ',"$p12 ","$p12 ",'? ', '??')[$p12] . ' '; } if ($oid) { printf "%3d %4d $config'name_format", $opp->{'id'}, $opp->{'rating'}, $opp->{'name'}; } else { printf "%3s %4s $config'name_format", '', 'bye', ''; } if (defined $score) { $games++; my $oscore = $oid ? $opp->{'scores'}[$i] : 0; my $spread = $score - $oscore; $cume += $spread; $wins += (1+($spread <=> 0))/2; printf " %4.1f-%4.1f %3d %3d %+4d %+5d", $wins, $games-$wins, $score, $oscore, $spread, $cume; } print "\n"; } # for $i 0; } # TODO: parse -f # and division... using ParseArgs sub CmdShowWallChart ($$) { my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: showWallChart [-f #] [division...]\n"; my $from = 1; if (@$argvp && $argvp->[0] eq '-f') { shift @$argvp; $from = shift @$argvp; } $from--; do { { my $dp = (ParseDivisionName $argvp, $usage); next unless defined $dp; open(WC, ">$dp->{'name'}-WC.doc") or die "Can't create WC log: $!\n"; log_wc "Wall Chart: Division $dp->{'name'}.\n\n"; log_wc sprintf("$config'name_format\n", 'Player'); # TODO: show full and correct header my $datap = $dp->{'data'}; for my $p (@$datap[1..$#$datap]) { next unless defined $p; my $line1 = sprintf("$config'name_format ", $p->{'name'}); my $line2 = sprintf("$config'name_format ", ''); my $spread = 0; my $wins = 0; my $cols = 0; for my $j (0..$#{$p->{'scores'}}) { my $opp = $p->{'pairings'}[$j]; my $oppScore = $opp ? $datap->[$opp]{'scores'}[$j] : 0; my $thisSpread = $p->{'scores'}[$j] - $oppScore; $spread += $thisSpread; $wins += (1 + ($thisSpread <=> 0))/2; if ($j >= $from) { $line1 .= sprintf("%5.1f ", $wins); $line2 .= sprintf("%+5d ", $spread); } unless ((1+$cols-$from) % 12) { if ($j >= $from) { log_wc "$line1\n$line2\n"; $line1 = $line2 = sprintf("$config'name_format ", ''); } } $cols++; } # for $j if ($line1 =~ /\S/) { log_wc "$line1\n$line2\n"; } } # for my $p close(WC); } } while ($#$argvp >= 0); } sub CmdStandings ($$) { my($argvp, $args) = @_; my ($dp) = ParseArgs $argvp, [qw(division)]; return 0 unless defined $dp; my $datap = $dp->{'data'}; my $round = $dp->{'maxs'} + 1; my $fhsp = OpenLogs $dp, 'standings', $round; WriteLog %$fhsp, "Rank Won-Lost Spread Rtng Name\n\n", <<'EOF'; Rank Won-Lost Spread Rating Name EOF my $lastw = -1; my $lasts = 0; my $rank = 0; my $i = 0; for my $p (sort by_current_standing @$datap[1..$#$datap]) { next if defined $p->{'etc'}{'off'}; my $wins = $p->{'wins'}; my $spread = $p->{'spread'}; $i++; if ($wins != $lastw || $spread != $lasts) { $lastw = $wins; $lasts = $spread; $rank = $i; } unless ($p->{name} =~ /^bye /) { my (@fields) = ($rank, $wins, $#{$p->{'scores'}}+1-$wins, $spread, $p->{'rating'}, (TaggedName $p)); WriteLog %$fhsp, sprintf("%4d %4.1f-%4.1f %+5d %4d %s\n", @fields), sprintf(<<'EOF', @fields); %d %4.1f-%4.1f %+d %d %s EOF } } CloseLogs %$fhsp; 0; } sub CmdSwiss ($$) { my($argvp, $args) = @_; print "WARNING: deprecated\n"; shift @$argvp; my $usage = "Usage: Swiss repeats sr division-name\n"; my $repeats = shift @$argvp; unless (defined $repeats && $repeats =~ /^\d+$/) { print "1. $usage"; return 0; } my $sr = shift @$argvp; unless ($sr =~ /^\d+$/) { print "2. $usage"; return 0; } my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; my $datap = $dp->{'data'}; my $pre = $dp->{maxp} - ($sr+1); DoSwiss $dp, $repeats, 1, $#{$dp->{'data'}}, $pre; 0; } # TODO: should delete byes sub CmdUnpairRound ($$) { my($argvp, $args) = @_; my ($round, $dp) = ParseArgs $argvp, [qw(round division)]; return 0 unless defined $dp; my $round0 = $round - 1; if ($dp->{'maxp'} == -1) { print "There aren't any pairings in that division yet.\n"; return 0; } if ($round0 != $dp->{'maxp'}) { printf "The only round you can unpair is the last paired one: %d\n", $dp->{'maxp'}+1; return 0; } if ($round0 <= $dp->{'maxs'}) { print "You can't unpair round $round, because it already has scores.\n"; print "($dp->{'maxs_player'} is one player who has a score.)\n"; print "Try using the DeleteScore command or editing the .t file.\n"; return 0; } print "Deleting pairings for Division $dp->{'name'}, round $round.\n"; my $datap = $dp->{'data'}; for my $i (1..$#$datap) { my $p = $datap->[$i]; my $pairingsp = $p->{'pairings'}; if ($#$pairingsp == $round0) { my $opp = pop @$pairingsp; print "... $p->{id} unpaired from $opp.\n"; } } SynchDivision $dp; WriteDivision $dp; print "Done.\n"; 0; } # Count how many byes each player in a division has, save as $p->{'byes'}. # Return the smallest number of byes. sub CountByes ($) { my $dp = shift; my $datap = $dp->{'data'}; my $minbyes = 9999999; for my $p (@$datap[1..$#$datap]) { next unless defined $p; my $byes = 0; for my $opp (@{$p->{'pairings'}}) { if ((defined $opp) && $opp == 0) { $byes++; } } $minbyes = $byes if $byes < $minbyes; $p->{'byes'} = $byes; } return $minbyes; } sub DefineExternal ($$$) { my $name = lc shift; my $script = shift; my $template = shift; $config'externals{$name} = { 'args' => $template, 'file' => "$global'path/$script", }; $global'commands{$name} = \&CmdExternal; print " $name"; return 1; } # Add one round of Clark pairings to a division. Clark pairings are # described in the NSA Directors' Manual, and are a way of generating # not especially high-quality round robin pairings. This subroutine # takes two arguments: a division reference and the opponent number for # player #1. Enumerating all the possible opponents for player #1 will # result in a complete round robin schedule. # TODO: improve the quality of the pairings, by rearranging the order # in which players sit in their Clark circle so that when #1 plays #2, # KOTH pairings result. sub DoClark (\%$) { my $dp = shift; my $opp1 = shift; my $datap = $dp->{'data'}; my $round = $dp->{'maxp'} + 1; my $n = $#$datap; my $odd = $n % 2; if ($odd) { # if division is odd, pair as per n+1 and fix up as we go $n++; $opp1 = $n if $opp1 == 0; # allow user to specify } $datap->[1]{'pairings'}[$round] = ($odd && $opp1 == $n) ? 0 : $opp1; $datap->[$opp1]{'pairings'}[$round] = 1 unless $odd && $opp1 == $n; for my $id (2..$n - $odd) { next if $id == $opp1; my $oppid = (2*$opp1 - $id + $n - 1) % ($n - 1); $oppid += $n-1 if $oppid <= 1; # print "id=$id oppid=$oppid opp1=$opp1 n=$n\n"; die "Assertion failed (id=$id opp1=$opp1 n=$n oppid=$oppid)" unless $oppid > 1 && $id != $oppid && $oppid <= $n; $oppid = 0 if $odd && $oppid == $n; $datap->[$id]{'pairings'}[$round] = $oppid; } SynchDivision $dp; } sub DoNewSwiss ($$$) { my ($dp, $repeats, $sr0) = @_; my $datap = $dp->{'data'}; my $theKeyRound = $sr0; my $tobepaired = (GetRegularUnpaired $dp, $sr0); unless (@$tobepaired) { print "No players can be paired.\n"; return 0; } die "Assertion failed" unless @$tobepaired % 2 == 0; my (@ranked) = SortByStanding $theKeyRound, @$tobepaired; # for my $p (@ranked) { print "$p->{'id'} $p->{'name'}\n"; } # divide into win groups my @win_groups = (); { my $wins = -1; for my $p (@ranked) { my $this_wins = $p->{'rwins'}[$theKeyRound]; $this_wins = 0 unless defined $this_wins; if ($this_wins == $wins) { push(@{$win_groups[-1]}, $p); } else { push(@win_groups, [$p]); $wins = $this_wins; } } # for my $p } # divide into win groups # count repeats - this should be a sub, as it's duplicated in ResolvePairings for my $p (@ranked) { my (@repeats) = (0) x ($#$datap + 1); for my $j (0..$#$datap) { $repeats[$j] =0; } for my $j (@{$p->{'pairings'}}) { $repeats[$j]++; } $p->{'repeats'} = \@repeats; # print "$p->{'name'} [$p->{'id'}] repeats: ", join(' ', @repeats), "\n"; } my @pair_list = Recursive_Swiss \@win_groups, $repeats; unless (@pair_list) { print "Swiss pairings failed, try increasing repeats or using manual pairings.\n"; return; } # store pairings { while (@pair_list) { my $p1 = shift @pair_list; my $p2 = shift @pair_list; push(@{$p1->{'pairings'}}, $p2->{'id'}); push(@{$p2->{'pairings'}}, $p1->{'id'}); } } # store pairings print "Done.\n"; SynchDivision $dp; WriteDivision $dp; } sub DoSwiss ($$$$;$) { my($dp, $repeats, $p1, $p2, $pre) = @_; $pre = 0 unless defined $pre; my $datap = $dp->{'data'}; my $theKeyRound = $dp->{maxp} - $pre; print("Calculating Swiss pairings for division $dp->{'name'}," ." $repeats repeats, players $p1-$p2.\n"); printf "... using round %d results.\n", $theKeyRound + 1; my $tobepaired = (GetUnpaired $dp); print "tobepaired size: $#$tobepaired.\n"; @$tobepaired = grep($_->{'id'} >= $p1 && $_->{'id'} <= $p2, @$tobepaired); if ($#$tobepaired % 2 == 0) { print "Can't Swiss pair an odd number of players.\n"; return 0; } print "tobepaired size: $#$tobepaired.\n"; my ($maxpair, @offsets, $p, @pairing, $wins); # generate list of player offsets (see below) @offsets = (0); for my $j (1..$#$tobepaired-1) { push(@offsets, $j, -$j); } # sort by wins and spread, arrange tied players randomly my (@ranked) = SortByStanding $theKeyRound, @$tobepaired; # for my $p (@ranked) { print "$p->{'id'} $p->{'name'}\n"; } # calculate pairings for each win group # print "# calculating pairing preference lists\n"; { my $n; for (my $i=0; $i<=$#ranked; $i += $n+$n) { my $message; # this group starts at position $i, how far does it go? $wins = $ranked[$i]{'rwins'}[$theKeyRound]; print "$ranked[$i]{'name'} has $wins wins in round $theKeyRound+1.\n"; if ((!$config'noboys) && $i == 0 && defined $wins) { # Dave Boys' idea: first group includes anyone with at least 2/3 leader's wins # my $quota = 2*$wins/3; # 1.500: changed to 2/3 of total wins my $quota = 2*($theKeyRound+1)/3; $message = "# at least $quota wins: "; $n = 1; while ($n%2==1 || ( $i+$n <= $#ranked && $ranked[$i+$n]{'rwins'}[$theKeyRound] >= $quota )) { $n++; } } else { $message = "# $wins wins: "; $n = 1; # start n at 1 and increment until while ($i+$n<=$#ranked && ( # we hit the end or... ((!defined $wins) && (!defined $ranked[$i+$n]{'rwins'}[$theKeyRound])) # number of wins becomes defined or... || $ranked[$i+$n]{'rwins'}[$theKeyRound] == $wins || $n%2)) # number of wins changes and n is even { $n++; } } $wins = 0 unless defined $wins; print "$message$i to $i+$n\n"; $n >>= 1; # $j indexes how far we are along in the "semigroup" for (my $j=0; $j<$n; $j++) { # list pairings preferences for player $j in upper semigroup # TODO: should prefer players in current group first { # scoping only my $me = $ranked[$i+$j]; my @pairing = (); # print "pairings for $me->{'name'} ($me->{'id'})\n"; for my $k (@offsets) { next if $k == -$n; # identity check my $opprank = $i+$j+$k+$n; next if $opprank < 0 || $opprank > $#ranked; # range check my $oppid = $ranked[$opprank]->{'id'}; # print " $ranked[$opprank]->{'name'} ($ranked[$opprank]->{'id'})\n"; next if $me->{'repeats'}[$oppid] > $repeats; # re-pairing check # print " (ok)\n"; push(@pairing, $ranked[$opprank]); } die "$me->{'name'} can't be paired!\n" unless $#pairing >= 0; $me->{'pref'} = \@pairing; # print "$me->{'name'} ($me->{'id'}): @pairing\n"; } # scoping { # scoping only # list pairings preferences for player $j in lower semigroup my $me = $ranked[$i+$j+$n]; my @pairing = (); # print "pairings for $me->{'name'}\n"; for my $k (@offsets) { next if $k == $n; # identity check my $opprank = $i+$j+$k; next if $opprank < 0 || $opprank > $#ranked; # range check my $oppid = $ranked[$opprank]->{'id'}; # print " $ranked[$opprank]->{'name'}\n"; next if $me->{'repeats'}[$oppid] > $repeats; # re-pairing check # print " (ok)\n"; push(@pairing, $ranked[$opprank]); } # print "$me->{'name'} ($me->{'id'}): @pairing\n"; die "$me->{'name'} can't be paired!\n" unless $#pairing >= 0; $me->{'pref'} = \@pairing; } # scoping } # for $j } } # for $i # special check for bye player byes: for my $i (0..$#ranked) { my($p) = $ranked[$i]; if ($p->{'name'} =~ /^bye /i) { for my $j (0..$#ranked) { if ($i == $j) { my($k, @newpref, $repeatp); $repeatp = $p->{'repeats'}; for ($k=$#ranked; $k>=0; $k--) { # bye pairs against bottom of field next if $k == $i; # bye doesn't pair against bye my $oppid = $ranked[$k]{'id'}; next if $repeatp->[$oppid] > 0; # bye never repeats push(@newpref, $ranked[$k]); } $ranked[$j]{'pref'} = \@newpref; } } unshift(@ranked, splice(@ranked, $i, 1)); last byes; } # if player is bye } # for $i (bye player) if (ResolvePairings $dp, \@ranked) { SynchDivision $dp; WriteDivision $dp; } } # Return a formatted string describing one pairing sub FormatPairing ($$$;$) { my $dp = shift; my $round0 = shift; my $pn1 = shift; my $style = shift || 'normal'; my $datap = $dp->{'data'}; my $pn2 = $datap->[$pn1]{'pairings'}[$round0] or return ''; my $p = $datap->[$pn1]; my $opp = $datap->[$pn2]; my $p121 = $p->{'etc'}{'p12'}[$round0] || 0; my $p122 = $opp->{'etc'}{'p12'}[$round0] || 0; if ($p121 == 2 && $p122 == 1) { if ($style eq 'half') { return 'second vs. ' . (TaggedName $opp); } ($p, $opp) = ($opp, $p); } elsif ($p121 == 3 && $p122 == 3) { if ($style eq 'half') { return 'draws vs. ' . (TaggedName $opp); } else { return (TaggedName $p) . ' *draws* vs. ' . (TaggedName $opp); } } elsif (!($p121 == 1 && $p122 == 2)) { if ($style eq 'half') { return 'vs. ' . (TaggedName $opp); } else { return (TaggedName $p) . ' vs. ' . (TaggedName $opp); } } if ($style eq 'half') { return 'first vs. ' . (TaggedName $opp); } else { return (TaggedName $p) . ' *starts* vs. ' . (TaggedName $opp); } } # Return a vector of all players in a division sub GetAllPlayers ($) { my $dp = shift; my $datap = $dp->{'data'}; return @$datap[1..$#$datap]; } # Return a vector of players that need to be paired in the given division. # Make adjustments if necessary, such as assigning a bye to make the # vector even, or (still to do) Gibsonizing a clincher. Inactive players # will be assigned their bye score. sub GetRegularUnpaired ($$) { my $dp = shift; my $sr0 = shift; # used in assigning byes my $datap = $dp->{'data'}; my $round0 = $dp->{'maxp'}; $round0 = 0 if $round0 < 0; my $psp = GetUnpaired $dp, 'empty is ok'; # if last round paired is complete if (!@$psp) { # use next round $round0++; $psp = [@$datap]; shift @$psp; SpliceInactive @$psp; } if ($config'gibson) { my $gibson_count = CheckGibson $dp, $sr0, $round0; if ($gibson_count < 0) { return []; } # error elsif ($gibson_count == 1) { # assign bye if possible $psp = [SortByStanding $sr0, @$psp]; my $p = shift @$psp; if (@$psp % 2) { print "Please manually pair $p->{'name'}.\n"; return []; } else { $p->{'pairings'}[$round0] = 0; print "Assigned a bye to $p->{'name'}.\n"; } } elsif ($gibson_count == 2) { # pair with each other $psp = [SortByStanding $sr0, @$psp]; my $p1 = shift @$psp; my $p2 = shift @$psp; $p1->{'pairings'}[$round0] = $p2->{'id'}; $p2->{'pairings'}[$round0] = $p1->{'id'}; print "Paired $p1->{'name'} and $p2->{'name'}.\n"; } } # check to see if we need a bye if (@$psp % 2) { my $minbyes = CountByes $dp; my $p = (SortByStanding $sr0, grep { $_->{'byes'} == $minbyes } @$psp)[-1] or die "Tried to choose a bye but couldn't find any players?!"; # only assign the by pairing, don't register the +50, as some routines # (and operators) may get confused by having early score data present $p->{'pairings'}[$round0] = 0; my $found = 0; # TODO: test to see how slow this is, fix if necessary for my $i (0..$#$psp) { if ($psp->[$i] eq $p) { $found = 1; splice(@$psp, $i, 1); last; } } print "Gave a bye to $p->{'name'}.\n"; # We have to call SynchDivision to update maxp SynchDivision $dp; # and we do have to call WriteDivision because later parsing might fail WriteDivision $dp; } return $psp; } # return a vector of players that need to be paired sub GetUnpaired ($;$) { my $dp = shift; my $emptyok = shift; my $datap = $dp->{'data'}; my @unpaired = @{GetUnpairedRound $dp, $dp->{'maxp'}}; # if we didn't find any in the last round, return complete vector if ($#unpaired < 0 && !$emptyok) { @unpaired = @$datap; shift @unpaired; SpliceInactive @unpaired; } return \@unpaired; } # sub GetUnpaired # return a vector of players that need to be paired sub GetUnpairedRound ($$) { my $dp = shift; my $round0 = shift; my $datap = $dp->{'data'}; my @unpaired = (); # first check for an already partially paired round for my $p (@$datap[1..$#$datap]) { next unless $p && !defined $p->{'pairings'}[$round0]; push(@unpaired, $p); } # for $p SpliceInactive @unpaired; return \@unpaired; } # sub GetUnpairedRound sub lint () { %config'externals = (); $config'gibson = undef; $config'noboys = 0; $config'reserved{''} = ''; $config'tables{''} = ''; lint; } sub log_wc ($) { print WC $_[0]; print $_[0]; } sub Main () { srand; # { # my $dawg = 'gloria:john:19990925-toronto:twl98.dawg'; # $dawg = "$ENV{'HOME'}/scrabble/ospd/words.dawg" # unless -f $dawg; # &dawg'open(*TWL98, $dawg) || warn "Can't open TWL98 file.\n";; # } mkdir $config'backup_directory, 0700 unless -d $config'backup_directory; ReopenConsole if $^O eq 'MacOS'; print "\nWelcome to tsh version $gkVersion.\n"; ReadConfig; ReadDivisions; Prompt; while (<>) { next unless /\S/; my(@argv) = split; my $sub = $global'commands{lc $argv[0]}; if (defined $sub) { last if &$sub(\@argv, $_); } else { print "Enter 'help' for help.\n"; } } continue { Prompt; } } BEGIN { %global'ParseArgsDispatch = ( 'based-on-round' => \&ParseBasedOnRoundNumber, 'division' => \&ParseDivisionName, 'nothing' => \&ParseNothing, 'nrounds' => \&ParseNRounds, 'player-number-or-0' => \&ParsePlayerNumberOrZero, 'player-number' => \&ParsePlayerNumber, 'repeats' => \&ParseRepeats, 'round' => \&ParseRoundNumber, 'score' => \&ParseScore, ); } sub MakePlayerMap () { return if %global'player_name_to_id; for my $dp (values %gDivision) { my $dname = $dp->{'name'}; my $datap = $dp->{'data'}; for my $id (1..$#$datap) { $global'player_name_to_id{$datap->[$id]{'name'}} = "$dname$id"; } } } sub OpenLogs ($$$) { my $dp = shift; my $type = lc shift; my $round = lc shift; my $Type = ucfirst $type; my ($fh, $fn, %fhs); my $round000 = sprintf("%03d", $round); unless ($config'no_text_files) { $fh = gensym; $fn = $dp ? "$dp->{'name'}-$type.doc" : "$type.doc"; open($fh, ">$fn") or warn "Can't create $fn: $!\n"; $fhs{'text'} = $fh; print $fh "testing\n"; } $fh = gensym; $fn = $dp ? "$dp->{'name'}-$type.html" : "$type.html"; open($fh, ">$fn") or warn "Can't create $fn: $!\n"; $fhs{'html'} = $fh; $fh = gensym; $fn = $dp ? "${config::html_directory}$dp->{'name'}-$type-$round000.html" : "${config::html_directory}$type-$round000.html"; open($fh, ">$fn") or warn "Can't create $fn: $!\n"; $fhs{'subhtml'} = $fh; { my $title = "Round $round $Type"; if ($gNDivisions > 1) { $title = $dp ? "Division $dp->{'name'} $title": $title; }; my ($text, $html) = ReportHeader $title, $type; WriteLog %fhs, $text, $html; } WriteLog %fhs, '', <<"EOF"; EOF return \%fhs; } sub ParseArgs ($$) { my $argvp = shift; my $typesp = shift; my $arg0 = shift @$argvp; my $usage = "Usage: $arg0 "; if ($gNDivisions == 1) { $usage .= join(' ', grep { $_ ne 'division' } @$typesp); } else { $usage .= join(' ', @$typesp); } $usage .= "\n"; my @values; $global'parse_error = ''; for my $type (@$typesp, 'nothing') { my $sub = $global'ParseArgsDispatch{$type}; die "Unknown argument type ($type)." unless $sub; my $value = &$sub($argvp, $usage); if (defined $value) { push(@values, $value); } else { $global'parse_error ||= 'error'; return (); } } return @values; } sub ParseBasedOnRoundNumber ($$) { my ($argvp, $usage) = @_; return ParseInteger $argvp, $usage, 'round number', 0, ($config'max_rounds || 10000); } sub ParseDivisionName ($$) { my $argvp = shift; my $usage = shift; if ($gNDivisions == 1) { if (defined $gDivision{lc $argvp->[0]}) { shift @$argvp; } return (%gDivision)[1]; } elsif ($#$argvp < 0) { print "You must specify a division name with this command.\n"; print $usage; return undef; } else { my $dn = lc shift @$argvp; my $dp = $gDivision{$dn}; if (!defined $dp) { print "No such division: \U$dn\E.\n"; print $usage; return undef; } else { return $dp; } } } sub ParseInteger ($$$$$) { my $argvp = shift; my $usage = shift; my $typename = shift; my $min = shift; my $max = shift; if ($#$argvp < 0) { print "Please specify a $typename.\n"; print $usage; return undef; } my $n = shift @$argvp; if ($n !~ /^-?\d+$/) { print "This doesn't look like a $typename to me: $n.\n"; print $usage; return undef; } if ($n < $min) { print "$n is too small to be a $typename.\n"; print $usage; return undef; } if ($n > $max) { print "$n is too big to be a $typename.\n"; print $usage; return undef; } return $n; } sub ParseNothing ($$) { my $argvp = shift; my $usage = shift; if (@$argvp) { print "I don't understand this bit at the end: @$argvp\n"; print $usage; return undef; } return 1; } sub ParseNRounds ($$) { my ($argvp, $usage) = @_; return ParseInteger $argvp, $usage, 'number of rounds', 1, ($config'max_rounds || 10000); } sub ParsePlayerNumber ($$) { my ($argvp, $usage) = @_; return ParseInteger $argvp, $usage, 'player number', 1, 100000; } sub ParsePlayerNumberOrZero ($$) { my ($argvp, $usage) = @_; return ParseInteger $argvp, $usage, 'player number', 0, 100000; } sub ParseRepeats ($$) { my ($argvp, $usage) = @_; return ParseInteger $argvp, $usage, 'number of repeat pairings per player', 0, ($config'max_rounds || 1000); } sub ParseRoundNumber ($$) { my ($argvp, $usage) = @_; return ParseInteger $argvp, $usage, 'round number', 1, ($config'max_rounds || 10000); } sub ParseScore ($$) { my ($argvp, $usage) = @_; return ParseInteger $argvp, $usage, 'score', -500, 1500; } sub Prompt () { print $gPrompt[-1]; } sub ReadConfig () { $config'table_format = '%3s'; open(CONFIG, ") { s/#.*//; s/^\s*//; s/\s*$//; next unless /\S/; if (/^division?\s+(\S+)\s+(.*)/i) { $gDivision{lc $1} = bless {'file' => $2, 'name' => (uc $1)}, 'TSH::Division'; $gNDivisions++; } elsif (s/^perl\s+//i) { eval $_; print "eval: $@\n" if length($@); } elsif (s/^config\s+//i) { eval q($config') . $_; print "eval: $@\n" if length($@); } elsif (s/^autopair\s+//i) { if (/^(\w+) (\d+) (\d+)\s+(\w+)\s+(.*)/) { my ($div, $sr, $round, $command, $args) = ($1, $2, $3, $4, $5); my (@args) = split(/\s+/, $args); if ($command =~ /^(?:if|pair1324|p1324|koth|ns|newswiss|rr|roundrobin)$/i) { $config'autopair{uc $div}[$round] = [$sr, $command, @args]; } else { die "Unsupported autopair pairing system: $command\n"; } } else { chomp; die "Can't parse 'autopair $_' in tsh.config\n"; } } else { print "Can't parse: $_\n"; } } print "Configuration file loaded.\n"; if (@config'external_path) { print "Loading external(s)"; for $global'path (@config'external_path) { my $config = "$global'path/tshxcfg.txt"; if (-r "$config") { my $rv = do $config; if ($@) { print " [\@$@]"; } if ($!) { print " [!$!]"; } unless ($rv) { print " [X]"; } } } print "\n"; } } sub ReadDivision (\%) { my $dp = shift; my $fn = $dp->{'file'}; print "Loading division $dp->{'name'}.\n"; open(DIV, "<$fn") || die "Can't open $fn: $!\n"; local($_); my (@data) = (undef); my $id = 1; my $name_length = 16; while (
) { s/#.*//; s/^\s*//; s/\s*$//; next unless /\S/; # TODO: find longest player name my($player, $rating, $pairings, $scores, $etc) = /^([^;]+[^;\s\d])\s+(\d+)\s*([\d\s]*);\s*([-\d\s]*)((?:;[^;]*)*)$/; die "Can't parse: $_\n" unless defined $scores; $name_length = length($player) if $name_length < length($player); my(@pairings) = split(/\s+/, $pairings); my(@scores) = split(/\s+/, $scores); my $pp = { 'division' => $dp, 'id' => $id, 'name' => $player, 'rating' => $rating, # 'rnd'=>rand, 'rnd' => ((length($player) * (100+$id) * ord($player)) % 641), 'pairings' => [split(/\s+/, $pairings)], 'scores' => [split(/\s+/, $scores)], }; for my $extra (split(/;\s*/, $etc)) { next unless $extra =~ /\S/; my ($tag, @words) = split(/\s+/, $extra); if (defined $pp->{$tag}) { warn "Overwriting $tag field for $player.\n"; } $pp->{'etc'}{$tag} = \@words; } push(@data, $pp); $id++; } close(DIV); if ($name_length > $config'max_name_length) { $config'max_name_length = $name_length; $config'name_format = "%-${name_length}s"; } print "Warning: odd number of players in Division $dp->{'name'}.\n" if $#data % 2 == 1; $dp->{'data'} = \@data; SynchDivision $dp; } sub ReadDivisions () { for my $dp (values %gDivision) { ReadDivision %$dp; } print "All divisions loaded.\n"; } # Recursive_Swiss: recursively perform swiss pairings # # capsule summary of algorithm # # if we have one group, try all pairings until we find one that works # or have exhausted all possibilities. preference order for opponents # is based on distance from ideal Swiss opponent (1 plays ceil(n/2)) # # if we have more than one group, first make it even by promoting a # player if necessary. then try pairing it, and if we fail, keep # promoting two players at a time until we succeed or run out of # players and fail sub Recursive_Swiss ($$) { # [[p1,p2],[p3],[p4,p5,p6],...] divided into pairings groups # number of players must be even (assign bye before calling) my $win_groupsp = shift; # passed as reference, but shouldn't be modified # 0 indicates no repeats allowed, ..., 3 means up to 3 repeats = 4 pairings my $repeats = shift; # print "RS([",join(',',map { '[' . join(',', @$_) . ']' } @$win_groupsp), "])\n"; # swiss-debug confess "no groups\n" unless @$win_groupsp; # if we're down to one group, try all possibilities if ($#$win_groupsp == 0) { my $win_groupp = $win_groupsp->[0]; my $group_size = $#$win_groupp + 1; # odd number of players - oops if ($group_size % 2) { die "Odd number of players in last win group:" . join(',', map { $_->{'id'}} @$win_groupp) . "\nAborting"; } # no more players - shouldn't happen elsif ($group_size == 0) { die "Ran out of players?!\n"; } # one pair left - almost as easy elsif ($group_size == 2) { my ($p1, $p2) = @$win_groupp; if ($p1->{'repeats'}[$p2->{'id'}] <= $repeats) { # print "RS=($p1->{'id'},$p2->{'id'}) rpt=$p1->{'repeats'}[$p2->{'id'}]\n"; # swiss-debug return ($p1, $p2); } else { # print "RS failed\n"; # swiss-debug return (); } } # more than one pair - try each possible opp for first player, recurse else { my ($p1, @opps) = @$win_groupp; # prefered opponent is halfway down the group my $index = $#opps/2; # after $index, we try $index + 1, $index - 2, $index + 3, ... my $delta = 1; my $sign = 1; for my $i (0..$#opps) { my $p2 = $opps[$index]; if ($p1->{'repeats'}[$p2->{'id'}] <= $repeats) { # print qq(RS:PC{$p1 $p2}=$p1->{'repeats'}[$p2->{'id'}]<=$repeats\n) if $p1 == 4 || $p2 == 4; my (@group) = @opps; splice(@group, $index, 1); my (@paired) = Recursive_Swiss [\@group], $repeats; if (@paired) { # success! :) # print "RS=(", join(',', $p1, $p2, @paired), ")\n"; # swiss-debug return ($p1, $p2, @paired); } } } continue { $index += $delta; $delta = -($delta + $sign); $sign = -$sign; } # failure! :( # print "RS failed (2)\n"; # swiss-debug return (); } } # else we have more than one group else { # make sure we have an even number of players my ($carp, @cdr) = @$win_groupsp; my (@car) = (@$carp); # copy so as not to change master copy my @cadr; unless ($#$carp % 2) { # [1] get (copy, so we don't mess things up) the next group (@cadr) = (@{shift @cdr}); # move its top player to top group push(@car, shift @cadr); # if that didn't empty the next group, put it back if (@cadr) { unshift(@cdr, \@cadr); } } # pair within the group, then keep promoting pairs while (1) { my (@car_paired) = Recursive_Swiss [\@car], $repeats; if (@car_paired) { if (@cdr) { # still some unpromoted my (@cdr_paired) = Recursive_Swiss \@cdr, $repeats; if (@cdr_paired) { # all done! # print "RS=(", join(',', @car_paired, @cdr_paired), ")\n"; # swiss-debug return(@car_paired, @cdr_paired); } } # everybody got promoted else { return (@car_paired); } } # did we run out of players? last unless @cdr; # promote one, see [1] for comments (@cadr) = (@{shift @cdr}); push(@car, shift @cadr); if (@cadr) { unshift(@cdr, \@cadr); } die "Ark error - did you forget to assign a bye?\n" unless @cdr; # promote the other, see [1] for comments (@cadr) = (@{shift @cdr}); push(@car, shift @cadr); if (@cadr) { unshift(@cdr, \@cadr); } } # ran out of players - d'oh! # print "RS failed (3)\n"; # swiss-debug return (); } } sub ReopenConsole () { close(STDOUT); close(STDERR); close(STDIN); open(STDOUT, "+>dev:console:tsh console") || die; open(STDERR, "+>dev:console:tsh console") || die; open(STDIN, " $title EOF $html .= $config'html_top if $config'html_top; $html .= "

$title

\n"; return ("$title\n\n", $html); } sub ReportTrailer () { return ('', "

This report was generated using tsh version $gkVersion. For more information about tsh, please ask John Chew.

"); } # Given a division and a list of unpaired players who have their # 'pref' field set to a list of opponent preferences, find a reasonable # pairing of all the players sub ResolvePairings ($$) { my ($dp, $unpairedp) = @_; # { my $p; for $p (@$unpairedp) { print "# $p->{'name'}: @{$p->{'pref'}}\n"; } } # print "# finding optimal pairing\n"; { # block for scope isolation only my(@choice, $opp, $oppid); # mark all players as initially unpaired # 'opp' points to the provisional opponent for my $p (@$unpairedp) { $p->{'opp'} = -1; } # find best opp for each player, favoring top of field for (my $i=0; $i<=$#$unpairedp; ) { my $p = $unpairedp->[$i]; if ($p->{'opp'} >= 0) { $i++; next; } # player has already been paired - skip # go to head of preference list if visiting player for first time $choice[$i] = -1 unless defined $choice[$i]; # try the next preferred opp for this player. $opp = $p->{'pref'}[++$choice[$i]]; if (!defined $opp) { # print '.' x $i, "$p->{'name'} can't be paired, climbing back up from i=$i to i="; for ($choice[$i]=undef; $i>=0 && !defined $choice[$i]; $i--) { } # print "$i.\n"; if ($i < 0) { print "Walked entire tree, couldn't find acceptable pairing.\n"; return 0; } # find last paired player's opponent, which now has to be unpaired my $opp = $unpairedp->[$i]{'pref'}[$choice[$i]]; # unpair opponent from that player $opp->{'opp'} = -1; # unpair that player from the opponent $unpairedp->[$i]{'opp'} = -1; next; } # if (!defined $opp) - we've run out of opps, back up # print '.' x $i, "$p->{'name'} has pairing vector @{$p->{'pref'}}.\n"; # print ' ' x $i, " trying to pair $p->{'name'}, choice $choice[$i] is ", # defined $opp ? "$opp->{'name'} ($opp->{'id'})" : 'undef', "\n"; if ($opp->{'opp'} >= 0) { # print ' ' x $i, " but $opp->{'name'} has already been paired.\n"; next; } # looks good so far, let's try to keep going $p->{'opp'} = $opp->{'id'}; $opp->{'opp'} = $p->{'id'}; $i++; } # for $i } # copy provisional opponents to pairings for my $i (0..$#$unpairedp) { my $p = $unpairedp->[$i]; push(@{$p->{'pairings'}}, $p->{'opp'}); } 1; } # sub ResolvePairings sub SortByStanding ($@) { my $sr0 = shift; $gKeyRound = $sr0; my (@sorted) = sort bystanding @_; $gKeyRound = undef; return @sorted; } sub SpliceInactive (\@;$) { my $psp = shift; my $count = shift || 1; for (my $i=0; $i<=$#$psp; $i++) { my $p = $psp->[$i]; my $off = $p->{'etc'}{'off'}; next unless defined $off; splice(@$psp, $i--, 1); push(@{$p->{'pairings'}}, 0); push(@{$p->{'scores'}}, ($off->[0]) x $count); } } # update internal stats on division sub SynchDivision ($) { my ($dp) = @_; my $datap = $dp->{'data'}; my $minpairs = 999999; my $maxpairs = -1; my $maxscores = -1; my $maxs_player = undef; for my $i (1..$#$datap) { my $p = $datap->[$i]; my $pairingsp = $p->{'pairings'}; my $npairs = $#$pairingsp; my $nscores = $#{$p->{'scores'}}; my $spread = 0; my (@spread) = (); my $ratedgames = 0; my $ratedwins = 0; my $wins = 0; my (@wins) = (); # print "$p->{id} has $nscores+1 scores.\n" if $nscores > $maxscores; # print "$p->{id} has $npairs+1 opponents.\n" if $npairs > $maxpairs; $minpairs = $npairs if $npairs < $minpairs; $maxpairs = $npairs if $npairs > $maxpairs; if ($nscores > $maxscores) { $maxscores = $nscores; $maxs_player = $p->{'name'}; # print join(' ', $p->{'name'}, $nscores, @{$p->{'scores'}}), "\n"; } for my $j (0..$nscores) { # number of scores my $opp = $pairingsp->[$j]; if (!defined $opp) { printf "Oops: %s has a score but no opp in round 1+$j.\n", (TaggedName $p); } else { my $oppscore; if ($opp) { $oppscore = $datap->[$opp]{'scores'}[$j]; $ratedgames++; } else { $oppscore = 0; } print "j=$j pid=$p->{'id'} opp=$opp\n" unless defined $p->{'scores'}[$j]; my $thisSpread = $p->{'scores'}[$j] - $oppscore; $spread += $thisSpread; push(@spread, $spread); my $result = (1 + ($thisSpread <=> 0))/2; $wins += $result; $ratedwins += $result if $opp; push(@wins, $wins); } } # for $j $p->{'rspread'} = \@spread; $p->{'rwins'} = \@wins; $p->{'spread'} = $spread; $p->{'ratedwins'} = $ratedwins; $p->{'ratedgames'} = $ratedgames; $p->{'wins'} = $wins; { my @repeats; for my $j (1..$#$datap) { $repeats[$j] = 0; } for my $j (@$pairingsp) { $repeats[$j]++; } $p->{'repeats'} = \@repeats; } } $dp->{'maxs'} = $maxscores; $dp->{'maxs_player'} = $maxs_player; $dp->{'maxp'} = $maxpairs; $dp->{'minp'} = $minpairs; if ($config'track_firsts) { # must come after maxp computation SynchFirsts $dp; } } # Firsts and seconds are coded in $p->{'etc'}{'p12'} as follows # # 0: bye # 1: first # 2: second # 3: must draw # 4: indeterminate pending prior draws sub SynchFirsts ($) { my $dp = shift; my $datap = $dp->{'data'}; for my $p (@$datap[1..$#$datap]) { $p->{'p1'} = $p->{'p2'} = $p->{'p3'} = $p->{'p4'} = 0; my $scoresp = $p->{'scores'}; my $p12p = $p->{'etc'}{'p12'}; $#$p12p = $#$scoresp if $#$p12p > $#$scoresp; } for my $round0 (0..$dp->{'maxp'}) { for my $p (@$datap[1..$#$datap]) { my $opp = $p->{'pairings'}[$round0]; next unless defined $opp; my $p12p = $p->{'etc'}{'p12'}; if ($opp == 0) { $p12p->[$round0] = 0; next; } if ($opp < $p->{'id'}) { # in theory, we already did this one # if the pairings are inconsistent, though... if (!defined $p12p->[$round0]) { my $round = $round0 + 1; print((TaggedName $p) . " has no opponent in round $round.\n"); $p12p->[$round0] = 4; } next; } $opp = $datap->[$opp]; my $o12p = $opp->{'etc'}{'p12'}; my $exists = 1; my $p12 = $p12p->[$round0]; my $o12 = $o12p->[$round0]; if ($p12 && $p12 < 4) { if (!(defined $o12 && $o12 < 4)) { $o12p->[$round0] = (0, 2, 1, 3)[$p12]; } } elsif (defined $o12 && $o12 < 4) { $p12p->[$round0] = (0, 2, 1, 3)[$o12]; } else { $exists = 0; } if ($exists) { $p->{"p$p12p->[$round0]"}++; $opp->{"p$o12p->[$round0]"}++; next; } # otherwise, see if we can deduce first/second my $ofuzz = $opp->{'p3'} + $opp->{'p4'}; my $pfuzz = $p->{'p3'} + $p->{'p4'}; if ($pfuzz + $ofuzz == 0 || $round0 == 0) { my $which = 1 + ($p->{'p1'} <=> $opp->{'p1'} || $opp->{'p2'} <=> $p->{'p2'}); # print "$p->{'name'} $p->{'p1'} $p->{'p2'} $opp->{'name'} $opp->{'p1'} $opp->{'p2'} $which\n"; if ($which == 1 && $config'assign_firsts) { $which = 2 * int(rand(2)); } $p12 = (1, 3, 2)[$which]; $o12 = (2, 3, 1)[$which]; } # else there's fuzz, so we could get 4s else { my $diff1 = $p->{'p1'} - $opp->{'p1'}; my $diff2 = $p->{'p2'} - $opp->{'p2'}; if (($diff1 <=> $ofuzz || -$diff2 <=> $pfuzz) > 0) { $p12 = 1; $o12 = 2; } elsif ((-$diff1 <=> $pfuzz || $diff2 <=> $ofuzz) > 0) { $p12 = 2; $o12 = 1; } elsif ($config'assign_firsts) { if (rand(1) > 0.5) { $p12 = 1; $o12 = 2; } else { $p12 = 2; $o12 = 1; } } else { $p12 = $o12 = 4; } } $p->{'etc'}{'p12'}[$round0] = $p12; $opp->{'etc'}{'p12'}[$round0] = $o12; $p->{"p$p12"}++; $opp->{"p$o12"}++; } } } sub TaggedName ($) { my ($p) = @_; my $clean_name = $p->{'name'} || ''; $clean_name =~ s/,$//; # kludge to allow names ending in digits defined $p && length($clean_name) ? "$clean_name (\U$p->{'division'}{'name'}\E$p->{'id'})" : 'nobody'; } sub UpdateDivisions ($) { my $divsp = shift; for my $dname (keys %$divsp) { print "Updating Division $dname\n"; SynchDivision $gDivision{lc $dname}; WriteDivision $gDivision{lc $dname}; delete $divsp->{$dname}; } } sub WriteDivision ($) { my ($dp) = @_; my $i; rename $dp->{'file'}, ("$config'backup_directory$dp->{'file'}.".time) || die "Can't backup division ($!).\n"; open(OUT, ">$dp->{'file'}") || die "Can't create division ($!).\n"; &MacPerl'SetFileInfo('McPL', 'TEXT', $dp->{'file'}) if defined &MacPerl'SetFileInfo; for my $p (@{$dp->{'data'}}) { if (defined $p && defined $p->{'id'} && $p->{'id'}) { printf OUT "%-22s %4d %s; %s", $p->{'name'}, $p->{'rating'}, join(' ', @{$p->{'pairings'}}), join(' ', @{$p->{'scores'}}); if ($p->{'etc'}) { my $etcp = $p->{'etc'}; for my $key (sort keys %$etcp) { my $wordsp = $etcp->{$key}; print OUT "; $key @$wordsp" if $wordsp; } } print OUT "\n"; } } close(OUT); } sub WriteLog (\%$$) { my $fhsp = shift; my $text = shift; my $html = shift; my $fh; print $text; unless ($config'no_text_files) { $fh = $fhsp->{'text'}; print $fh $text; } $fh = $fhsp->{'html'}; print $fh $html; $fh = $fhsp->{'subhtml'}; print $fh $html; } ## main code Main;