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 HTML::Entities;
  11 use Encode;
  12 use utf8;
  13 use locale;
  14 use lib qw(../include);
  15 require 'config.pm';
  16 require 'common.pm';
  17
  18 my $cgi = CGI->new;
  19
  20 my $dbh = DBI->connect($config::local_connstr, $config::local_username, $config::local_password)
  21         or die "connect: " . $DBI::errstr;
  22 $dbh->{AutoCommit} = 0;
  23 $dbh->{RaiseError} = 1;
  24
  25 my $trials = 25_000;
  26
  27 binmode STDOUT, ':utf8';
  28
  29 my %players = ();
  30 my %ratings = ();
  31 my %ratings_stddev = ();
  32 my @matches = ();
  33
  34 sub sanitize {
  35         return HTML::Entities::encode_entities(shift);
  36 }
  37
  38 sub color {
  39         my $x = shift;
  40         return int(255.0 * ($x ** (1.80)));
  41 }
  42
  43 sub get_divisions {
  44         my ($dbh, $locale, $season) = @_;
  45
  46         my @divisions = ();
  47
  48         my $q = $dbh->prepare('SELECT DISTINCT(divisjon) FROM fotballserier se JOIN fotballspraak sp ON se.spraak=sp.id WHERE kultur=? AND sesong=? ORDER BY divisjon');
  49         $q->execute($locale, $season);
  50
  51         while (my $ref = $q->fetchrow_hashref) {
  52                 push @divisions, $ref->{'divisjon'};
  53         }
  54
  55         return @divisions;
  56 }
  57
  58 sub get_subdivisions {
  59         my ($dbh, $locale, $season, $division) = @_;
  60
  61         my @subdivisions = ();
  62
  63         my $q = $dbh->prepare('SELECT DISTINCT(avdeling) FROM fotballserier se JOIN fotballspraak sp ON se.spraak=sp.id WHERE kultur=? AND sesong=? AND divisjon=? ORDER BY avdeling');
  64         $q->execute($locale, $season, $division);
  65
  66         while (my $ref = $q->fetchrow_hashref) {
  67                 push @subdivisions, $ref->{'avdeling'};
  68         }
  69
  70         return @subdivisions;
  71 }
  72
  73 sub get_division_selector {
  74         my ($divisions, $division) = @_;
  75
  76         my @ret = ();
  77         for my $d (@$divisions) {
  78                 my $parms = {
  79                         'option' => $d,
  80                         'option/value' => $d,
  81                 };
  82                 $parms->{'option/selected'} = 'selected' if ($d == $division);
  83                 push @ret, $parms;
  84         }
  85         return \@ret;
  86 }
  87
  88 sub get_players_and_ratings {
  89         my ($dbh, $locale, $season, $division, $subdivision) = @_;
  90
  91         my $q = $dbh->prepare('SELECT fotballdeltagere.id,fotballdeltagere.navn,rating,rating_stddev FROM fotballdeltagere JOIN fotballserier ON fotballdeltagere.serie=fotballserier.nr NATURAL JOIN spiller_kultur LEFT JOIN ratings ON fotballdeltagere.id=ratings.id WHERE kultur=? AND sesong=? AND divisjon=? AND avdeling=?');
  92         $q->execute($locale, $season, $division, $subdivision);
  93
  94         while (my $ref = $q->fetchrow_hashref) {
  95                 my $id = $ref->{'id'};
  96                 $players{$id} = sanitize(Encode::decode_utf8($ref->{'navn'}));
  97                 $ratings{$id} = $ref->{'rating'};
  98                 $ratings_stddev{$id} = $ref->{'rating_stddev'};
  99         }
 100         $q->finish;
 101 }
 102
 103 sub get_matches {
 104         my ($dbh, $locale, $season, $division, $subdivision) = @_;
 105
 106         my @matches = ();
 107         my $q = $dbh->prepare('
 108         SELECT
 109           d1.id AS p1, d2.id AS p2, maalfor AS score1, maalmot AS score2
 110         FROM ( SELECT * FROM fotballresultater UNION ALL SELECT * FROM fotballresultater_2123 ) r
 111           JOIN fotballserier s ON r.serie=s.nr
 112           JOIN fotballspraak sp ON s.spraak=sp.id
 113           JOIN fotballdeltagere d1 ON r.lagrecno=d1.nr AND r.serie=d1.serie
 114           JOIN fotballdeltagere d2 ON r.motstander=d2.nr AND r.serie=d2.serie
 115         WHERE
 116           kultur=? AND sesong=? AND divisjon=? AND avdeling=?
 117           AND lagrecno > motstander
 118         ');
 119         $q->execute($locale, $season, $division, $subdivision);
 120
 121         while (my $ref = $q->fetchrow_hashref) {
 122                 push @matches, [ $ref->{'p1'}, $ref->{'p2'}, $ref->{'score1'}, $ref->{'score2'} ];
 123         }
 124         $q->finish;
 125
 126         return @matches;
 127 }
 128
 129 sub get_covariance_matrix {
 130         my ($dbh, @players) = @_;
 131
 132         my $player_sql = '{' . join(',', @players ) . '}';
 133         my $q = $dbh->prepare('SELECT * FROM covariance WHERE player1=ANY(?::smallint[]) AND player2=ANY(?::smallint[])', { pg_prepare_now => 0 });
 134         $q->execute($player_sql, $player_sql);
 135
 136         my $cov = {};
 137         while (my $ref = $q->fetchrow_hashref) {
 138                 $cov->{$ref->{'player1'}}{$ref->{'player2'}} = $ref->{'cov'};
 139         }
 140
 141         return $cov;
 142 }
 143
 144 sub write_parms_to_file {
 145         my ($aux_parms, $match_stddev, $used_ratings, $used_cov) = @_;
 146
 147         POSIX::setlocale(&POSIX::LC_ALL, 'nb_NO.UTF-8');
 148
 149         my @sorted_players = sort { $players{$a} cmp $players{$b} } keys %players;
 150
 151         POSIX::setlocale(&POSIX::LC_ALL, 'C');
 152
 153         my $tmpnam = POSIX::tmpnam();
 154         open MCCALC, ">", $tmpnam
 155                 or die "$tmpnam: $!";
 156
 157         printf MCCALC "%f\n", $match_stddev;
 158         printf MCCALC "%d\n", scalar keys %players;
 159
 160         for my $id (@sorted_players) {
 161                 my $rating = $used_ratings->{$id} // 500.0;
 162                 printf MCCALC "%s %f\n", $id, $rating;
 163         }
 164
 165         # covariance matrix
 166         for my $id1 (keys %players) {
 167                 for my $id2 (keys %players) {
 168                         if ($id1 == $id2) {
 169                                 printf MCCALC "%f ", ($used_cov->{$id1}{$id2} // $aux_parms->{'rating_prior_stddev'});
 170                         } else {
 171                                 printf MCCALC "%f ", ($used_cov->{$id1}{$id2} // 0.0);
 172                         }
 173                 }
 174                 printf MCCALC "\n";
 175         }
 176
 177         for my $match (@matches) {
 178                 printf MCCALC "%s %s %d %d\n", $match->[0], $match->[1], $match->[2], $match->[3];
 179         }
 180         close MCCALC;
 181
 182         POSIX::setlocale(&POSIX::LC_ALL, 'nb_NO.UTF-8');
 183
 184         return $tmpnam;
 185 }
 186
 187 sub make_table {
 188         my ($locale, $aux_parms, $match_stddev, $lowest_division, $used_ratings, $used_cov, $division, $subdivision, $table_id) = @_;
 189
 190         my $tmpnam = write_parms_to_file($aux_parms, $match_stddev, $used_ratings, $used_cov);
 191         my %prob = ();
 192
 193         open MCCALC, "$config::base_dir/mcwordfeud $trials < $tmpnam |"
 194                 or die "mccalc: $!";
 195         while (<MCCALC>) {
 196                 chomp;
 197                 my @x = split /\s+/;
 198                 my $id = $x[0];
 199                 my $player = sprintf "%s (%.0f ± %.0f)", $players{$id}, ($ratings{$id} // 500.0), ($ratings_stddev{$id} // $aux_parms->{'rating_prior_stddev'});
 200                 $prob{$player} = [ @x[1..$#x] ];
 201         }
 202         close MCCALC;
 203         unlink $tmpnam;
 204
 205         my $num_games = scalar keys %prob;
 206
 207         # Make list of ranks.
 208         my @ranks = ();
 209         for my $i (1..$num_games) {
 210                 push @ranks, { 'th' => "$i." };
 211         }
 212         push @ranks, { 'th' => 'NEDRYKK' } unless ($lowest_division);
 213
 214         my @players = ();
 215
 216         my $pnum = 0;
 217         for my $player (sort { $a cmp $b } keys %prob) {
 218                 ++$pnum;
 219
 220                 my @player_ranks = ();
 221
 222                 for my $i (1..$num_games) {
 223                         my $pn = $prob{$player}->[$i - 1] / $trials;
 224
 225                         my $r = color(1.0 - $pn / 3);
 226                         my $g = color(1.0 - $pn / 3);
 227                         my $b = color(1.0);
 228
 229                         if ($i == 1) {
 230                                 ($g, $b) = ($b, $g);
 231                         } elsif ($i >= $num_games - 1 && !$lowest_division) {
 232                                 ($r, $b) = ($b, $r);
 233                         }
 234
 235                         my $num_total_games = ($num_games * ($num_games - 1)) / 2;
 236                         if (scalar @matches == $num_total_games || $prob{$player}->[$i - 1] == $trials) {
 237                                 push @player_ranks, {
 238                                         'td/style' => "background-color: rgb($r, $g, $b)",
 239                                         'td' => sprintf("%.1f%%", $pn * 100.0),
 240                                         'link' => ''
 241                                 };
 242                         } else {
 243                                 push @player_ranks, {
 244                                         'td/style' => "background-color: rgb($r, $g, $b)",
 245                                         'a' => sprintf("%.1f%%", $pn * 100.0),
 246                                         'a/href' => "javascript:showScenario('$table_id', '/$locale/?divisjon=$division;avdeling=$subdivision;spiller=$pnum;posisjon=$i')"
 247                                 };
 248                         }
 249                 }
 250
 251                 unless ($lowest_division) {
 252                         my $pn = ($prob{$player}->[$num_games - 1] + $prob{$player}->[$num_games - 2]) / $trials;
 253
 254                         my $r = color(1.0);
 255                         my $g = color(1.0 - $pn / 3);
 256                         my $b = color(1.0 - $pn / 3);
 257                         push @player_ranks, {
 258                                 'td/style' => "background-color: rgb($r, $g, $b)",
 259                                 'td' => sprintf("%.1f%%", $pn * 100.0),
 260                                 'link' => ''
 261                         };
 262                 }
 263                 push @players, {
 264                         'player' => $player,
 265                         'player-ranks' => \@player_ranks
 266                 };
 267         }
 268
 269         return {
 270                 'ranks' => \@ranks,
 271                 'tbody' => \@players,
 272         };
 273 }
 274
 275 sub make_cov_table {
 276         my ($cov) = @_;
 277         my @players = (sort { $players{$a} cmp $players{$b} } keys %players);
 278
 279         my @player_list = ();
 280         for my $player (@players) {
 281                 push @player_list, { 'th' => $players{$player} };
 282         }
 283
 284         my @player_rows = ();
 285         for my $player (@players) {
 286                 my @elements = ();
 287                 for my $player2 (@players) {
 288                         my $c = sprintf("%.2f", $cov->{$player}{$player2});
 289                         push @elements, { 'td' => $c };
 290                 }
 291                 push @player_rows, {
 292                         '#player' => $players{$player},
 293                         'elements' => \@elements
 294                 };
 295         }
 296
 297         return {
 298                 'player-list' => \@player_list,
 299                 'tbody' => \@player_rows
 300         };
 301 }
 302
 303 sub find_avg_rating {
 304         my ($ratings) = shift;
 305
 306         my $sum_rating = 0.0;
 307         for my $r (values %$ratings) {
 308                 $sum_rating += ($r // 500.0);
 309         }
 310         return $sum_rating / scalar keys %$ratings;
 311 }
 312
 313 sub print_header {
 314         my ($cgi, $title) = @_;
 315         print $cgi->header(-type=>'text/html; charset=utf-8', -expires=>'now');
 316         print <<"EOF";
 317 <?xml version="1.0" encoding="UTF-8" ?>
 318 <!DOCTYPE
 319   html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
 320   "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
 321 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="no">
 322   <head>
 323     <title>$title</title>
 324     <link rel="stylesheet" href="style" type="text/css" />
 325   </head>
 326   <body>
 327 EOF
 328 }
 329
 330 sub print_footer {
 331         print <<"EOF";
 332   </body>
 333 </html>
 334 EOF
 335 }
 336
 337 my $locale = wloh_common::get_locale($cgi);
 338 my $aux_parms = wloh_common::get_auxillary_parameters($dbh, $locale);
 339 my $match_stddev = $aux_parms->{'score_stddev'} * sqrt(2.0);
 340
 341 my $division = $cgi->param('divisjon') // -1;
 342 my $subdivision = $cgi->param('avdeling') // -1;
 343 my $match_player = $cgi->param('spiller');
 344 my $match_position = $cgi->param('posisjon');
 345
 346 my $season = wloh_common::get_max_season($dbh, $locale);
 347 die "Nonexistent locale!" if (!defined($season));
 348
 349 my @divisions = get_divisions($dbh, $locale, $season);
 350 $division = $divisions[0] if (!grep { $_ == $division } @divisions);
 351 my @subdivisions = get_subdivisions($dbh, $locale, $season, $division);
 352 $subdivision = $subdivisions[0] if (!grep { $_ == $subdivision } @subdivisions);
 353
 354 get_players_and_ratings($dbh, $locale, $season, $division, $subdivision);
 355 @matches = get_matches($dbh, $locale, $season, $division, $subdivision);
 356 my $cov = get_covariance_matrix($dbh, keys %players);
 357
 358 if (defined($match_player) && defined($match_position)) {
 359         my $tmpnam = write_parms_to_file($aux_parms, $match_stddev, \%ratings, $cov);
 360
 361         --$match_player;
 362         --$match_position;
 363
 364         my @scenario = ();
 365         open MCCALC, "$config::base_dir/mcwordfeud $trials $match_player $match_position < $tmpnam |"
 366                 or die "mccalc: $!";
 367         while (<MCCALC>) {
 368                 /(\d+) (\d+) (-?\d+)/ or next;
 369                 chomp;
 370                 push @scenario, {
 371                         'player-1' => $players{$1},
 372                         'player-2' => $players{$2},
 373                         'result' => sprintf("%+d", $3),
 374                 };
 375         }
 376         close MCCALC;
 377         unlink $tmpnam;
 378
 379         my @sorted_players = sort { $players{$a} cmp $players{$b} } keys %players;
 380         my $player_name = $players{$sorted_players[$match_player]};
 381
 382         if (scalar @scenario == 0) {
 383                 print CGI->header(-type=>'text/html; charset=utf-8', -expires=>'+5m');
 384                 wloh_common::process_template('scenario-not-found.xml', {
 385                         '#nick' => $player_name,
 386                         '#rank' => sprintf("%d.", $match_position + 1)
 387                 });
 388         } else {
 389                 print CGI->header(-type=>'text/html; charset=utf-8', -expires=>'+5m');
 390                 wloh_common::process_template('scenario.xml', {
 391                         '#nick' => $player_name,
 392                         '#rank' => sprintf("%d.", $match_position + 1),
 393                         '#results' => \@scenario
 394                 });
 395         }
 396 } else {
 397         POSIX::setlocale(&POSIX::LC_ALL, 'nb_NO.UTF-8');
 398
 399         my $max_division = $divisions[$#divisions];
 400         my $lowest_division = ($division == $max_division);
 401         my $basic_table = make_table($locale, $aux_parms, $match_stddev, $lowest_division, {}, {}, $division, $subdivision, 'scenario1');
 402         my $adjusted_table = make_table($locale, $aux_parms, $match_stddev, $lowest_division, \%ratings, $cov, $division, $subdivision, 'scenario2');
 403         my $cov_table = (defined($cgi->param('showcov'))) ? make_cov_table($cov) : '';
 404
 405         my $avg_rating = find_avg_rating(\%ratings);
 406
 407         print CGI->header(-type=>'text/html; charset=utf-8', -expires=>'+5m');
 408         wloh_common::process_template('index.xml', {
 409                 '#navbar' => wloh_common::get_navbar($cgi, $dbh, $locale),
 410                 '#division-selector/action' => "/$locale/",
 411                 '#division' => get_division_selector(\@divisions, $division),
 412                 '#subdivision' => get_division_selector(\@subdivisions, $subdivision),
 413                 '#basic-probabilities' => $basic_table,
 414                 '#adjusted-probabilities' => $adjusted_table,
 415                 'cov-table' => $cov_table,
 416                 'match-stddev' => sprintf("%.1f", $match_stddev),
 417                 '#average-rating' => sprintf("%.1f", $avg_rating),
 418                 'last-sync' => wloh_common::get_last_sync($dbh),
 419         });
 420 }
 421