#!/usr/bin/perl -w ## tsh - tournament shell ## Copyright (C) 1998-2003 by John J. Chew, III. # TODO support for .t extensions: cume cumeadj # TODO Amit points out that sort +1 is POSIX-deprecated :( # TODO stat .t files to check for and journal independently made changes? # TODO file locking to prevent tsh from running twice with same config # 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 pair using firsts and seconds # TODO extend support for 9999 = no score yet ## Version history # # 2.900 ? # 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 # TODO: printing support use strict; use Carp; ## libraries unshift(@::INC, "$::ENV{'HOME'}/lib/perl") if defined $::ENV{'HOME'}; # require 'dawg.pl'; ## global constants if ($^O eq 'MacOS') { $config'backup_directory = ':old:'; } else { $config'backup_directory = './old/'; } $config'max_name_length = 22; $config'name_format = '%-22s'; @config'external_path = qw(./bin ../bin); my $gkVersion = '2.850'; ## prototypes sub CheckAutoPair ($$); sub CheckRoundHasResults ($$); sub ChooseBye ($$$); 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 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 log_pairings ($$); sub log_standings ($$); sub log_ratings ($); sub log_wc ($); 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 ($); ## 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 in CmdResultsByRound # twins temporary wins variable used in CmdResultsByRound # 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, '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, ); 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"; # # if unpaired are odd, choose a bye player # if (@unpaired % 2 && $system !~ /^if$/i) { # ChooseBye $dp, $round0, $sr0; # } # unpaired are now even, apply required pairing system if ($system =~ /^(?:if)$/i) { CmdInitFontes \@apd, "@apd"; } elsif ($system =~ /^(?:ns|newswiss)$/i) { CmdNewSwiss \@apd, "@apd"; } elsif ($system =~ /^(?:koth)$/i) { CmdKOTH \@apd, "@apd"; } elsif ($system =~ /^(?:rr|roundrobin)$/i) { CmdRoundRobin \@apd, "@apd"; } else { die "Unknown pairing system '$system'"; } } 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 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->{'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->{'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 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); printf "Players to be paired: %d\n", $#$sortedp+1; return unless @$sortedp; 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); 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, }; } # 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; open(RATINGS, ">$dp->{'name'}-ratings.doc") or warn "can't create tee log: $!\n"; log_ratings "Estimated Ratings"; log_ratings " for Division $dp->{'name'}" if $gNDivisions > 1; # log_ratings " after Round $dp->{'maxs'}"; # not working correctly log_ratings "\n\n"; log_ratings "Rank Won-Lost Spread OldR NewR Delta Player\n\n"; 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'}; log_ratings sprintf("%4d %4.1f-%4.1f %+5d %4d %4d %+5d %s\n", $rank, $wins, $#{$p->{'scores'}}+1-$wins, $spread, $p->{'rating'}, $newr, $newr-$p->{'rating'}, (TaggedName $p) ) unless $p->{name} =~ /^bye /; } close(RATINGS); 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 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; } open(PAIRINGS, ">$dp->{'name'}-pairings.doc") or warn "can't create tee log: $!\n"; open(PAIRINGS_HTML, ">$dp->{'name'}-pairings.html") or warn "can't create tee log: $!\n"; &MacPerl'SetFileInfo('MSWD', 'TEXT', "$dp->{'name'} pairings") if defined &MacPerl'SetFileInfo; { my $title = "Round $round Pairings"; if ($gNDivisions > 1) { $title = "Division $dp->{'name'} $title"; } my ($text, $html) = ReportHeader $title; log_pairings $text, $html; } log_pairings '', <<'EOF'; EOF # 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) { log_pairings 'Table ', ''); } log_pairings "Board Players\n", <<'EOF'; 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) { log_pairings sprintf(" $config'table_format ", ''), '' if defined $tables; log_pairings sprintf(" %s: UNPAIRED.\n", (TaggedName $p)), ''; } elsif ($opp == 0) { log_pairings sprintf(" $config'table_format ", ''), '' if defined $tables; log_pairings sprintf(" %s: BYE.\n", (TaggedName $p)), ''; $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]) { $reserved{$reserved->[$p]} = [$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}) { $board++; } log_pairings '', ''; log_pairings sprintf(" $config'table_format ", $tables->[$board]), "" if defined $tables; my $vs = FormatPairing $dp, $round0, $p->{id}; unless ($vs) { log_pairings "Lost track of $p->{name}", "Lost track of $p->{name}"; next; } my $vshtml = $vs; $vshtml =~ s/\*(?:starts|draws)\*/$&<\/span>/; log_pairings sprintf(" %3d %s.\n", $board+1, $vs), '\n" ; $board++; } for my $b (sort { $a <=> $b } keys %reserved) { my ($p, $opp) = @{$reserved{$b}}; my $board = $reserved->[$p->{'id'}]; die "Oops!" unless defined $board; log_pairings '', ''; log_pairings sprintf(" $config'table_format ", $tables->[$board]), "" if defined $tables; my $vs = FormatPairing $dp, $round0, $p->{id}; log_pairings sprintf(" %3d %s.\n", $board+1, $vs), '"; ; } } print @errors; } log_pairings '', '
Table'; my $shortage = length(sprintf($config'table_format, ''))-3; die "table format must be at least three characters wide\n" if $shortage < 0; log_pairings ((' ' x $shortage), 'Board Who Plays Whom
 UNPAIRED' . (TaggedName $p) . ' BYE' . (TaggedName $p) . '
$tables->[$board]' . ($board+1) . "$vshtml
$tables->[$board]' . ($board+1) . "$vs
'; { my ($text, $html) = ReportTrailer; log_pairings $text, $html; } close(PAIRINGS); close(PAIRINGS_HTML); 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"; 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'}; open(STANDINGS, ">$dp->{'name'}-standings.doc") or warn "can't create tee log: $!\n"; open(STANDINGS_HTML, ">$dp->{'name'}-standings.html") or warn "can't create tee log: $!\n"; # TODO: should report round number? { my $round = $dp->{'maxs'} + 1; my $title = "Round $round Standings"; if ($gNDivisions > 1) { $title = "Division $dp->{'name'} $title"; } my ($text, $html) = ReportHeader $title; log_standings $text, $html; } log_standings "Rank Won-Lost Spread Rtng Name\n\n", <<'EOF'; 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)); log_standings sprintf("%4d %4.1f-%4.1f %+5d %4d %s\n", @fields), sprintf(<<'EOF', @fields); EOF } } log_standings '', "
Rank Won-Lost Spread Rating Name
%d %4.1f-%4.1f %+d %d %s
"; { my ($text, $html) = ReportTrailer; log_standings $text, $html; } close(STANDINGS); close(STANDINGS_HTML); 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(based-on-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); printf "Players to be paired: %d\n", $#$tobepaired+1; return unless @$tobepaired; 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; } # 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'noboys = 0; $config'reserved{''} = ''; $config'tables{''} = ''; lint; } sub log_ratings ($) { print $_[0]; print RATINGS $_[0]; } sub log_pairings ($$) { print $_[0]; print PAIRINGS $_[0]; print PAIRINGS_HTML $_[1]; } sub log_standings ($$) { print $_[0]; print STANDINGS $_[0]; print STANDINGS_HTML $_[1]; } 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 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, 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, 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, 1000; } sub ParseRoundNumber ($$) { my ($argvp, $usage) = @_; return ParseInteger $argvp, $usage, 'round number', 1, 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|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; } for my $round0 (0..$dp->{'maxp'}) { for my $p (@$datap[1..$#$datap]) { my $opp = $p->{'pairings'}[$round0]; next unless defined $opp; if ($opp == 0) { $p->{'etc'}{'p12'}[$round0] = 0; next; } next if $opp < $p->{'id'}; $opp = $datap->[$opp]; my $p12p = $p->{'etc'}{'p12'}; 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"; } } print OUT "\n"; } } close(OUT); } ## main code Main;