#!/usr/local/bin/perl -w ## tsh - tournament shell ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 by John J. Chew, III. ## jjchew@math.utoronto.ca ## Version history # # 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 = '1.700'; ## prototypes sub CmdAddScore ($$); sub CmdBye ($$); 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 CmdPartialSwiss ($$); sub CmdPreSwiss ($$); sub CmdPrePreSwiss ($$); sub CmdQuit ($$); sub CmdRandomScores ($$); sub CmdResultsByRound ($$); sub CmdRoundStandings ($$); sub CmdShowWallChart ($$); sub CmdShowScoreCard ($$); sub CmdStandings ($$); sub CmdSwiss ($$); sub CmdUnpairRound ($$); sub DoNewSwiss ($$$); sub DoSwiss ($$$$;$); sub GetUnpaired ($); sub Main (); 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 # maxs highest round number that has score data # name division name # # player data (in $gDivision{$div}{data}) is a hash mapping # # division pointer to division # id player ID (1-based) # name player name # rating pre-tournament rating # pairings list of opponent IDs by round (0-based by round, 1-based IDs) # rnd random value used to break ties in standings # scores list of this player's scores by round (0-based) # tspread temporary spread variable used in CmdResultsByRound # twins temporary wins variable used in CmdResultsByRound # # (and a lot more that I have yet to document) ## global variables my (%gCommands) = ( 'a' => \&CmdAddScore, 'addscore' => \&CmdAddScore, 'bye' => \&CmdBye, '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, 'p1324' => \&CmdPair1324, 'pair1324' => \&CmdPair1324, 'partialswiss' => \&CmdPartialSwiss, 'ppsw' => \&CmdPrePreSwiss, 'prepreswiss' => \&CmdPrePreSwiss, 'presw' => \&CmdPreSwiss, 'preswiss' => \&CmdPreSwiss, 'psw' => \&CmdPartialSwiss, 'q' => \&CmdQuit, 'quit' => \&CmdQuit, 'rand' => \&CmdRandomScores, 'rbr' => \&CmdResultsByRound, '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 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 = 0; while (1) { print "[$dp->{'name'}${round}]:pn1 ps1 pn2 ps2? "; local($_) = scalar(); 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; } print "$pp1->{name} $ps1 - $pp2->{name} $ps2.\n"; $dirty = 1; $pp1->{'scores'}[$round-1] = $ps1; $pp2->{'scores'}[$round-1] = $ps2; } if ($dirty) { SynchDivision $dp; WriteDivision $dp; } 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; } 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; $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 DELETEscore p1 s1 p2 s2 r d delete scores EditScore d p r edit scores for division d, player p, round r 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 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) ResultsByRound r1-r2 d rank players based only on rounds r1-r2 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)w 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; } 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 (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 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 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 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 pair_log ($) { print $_[0]; print PAIR $_[0]; } sub CmdShowPairings ($$) { my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: ShowPairings round [division-name]\n"; 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; } open(PAIR, ">$dp->{'name'} pairings") or warn "can't create tee log: $!\n"; &MacPerl'SetFileInfo('MSWD', 'TEXT', "$dp->{'name'} pairings") if defined &MacPerl'SetFileInfo; pair_log "Round $round Pairings for Division $dp->{'name'}:\n\n"; # print "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'}}; pair_log "Table " if defined $tables; pair_log "Board Players\n"; my $datap = $dp->{'data'}; { my %done; my %reserved; my @unreserved; $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) { pair_log ' ' if defined $tables; pair_log sprintf(" %s: UNPAIRED.\n", (TaggedName $p)); } elsif ($opp == 0) { pair_log ' ' if defined $tables; pair_log sprintf(" %s: BYE.\n", (TaggedName $p)); } elsif (!$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]]); } $done{$p->{id}} = 1; } } # 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++; } pair_log sprintf(" %3d ", $tables->[$board]) if defined $tables; pair_log 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; pair_log sprintf(" %3d ", $tables->[$board]) if defined $tables; pair_log sprintf(" %3d %s vs. %s.\n", $board+1, (TaggedName $p), (TaggedName $opp)); } } } 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) { 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\n", (TaggedName $p); printf "Rnd Opp ${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 ${gkNameFormat}", 1+$i, $opp->{'id'}, $opp->{'name'}; } else { printf "%3d %3s ${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 log_wc ($) { print WC $_[0]; print $_[0]; } sub CmdShowWallChart ($$) { my($argvp, $args) = @_; shift @$argvp; my $usage = "Usage: showWallChart [division...]\n"; do { { my $dp = (ParseDivisionName $argvp, $usage); next unless defined $dp; open(WC, ">$dp->{'name'} WC") 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) { next unless defined $p; my $line1 = sprintf("$gkNameFormat ", $p->{'name'}); my $line2 = sprintf("$gkNameFormat ", ''); my $spread = 0; my $wins = 0; { my $j; for $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; $line1 .= sprintf("%5.1f ", $wins); $line2 .= sprintf("%+5d ", $spread); unless ((1+$j) % 12) { log_wc "$line1\n$line2\n"; $line1 = $line2 = sprintf("$gkNameFormat ", ''); } } } # 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; } # TODO: should report round number? print "Current 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; 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; } printf "%4d %4.1f-%4.1f %+5d %4d %s\n", $rank, $wins, $#{$p->{'scores'}}+1-$wins, $spread, $p->{'rating'}, (TaggedName $p) unless $p->{name} =~ /^bye /; } 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 report on player with scoresin round # 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 ne $dp->{'maxp'}) { printf "The only round you can unpair is the last paired one: %d\n", $dp->{'maxp'}+1; return 0; } if ($round le $dp->{'maxs'}) { print "You can't unpair a round that already has scores recorded in it.\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; } 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]; 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) = @_; my $datap = $dp->{'data'}; my $maxp = $dp->{'maxp'}; my @unpaired = (); # first check for an already partially paired round for my $p (@$datap) { push(@unpaired, $p) if $p && !defined $p->{'pairings'}[$maxp]; # if ($p) { my $o = $p->{'pairings'}[$maxp]; print "$p: "; print defined $o ? $o : "undef"; print "\n"; } } # for $p # if we didn't find any in the last round, return complete vector if ($#unpaired < 0) { @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 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 () { 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+//) { eval $_; print "eval: $@\n" if length($@); } 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) = /^([^\d]+[^\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; 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 $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; $maxscores = $nscores if $nscores > $maxscores; 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 = $opp ? $datap->[$opp]{'scores'}[$j] : 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); $wins += (1 + ($thisSpread <=> 0))/2; push(@wins, $wins); } } # for $j $p->{'rspread'} = \@spread; $p->{'rwins'} = \@wins; $p->{'spread'} = $spread; $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->{'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;