#!/usr/bin/perl -w ## tsh - tournament shell ## Copyright (C) 1998-2003 by John J. Chew, III. ## Version history # # 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 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/'; } my $gkNameFormat = '%-22s'; my $gkVersion = '2.730'; ## prototypes sub CheckAutoPair ($$); sub ChooseBye ($$$); sub CmdAddScore ($$); sub CmdBye ($$); sub CmdCambridgePair ($$); sub CmdDeleteScore ($$); sub CmdEditScore ($$); sub CmdEval ($$); sub CmdFixWindow ($$); 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 DoClark (\%$); sub DoNewSwiss ($$$); sub DoSwiss ($$$$;$); sub GetUnpaired ($;$); sub lint (); sub Main (); sub log_pair ($); sub log_standings ($;$); sub log_ratings ($); sub log_wc ($); sub ParseDivisionName ($$); sub Prompt (); sub ReadConfig (); sub ReadDivisions (); sub Recursive_Swiss ($$); sub ReopenConsole (); sub ResolvePairings ($$); sub SynchDivision ($); sub TaggedName ($); 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 # maxp highest round number that has pairings data (0-based) # maxs highest round number that has score data (0-based) # 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 # id player ID (1-based) # not sure this is still here # name player name # 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 random 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 # # (and a lot more that I have yet to document) ## global variables my (%gCommands) = ( '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 ? ($b->{'rwins'}[$gKeyRound]<=>$a->{'rwins'}[$gKeyRound] || $b->{'rspread'}[$gKeyRound]<=>$a->{'rspread'}[$gKeyRound] || $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 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: missing a score for $p->{'name'} (and maybe others) in round $sr.\n"; return 0; } } } my $system = $apd[0]; # check to see we aren't going too far ahead if ($round0 != $dp->{'maxp'}+1) { my $mp1 = $dp->{'maxp'}+1; print "Can't autopair round $round; next round to pair is $mp1.\n"; return 0; } # 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 ChooseBye ($$$) { my $dp = shift; my $round0 = shift; my $sr0 = shift; my $datap = $dp->{'data'}; my $minbyes = 9999999; # recount everyone's byes for my $p (@$datap[1..$#$datap]) { next unless defined $p; my $byes = 0; for my $r (0..$round0) { my $opp = $p->{'pairings'}[$r]; if ((defined $opp) && $opp == 0) { $byes++; } } $minbyes = $byes if $byes < $minbyes; $p->{'byes'} = $byes; } # look for lowest ranked player with minimum byes $gKeyRound = $sr0; my $p = (sort bystanding grep { (defined $_->{'byes'}) && $_->{'byes'} == $minbyes } @$datap[1..$#$datap])[-1]; $gKeyRound = undef; unless (defined $p) { die "Tried to choose a bye but couldn't find any players?!"; } $p->{'pairings'}[$round0] = 0; # $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) = @_; shift @$argvp; my $usage = "Usage: Addscore round [division]\n"; my $round = shift @$argvp; unless ($round =~ /^\d+$/ && $round > 0) { print "Bad round: $round.\n"; return 0; } my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; my $datap = $dp->{'data'}; if ($#$argvp != -1) { print $usage; return 0; } my %dirty = (); 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; } last if /[^-\d\s]/; my (@words) = split; last if $#words != 3; my ($pn1, $ps1, $pn2, $ps2) = @words; if ($pn1 > $#$datap) { print "There is no player #$pn1.\n"; next; } if ($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] != 999) { print "$pp1->{'name'} already has a score.\n"; next; } if ($pp2->{'scores'}[$round-1] && $pp2->{'scores'}[$round-1] != 999) { print "$pp2->{'name'} already has a score.\n"; next; } { 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, ; } $dirty{$dp->{name}}++; $pp1->{'scores'}[$round-1] = $ps1; $pp2->{'scores'}[$round-1] = $ps2; } for my $dname (keys %dirty) { print "Updating Division $dname\n"; SynchDivision $gDivision{lc $dname}; WriteDivision $gDivision{lc $dname}; } 0; } sub CmdBye ($$) { my ($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: BYE p1 score round [division]\n"; # TODO: fix pairings for opponents of bye player my $p1 = shift @$argvp; unless (defined $p1 && $p1 =~ /^\d+$/ && $p1 >= 1) { print $usage; return 0; } my $score = shift @$argvp; unless (defined $score && $score =~ /^-?\d+$/) { print $usage; return 0; } my $round = shift @$argvp; unless (defined $round && $round =~ /^\d+$/ && $round >= 1) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, $usage); unless (defined $dp && $#$argvp == -1) { print $usage; return 0; } my $datap = $dp->{'data'}; $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 defined $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) = @_; shift @$argvp; my $usage = "Usage: CambridgePair [division-name]\n"; my $dp = (ParseDivisionName $argvp, "1. $usage"); return 0 unless defined $dp; unless ($#$argvp == -1) { print "2. $usage"; return 0; } # check that division has no pairings if ($dp->{'maxp'} != -1) { print "Division already has pairings.\n"; return 0; } 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; } } SynchDivision $dp; WriteDivision $dp; 0; } sub CmdDeleteScore ($$) { # TODO: should delete byes my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: DELETEscore p1 s1 p2 s2 round [division]\n"; my $pn1 = shift @$argvp; my $s1 = shift @$argvp; my $pn2 = shift @$argvp; my $s2 = shift @$argvp; my $round = shift @$argvp; unless ((defined $round) && $round =~ /^\d+$/ && $round > 0) { print "Bad round: $round.\n$usage"; return 0; } my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; if ($#$argvp != -1 || $pn1 !~ /^\d+$/ || $pn2 !~ /^\d+$/) { print $usage; return 0; } 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) = @_; shift @$argvp; my $usage = "Usage: EditScore [division] player-id round\n"; my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; my $datap = $dp->{'data'}; if ($#$argvp != 1) { print $usage; return 0; } my $id = shift @$argvp; unless ($id =~ /^\d+$/ && $id > 0) { print "Bad player id: $id.\n"; return 0; } my $p = $datap->[$id]; unless (defined $p) { print "No such player: $id.\n"; return 0; } my $round = shift @$argvp; unless ($round =~ /^\d+$/ && $round > 0) { print "Bad round: $round.\n"; return 0; } my $dirty = 0; print "Enter: D div, R round, P player, or a pair of corrected scores\n"; while (1) { my $oppid = $p->{'pairings'}[$round-1]; my $opp = $datap->[$oppid]; my $ms = $p->{'scores'}[$round-1] || 0; my $os = $opp->{'scores'}[$round-1] || 0; my $oname = $oppid ? "$opp->{'name'} ($dp->{'name'}$oppid)" : 'bye'; print "$p->{'name'} ($dp->{'name'}$id) R$round " . "[$ms $os vs $oname]: "; 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]; unless (defined $p) { $id = 1; $p = $datap->[1]; } } 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) { $p = $newp; $id = $newid; } else { print "No such player.\n"; } } elsif (/^(-?\d+)\s+(-?\d+)$/) { $p->{'scores'}[$round-1] = $1; $opp->{'scores'}[$round-1] = $2 if $oppid; if ($gNDivisions == 1) { CmdShowScoreCard ['sc', $id], "sc $id"; } else { CmdShowScoreCard ['sc', $dp->{'name'}, $id], "sc $dp->{'name'} $id"; } $dirty = 1; } else { last; } } if ($dirty) { SynchDivision $dp; WriteDivision $dp; } 0; } sub CmdEval ($$) { my($argvp, $args) = @_; $args =~ s/^(;|eval)\s//i; print join("\n", eval $args); print "\neval returns: '$@'\n"; 0; } 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 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 and the rest KOTH PairMany r d make several pairings changes at once PartialSWiss rpt p1 p2 d Swiss-pair division from p1 to p2 only PrePreSWiss rpt p1 p2 d Swiss-pair division using n-3 results PRESWiss rpt p1 p2 d Swiss-pair division using n-2 results 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 div p1 show correct scorecard for checking ShowPair r d show pairings STandings d show current standings SWiss rpt sr d add a round of Swiss pairings (replaced by NewSwiss) 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) = @_; shift @$argvp; my $usage = "Usage: InitFontes number-of-rounds [division-name]\n"; my $nrounds = shift @$argvp; unless (defined $nrounds && $nrounds =~ /^\d+/) { print "1. $usage"; return 0; } my $dp = (ParseDivisionName $argvp, "2. $usage"); return 0 unless defined $dp; unless ($#$argvp == -1) { print "3. $usage"; return 0; } # check that division has no pairings if ($dp->{'maxp'} != -1) { print "Division already has pairings.\n"; return 0; } # calculate pairings if ($nrounds == 3) { my @rrs = (); my $sortedp = GetUnpaired $dp; @$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 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) # 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) + 1; $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) = @_; shift @$argvp; my $usage = "Usage: KOTH repeats-allowed sorting-round [division-name]\n"; my $repeats = shift @$argvp; unless (defined $repeats && $repeats =~ /^\d+$/) { print "1. $usage"; return 0; } my $sorting_round = shift @$argvp; if ($sorting_round !~ /^\d+$/) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, "2. $usage"); return 0 unless defined $dp; unless ($#$argvp == -1) { print $usage; return 0; } if ($sorting_round-1 > $dp->{'maxs'}) { print "sorting-round $sorting_round is too big for division $dp->{'name'}.\n"; return 0; } print "Calculating King-Of-The-Hill pairings for Division $dp->{'name'} based on round $sorting_round.\n"; $sorting_round--; my $sortedp = (GetUnpaired $dp); if ($#$sortedp % 2 == 0) { print "Can't pair an odd number of players.\n"; return 0; } $gKeyRound = $sorting_round; @$sortedp = sort bystanding @$sortedp; $gKeyRound = undef; { 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) = @_; shift @$argvp; my $usage = "Usage: MISSING round\n"; my $round = shift @$argvp; unless (defined $round && $round =~ /^\d+$/ && $round >= 1) { print $usage; return 0; } 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'}[$round-1]) { print TaggedName $datap->[$i]; my $opp = $datap->[$i]{'pairings'}[$round-1]; if (defined $opp) { if (!defined $datap->[$opp]{'scores'}[$round-1]) { print ' vs. ', TaggedName $datap->[$opp]; } $done[$opp] = 1; } print "\n"; } } } 0; } sub CmdNewSwiss ($$) { my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: NewSwiss repeats standings-round [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; } $sr --; # humans use one-based indexing, internally we use zero-based my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; my $datap = $dp->{'data'}; DoNewSwiss $dp, $repeats, $sr; 0; } sub CmdPair ($$) { my ($argvp) = @_; shift @$argvp; # TODO: fix pairings for opponents of repaired players my $usage = "Usage: PAIR p1 p2 round [division]\n"; my $p1 = shift @$argvp; unless (defined $p1 && $p1 =~ /^\d+$/ && $p1 >= 0) { print $usage; return 0; } my $p2 = shift @$argvp; unless (defined $p2 && $p2 =~ /^\d+$/ && $p2 >= $p1) { print $usage; return 0; } my $round = shift @$argvp; unless (defined $round && $round =~ /^\d+$/ && $round >= 1) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, $usage); unless (defined $dp && $#$argvp == -1) { print $usage; return 0; } my $datap = $dp->{'data'}; unless ($p2 <= $#$datap) { print $usage; return 0; } $round--; $^W = 0; my $p1pair = $datap->[$p1]{'pairings'} if $p1; my $p2pair = $datap->[$p2]{'pairings'}; printf "%s used to be paired to %s\n", (TaggedName $datap->[$p1]), (TaggedName $datap->[$p1pair->[$round]]) if $p1 && defined $p1pair->[$round]; printf "%s used to be paired to %s\n", (TaggedName $datap->[$p2]), (TaggedName $datap->[$p2pair->[$round]]) if defined $p2pair->[$round]; $^W = 1; $p1pair->[$round] = $p2 if $p1; $p2pair->[$round] = $p1; SynchDivision $dp; WriteDivision $dp; 0; } sub CmdPair1324 ($$) { my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: Pair1324 repeats-allowed sorting-round division-name\n"; my $repeats = shift @$argvp; if ($repeats !~ /^\d+$/) { print $usage; return 0; } my $sorting_round = shift @$argvp; if ($sorting_round !~ /^\d+$/) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, $usage); unless (defined $dp && $#$argvp == -1) { print $usage; return 0; } if ($sorting_round-1 > $dp->{'maxs'}) { print "sorting-round $sorting_round is too big for division $dp->{'name'}.\n"; return 0; } print "Calculating 1324 pairings for Division $dp->{'name'} based on round $sorting_round.\n"; $sorting_round--; my $sortedp = (GetUnpaired $dp); if ($#$sortedp % 2 == 0) { print "Can't pair an odd number of players.\n"; return 0; } $gKeyRound = $sorting_round; @$sortedp = sort bystanding @$sortedp; $gKeyRound = undef; { 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; } sub CmdPairMany ($$) { my ($argvp) = @_; shift @$argvp; # TODO: fix pairings for opponents of repaired players my $usage = "Usage: PairMany round [division]\n"; my $round = shift @$argvp; unless (defined $round && $round =~ /^\d+$/ && $round >= 1) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, $usage); unless (defined $dp && $#$argvp == -1) { print $usage; return 0; } 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]; next unless defined $oldoppn; next if $oldoppn == $oppn; print "#$pn $pp->{'name'} used to be paired to #$oldoppn $datap->[$oldoppn]{'name'}\n"; $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}, ; } $dirty{$dp->{name}}++; } for my $dname (keys %dirty) { print "Updating Division $dname\n"; SynchDivision $gDivision{lc $dname}; WriteDivision $gDivision{lc $dname}; } 0; } sub CmdPartialSwiss ($$) { my($argvp, $args) = @_; 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) = @_; 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) = @_; 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"; my $p; for $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) = @_; shift @$argvp; my $usage = "Usage: RATings division-name\n"; my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; unless ($#$argvp == -1) { print $usage; return 0; } 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]) { 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; } 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) = @_; shift @$argvp; my $usage = "Usage: RoundRobin [division-name]\n"; my $dp = (ParseDivisionName $argvp, "1. $usage"); return 0 unless defined $dp; unless ($#$argvp == -1) { print "2. $usage"; return 0; } # check that division is not partially paired my $datap = $dp->{'data'}; my $nplayers = $#$datap; { 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; } } 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) = @_; shift @$argvp; my $usage = "Usage: standings round division-name\n"; my $round = shift @$argvp; unless (defined $round) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, $usage); unless (defined $dp && $#$argvp == -1) { print $usage; 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; $gKeyRound = --$round; my @sorted = sort bystanding @$datap[1..$#$datap]; $gKeyRound = undef; for my $p (@sorted) { my $wins = $p->{'wins'}; my $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, $p->{'rwins'}[$round], $round+1-$p->{'rwins'}[$round], $p->{'rspread'}[$round], $p->{'rating'}, (TaggedName $p) unless $p->{name} =~ /^bye /; } 0; } sub CmdShowPairings ($$) { my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: ShowPair [-p] round [division-name]\n"; my $opt_p = 0; if ($argvp->[0] eq '-p') { shift @$argvp; $opt_p = 1; } my $round = shift @$argvp; unless (defined $round && $round =~ /^\d+$/ && $round > 0) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; if ($#$argvp != -1) { print $usage; return 0; } CheckAutoPair $dp, $round; if ($opt_p) { my $datap = $dp->{'data'}; print '['; print join(',', map { $_->{'pairings'}[$round-1]-1 } @$datap[1..$#$datap]); print "]\n"; return 0; } open(PAIR, ">$dp->{'name'}-pairings.doc") or warn "can't create tee log: $!\n"; &MacPerl'SetFileInfo('MSWD', 'TEXT', "$dp->{'name'} pairings") if defined &MacPerl'SetFileInfo; log_pair "Round $round Pairings for Division $dp->{'name'}:\n\n"; # 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_pair "Table "; my $shortage = length(sprintf($config'table_format, ''))-3; die "table format must be at least three characters wide\n" if $shortage < 0; log_pair ' ' x $shortage; } log_pair "Board Players\n"; my $datap = $dp->{'data'}; { my %done; my %reserved; my @unreserved; my @errors; $gKeyRound = $round-2; $gKeyRound = 0 if $gKeyRound < 0; $gKeyRound = $dp->{maxs} if $gKeyRound > $dp->{maxs}; my @sorted = sort bystanding @$datap[1..$#$datap]; $gKeyRound = undef; for my $p (@sorted) { my $opp = $p->{'pairings'}[$round-1]; if (!defined $opp) { log_pair sprintf(" $config'table_format ", '') if defined $tables; log_pair sprintf(" %s: UNPAIRED.\n", (TaggedName $p)); } elsif ($opp == 0) { log_pair sprintf(" $config'table_format ", '') if defined $tables; log_pair 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_pair sprintf(" $config'table_format ", $tables->[$board]) if defined $tables; log_pair sprintf(" %3d %s vs. %s.\n", $board+1, (TaggedName $p), (TaggedName $opp)); $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_pair sprintf(" %3d ", $tables->[$board]) if defined $tables; log_pair sprintf(" %3d %s vs. %s.\n", $board+1, (TaggedName $p), (TaggedName $opp)); } } print @errors; } close(PAIR); 0; } sub CmdShowScoreCard ($$) { my($argvp, $args) = @_; # parse command line shift @$argvp; my $usage = "Usage: ShowscoreCard division-name player-number\n"; my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; my $datap = $dp->{'data'}; my $pn = shift @$argvp; unless ((defined $pn) && $pn !~ /\D/) { print $usage; return 0; } my $p = $datap->[$pn]; unless (defined $p) { print "No player #$pn in division $dp->{'name'}.\n"; return 0; } # print header printf "Player Scorecard: %s (%d)\n", (TaggedName $p), $p->{'rating'}; printf "Rnd Opp Rtng ${gkNameFormat} 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]; if ($oid) { printf "%3d %3d %4d ${gkNameFormat}", 1+$i, $opp->{'id'}, $opp->{'rating'}, $opp->{'name'}; } else { printf "%3d %3s %4s ${gkNameFormat}", 1+$i, '', '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; } sub CmdShowWallChart ($$) { my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: showWallChart [-f #] [division...]\n"; my $from = 1; if ($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("${gkNameFormat}\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("$gkNameFormat ", $p->{'name'}); my $line2 = sprintf("$gkNameFormat ", ''); 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("$gkNameFormat ", ''); } } $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) = @_; shift @$argvp; my $usage = "Usage: standings [division-name]\n"; my $dp = (ParseDivisionName $argvp, $usage); return 0 unless defined $dp; unless ($#$argvp == -1) { print $usage; return 0; } open(STANDINGS, ">$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"; } log_standings qq($title), 1; log_standings "

