git.sesse.net Git - wloh/blob - www/index.pl

   1 #! /usr/bin/perl
   2 use strict;
   3 use warnings;
   4 no warnings qw(once);
   5 use CGI;
   6 use CGI::Carp qw( fatalsToBrowser );
   7 use DBI;
   8 use POSIX;
   9 use Devel::Peek;
  10 use locale;
  11 require '../config.pm';
  12
  13 my $dbh = DBI->connect($config::local_connstr, $config::local_username, $config::local_password)
  14         or die "connect: " . $DBI::errstr;
  15 $dbh->{AutoCommit} = 0;
  16 $dbh->{RaiseError} = 1;
  17
  18 my $trials = 25_000;
  19
  20 binmode STDOUT, ':utf8';
  21
  22 my %players = ();
  23 my %ratings = ();
  24 my @matches = ();
  25 my %parms = ();
  26 my $match_stddev;
  27
  28 sub sanitize {
  29         $_ = shift;
  30         y/ \t\n<>&/_/;
  31         return $_;
  32 }
  33
  34 sub color {
  35         my $x = shift;
  36         return int(255.0 * ($x ** (1.80)));
  37 }
  38
  39 sub make_table {
  40         my $used_ratings = shift;
  41
  42         print <<"EOF";
  43
  44     <table>
  45       <tr>
  46         <th></th>
  47 EOF
  48
  49         POSIX::setlocale(&POSIX::LC_ALL, 'C');
  50
  51         my $tmpnam = POSIX::tmpnam();
  52         open MCCALC, ">", $tmpnam
  53                 or die "$tmpnam: $!";
  54
  55         printf MCCALC "%f\n", $match_stddev;
  56         printf MCCALC "%d\n", scalar keys %players;
  57
  58         for my $id (keys %players) {
  59                 if (exists($used_ratings->{$id})) {
  60                         printf MCCALC "%s %f\n", $id, $used_ratings->{$id};
  61                 } else {
  62                         printf MCCALC "%s %f\n", $id, 1500.0;
  63                 }
  64         }
  65
  66         for my $match (@matches) {
  67                 printf MCCALC "%s %s %d %d\n", $match->[0], $match->[1], $match->[2], $match->[3];
  68         }
  69         close MCCALC;
  70
  71         POSIX::setlocale(&POSIX::LC_ALL, 'nb_NO.UTF-8');
  72
  73         my %prob = ();
  74
  75         open MCCALC, "$config::base_dir/mcwordfeud $trials < $tmpnam |"
  76                 or die "mccalc: $!";
  77         while (<MCCALC>) {
  78                 chomp;
  79                 my @x = split /\s+/;
  80                 my $id = $x[0];
  81                 my $player = $players{$id};
  82                 $prob{$player} = [ @x[1..$#x] ];
  83         }
  84         close MCCALC;
  85         #unlink $tmpnam;
  86
  87         my $num_games = scalar keys %prob;
  88         for my $i (1..$num_games) {
  89                 print "        <th>$i.</th>\n";
  90         }
  91         print "        <th>NEDRYKK</th>\n";
  92         print "      </tr>\n";
  93
  94         for my $player (sort { $a cmp $b } keys %prob) {
  95                 print "      <tr>\n";
  96                 print "        <th>$player</th>\n";
  97
  98                 for my $i (1..$num_games) {
  99                         my $pn = $prob{$player}->[$i - 1] / $trials;
 100
 101                         my $r = color(1.0 - $pn / 3);
 102                         my $g = color(1.0 - $pn / 3);
 103                         my $b = color(1.0);
 104
 105                         if ($i == 1) {
 106                                 ($g, $b) = ($b, $g);
 107                         } elsif ($i >= $num_games - 1) {
 108                                 ($r, $b) = ($b, $r);
 109                         }
 110
 111                         printf "        <td style=\"background-color: rgb($r, $g, $b)\">%.1f%%</td>\n", $pn * 100.0;
 112                 }
 113
 114                 {
 115                         my $pn = ($prob{$player}->[$num_games - 1] + $prob{$player}->[$num_games - 2]) / $trials;
 116
 117                         my $r = color(1.0);
 118                         my $g = color(1.0 - $pn / 3);
 119                         my $b = color(1.0 - $pn / 3);
 120                         printf "        <td style=\"background-color: rgb($r, $g, $b)\">%.1f%%</td>\n", $pn * 100.0;
 121                 }
 122                 print "      </tr>\n";
 123         }
 124
 125         print << "EOF";
 126     </table>
 127 EOF
 128 }
 129
 130 # Get auxillary parameters
 131 my $q = $dbh->prepare('SELECT * FROM ratings WHERE id < 0');
 132 $q->execute;
 133
 134 while (my $ref = $q->fetchrow_hashref) {
 135         $parms{$ref->{'id'}} = $ref->{'rating'};
 136 }
 137 $match_stddev = $parms{-2} * sqrt(2.0);
 138
 139 # Get players and ratings
 140 my $season = 18;
 141 my $division = 1;
 142 my $subdivision = 1;
 143
 144 $q = $dbh->prepare('SELECT fotballdeltagere.id,fotballdeltagere.navn,rating FROM fotballdeltagere JOIN fotballserier ON fotballdeltagere.serie=fotballserier.nr JOIN ratings ON fotballdeltagere.id=ratings.id AND sesong=? AND divisjon=? AND avdeling=?');
 145 $q->execute($season, $division, $subdivision);
 146
 147 while (my $ref = $q->fetchrow_hashref) {
 148         my $id = $ref->{'id'};
 149         $players{$id} = sanitize($ref->{'navn'});
 150         $ratings{$id} = $ref->{'rating'};
 151 }
 152 $q->finish;
 153
 154 $q = $dbh->prepare('
 155 SELECT
 156   d1.id AS p1, d2.id AS p2, maalfor AS score1, maalmot AS score2
 157 FROM fotballresultater r
 158   JOIN fotballserier s ON r.serie=s.nr
 159   JOIN fotballdeltagere d1 ON r.lagrecno=d1.nr AND r.serie=d1.serie
 160   JOIN fotballdeltagere d2 ON r.motstander=d2.nr AND r.serie=d2.serie
 161 WHERE
 162   sesong=? AND divisjon=? AND avdeling=?
 163   AND lagrecno > motstander
 164 ');
 165 $q->execute($season, $division, $subdivision);
 166
 167 while (my $ref = $q->fetchrow_hashref) {
 168         push @matches, [ $ref->{'p1'}, $ref->{'p2'}, $ref->{'score1'}, $ref->{'score2'} ];
 169 }
 170 $q->finish;
 171
 172 POSIX::setlocale(&POSIX::LC_ALL, 'nb_NO.UTF-8');
 173
 174 print CGI->header(-type=>'text/html; charset=utf-8', -expires=>'Thu, 01 Dec 1994 16:00:00 GMT');
 175 printf <<"EOF", $match_stddev;
 176 <html>
 177   <head>
 178     <title>WLoH-plasseringsannsynlighetsberegning</title>
 179     <style type="text/css">
 180 body {
 181         color: black;
 182         background: white;
 183         font-family: sans-serif;
 184 }
 185 table {
 186         border-collapse: collapse;
 187         border: 1px solid black;
 188 }
 189 td, th {
 190         border: 1px solid black;
 191         padding: 5px;
 192 }
 193 td {
 194         text-align: right;
 195 }
 196     </style>
 197   </head>
 198   <body>
 199     <h1>WLoH-plasseringsannsynlighetsberegning</h1>
 200
 201     <p>Beregningen tar ikke hensyn til ujevn spillestyrke, ting som er sagt i forumet e.l.;
 202       den antar at samtlige uspilte kamper trekkes fra en normalfordeling med standardavvik
 203       %.1f poeng. Sannsynlighetene kan summere til andre tall enn 100%% pga. avrunding.
 204       Tallene vil variere litt fra gang til gang fordi utregningen skjer ved randomisering.</p>
 205
 206     <p>Andre divisjoner enn 1. divisjon kommer etter hvert.</p>
 207
 208     <p>Spillerne er sortert etter nick.</p>
 209 EOF
 210
 211 make_table({});
 212
 213 print <<"EOF";
 214     <p>Under er en variant som pr&oslash;ver &aring; ta relativ spillestyrke med i betraktningen.
 215       Disse er basert p&aring; WLoH-data og oppdateres hver hele time (takk til Lobotommy for tilgang!),
 216       men modellen er forel&oslash;pig ikke fullstendig tunet.</p>
 217 EOF
 218
 219 make_table(\%ratings);
 220
 221 print << "EOF";
 222     </table>
 223   </body>
 224 </html>
 225 EOF