", 1; log_standings $title; log_standings "

", 1; log_standings "\n\n"; } log_standings "\n", 1; log_standings "", 1; log_standings "\n\n"; my $datap = $dp->{'data'}; my $lastw = -1; my $lasts = 0; my $rank = 0; my $i = 0; for my $p (sort by_current_standing @$datap[1..$#$datap]) { my $wins = $p->{'wins'}; my $spread = $p->{'spread'}; $i++; if ($wins != $lastw || $spread != $lasts) { $lastw = $wins; $lasts = $spread; $rank = $i; } unless ($p->{name} =~ /^bye /) { log_standings "", 1; log_standings "\n"; } } log_standings "
", 1; log_standings "Rank "; log_standings "", 1; log_standings "Won-Lost "; log_standings "", 1; log_standings "Spread "; log_standings "", 1; log_standings "Rtng "; log_standings "", 1; log_standings "Name"; log_standings "
", 1; log_standings sprintf("%4d ", $rank); log_standings "", 1; log_standings sprintf("%4.1f-%4.1f ", $wins, $#{$p->{'scores'}}+1-$wins); log_standings "", 1; log_standings sprintf("%+5d ", $spread); log_standings "", 1; log_standings sprintf("%4d ", $p->{'rating'}); log_standings "", 1; log_standings (TaggedName $p); log_standings "
", 1; close(STANDINGS); 0; } sub CmdSwiss ($$) { my($argvp, $args) = @_; 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; } sub CmdUnpairRound ($$) { my($argvp, $args) = @_; # TODO: should delete byes shift @$argvp; my $usage = "Usage: UnpairRound round [division-name]\n"; my $round = shift @$argvp; if ((!defined $round) || $round !~ /^\d+$/) { print $usage; return 0; } my $dp = (ParseDivisionName $argvp, "2. $usage"); return 0 unless defined $dp; unless ($#$argvp == -1) { print $usage; return 0; } $round--; if ($dp->{'maxp'} == -1) { print "There aren't any pairings in that division yet.\n"; return 0; } if ($round != $dp->{'maxp'}) { printf "The only round you can unpair is the last paired one: %d\n", $dp->{'maxp'}+1; return 0; } if ($round < $dp->{'maxs'}) { print "You can't unpair a round ($round) that already has scores recorded in it.\n"; print "($dp->{'maxs_player'} has a score in round $dp->{'maxs'}.)\n"; print "Try using the DeleteScore command or editing the .t file.\n"; return 0; } printf "Deleting pairings for Division %s, round %d.\n", $dp->{'name'}, $round+1; my $datap = $dp->{'data'}; for my $i (1..$#$datap) { my $p = $datap->[$i]; my $pairingsp = $p->{'pairings'}; if ($#$pairingsp == $round) { my $opp = pop @$pairingsp; print "... $p->{id} unpaired from $opp.\n"; } } SynchDivision $dp; WriteDivision $dp; print "Done.\n"; 0; } # 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] = $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, $sr) = @_; my $datap = $dp->{'data'}; my $theKeyRound = $sr; print("Calculating New Swiss pairings for division $dp->{'name'}," ." $repeats repeats"); printf " using round %d results.\n", $theKeyRound + 1; my $tobepaired = (GetUnpaired $dp); printf "Players to be paired: %d\n", $#$tobepaired+1; return unless @$tobepaired; # @$tobepaired = grep($_->{'id'} >= $p1 && $_->{'id'} <= $p2, @$tobepaired); if ($#$tobepaired % 2 == 0) { print "Can't Swiss pair an odd number of players, assign a bye first.\n"; return; } # sort by wins and spread, arrange tied players randomly $gKeyRound = $theKeyRound; my (@ranked) = sort bystanding @$tobepaired; $gKeyRound = undef; # 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 old-style or 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 $gKeyRound = $theKeyRound; my (@ranked) = sort bystanding @$tobepaired; $gKeyRound = undef; # 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 vector of players that need to be paired sub GetUnpaired ($;$) { my $dp = shift; my $emptyok = shift; my $datap = $dp->{'data'}; my $maxp = $dp->{'maxp'}; my @unpaired = (); # first check for an already partially paired round for my $p (@$datap[1..$#$datap]) { next unless $p && !defined $p->{'pairings'}[$maxp]; push(@unpaired, $p); # print "Unpaired in $maxp: $p->{'id'}\n" if $p->{'id'} == 7; # if ($p) { my $o = $p->{'pairings'}[$maxp]; print "$p: "; print defined $o ? $o : "undef"; print "\n"; } } # for $p # print "up=$#unpaired\n"; # if we didn't find any in the last round, return complete vector if ($#unpaired < 0 && !$emptyok) { @unpaired = @$datap; shift @unpaired; } # print "(round $maxp was completely paired, looking at next.)\n"; # else { print "(found partial round at $maxp)\n"; } \@unpaired; } # sub GetUnpaired sub lint () { $config'noboys = 0; $config'reserved{''} = ''; $config'tables{''} = ''; lint; } sub log_ratings ($) { print $_[0]; print RATINGS $_[0]; } sub log_pair ($) { print $_[0]; print PAIR $_[0]; } sub log_standings ($;$) { print $_[0] unless $_[1]; print STANDINGS $_[0]; } 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 defined $^O eq 'MacOS'; print "\nWelcome to tsh version $gkVersion.\n"; ReadConfig; ReadDivisions; Prompt; while (<>) { next unless /\S/; my(@argv) = split; my $sub = $gCommands{lc $argv[0]}; if (defined $sub) { last if &$sub(\@argv, $_); } else { print "Enter 'help' for help.\n"; } } continue { Prompt; } } sub ParseDivisionName ($$) { my ($argvp, $usage) = @_; if ($gNDivisions == 1) { (%gDivision)[1]; } elsif ($#$argvp < 0) { print $usage; undef; } else { my $dn = lc shift @$argvp; my $dp = $gDivision{$dn}; if (!defined $dp) { print "No such division: \U$dn\E.\n"; undef; } else { $dp; } } } 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} = {'file' => $2, 'name' => (uc $1)}; $gNDivisions++; } elsif (s/^perl\s+//i) { eval $_; 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"; } sub ReadDivisions () { for my $dp (values %gDivision) { 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; while (
) { s/#.*//; s/^\s*//; s/\s*$//; next unless /\S/; # TODO: find longest player name my($player, $rating, $pairings, $scores) = /^([^;]+[^;\s\d])\s+(\d+)\s+([\d\s]*);\s*([-\d\s]*)$/; die "Can't parse: $_\n" unless defined $scores; my(@pairings) = split(/\s+/, $pairings); my(@scores) = split(/\s+/, $scores); push(@data, { 'division'=>$dp, 'id'=>$id, 'name'=>$player, 'rating'=>$rating, 'pairings'=>\@pairings, 'rnd'=>rand, 'scores'=>\@scores }); $id++; } close(DIV); print "Warning: odd number of players in Division $dp->{'name'}.\n" if $#data % 2 == 1; $dp->{'data'} = \@data; SynchDivision $dp; } # for $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, "{'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 SynchDivision ($) { my ($dp) = @_; my $datap = $dp->{'data'}; 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; $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; } sub TaggedName ($) { my ($p) = @_; defined $p ? "$p->{'name'} (\U$p->{'division'}{'name'}\E$p->{'id'})" : 'nobody'; } 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\n", $p->{'name'}, $p->{'rating'}, join(' ', @{$p->{'pairings'}}), join(' ', @{$p->{'scores'}}); } } close(OUT); } ## main code Main;