#!/usr/bin/perl

use strict;
use warnings;
use CGI;
my $q = new CGI;                        # create new CGI object
print $q->header;                   # create the HTTP header


# The following statistics are from
# http://www.fifa.com/en/mens/statistics/index/0,2548,All-May-2006,00.
+html

my %FIFA_points =
  ("Brazil"              => 827,
   "Czech Republic"      => 772,
   "Holland"             => 768,
   "Mexico"              => 758,
   "Spain"               => 756,
   "USA"                 => 756,
   "Portugal"            => 750,
   "France"              => 749,
   "Argentina"           => 746,
   "England"             => 741,
   "Italy"               => 728,
   "Sweden"              => 709,
   "Japan"               => 705,
   "Germany"             => 696,
   "Tunisia"             => 693,
   "Iran"                => 686,
   "Croatia"             => 686,
   "Costa Rica"          => 683,
   "Poland"              => 677,
   "South Korea"         => 677,
   "Ivory Coast"         => 669,
   "Paraguay"            => 653,
   "Saudi Arabia"        => 651,
   "Switzerland"         => 648,
   "Ecuador"             => 631,
   "Australia"           => 612,
   "Serbia & Montenegro" => 610,
   "Ukraine"             => 609,
   "Trinidad & Tobago"   => 604,
   "Ghana"               => 600,
   "Angola"              => 581,
   "Togo"                => 569
  );

my %groups =
 (A => ["Germany",     "Costa Rica",     "Poland",              "Ecuad
+or"],
  B => ["England",     "Paraguay",       "Trinidad & Tobago",   "Swede
+n"],
  C => ["Argentina",   "Ivory Coast",    "Serbia & Montenegro", "Holla
+nd"],
  D => ["Mexico",      "Iran",           "Angola",              "Portu
+gal"],
  E => ["USA",         "Czech Republic", "Italy",               "Ghana
+"],
  F => ["Australia",   "Japan",          "Brazil",              "Croat
+ia"],
  G => ["South Korea", "Togo",           "France",              "Switz
+erland"],
  H => ["Spain",       "Ukraine",        "Tunisia",             "Saudi
+ Arabia"]
 );

my @combinations = ([0, 1], [2, 3], [0, 2], [3, 1], [3, 0], [1, 2]);
my %pts;
my %for;
my %against;

print qq~
<hr>
<h1> World Cup Results Generator</h1>
<ul>
<li><A href='#results'>Results</a></li>
<li><A href='#standings'>Standings</a></li>
</ul>
~;
print "\n<A name='results'>";
for ("A" .. "H") {
  print "\n<hr><h2>Group $_:</h2>\n";
  my $group = $groups{$_};
  foreach (@combinations) {
    my $a = $group->[$_->[0]];
    my $b = $group->[$_->[1]];
    my $home_advantage = $FIFA_points{$a} - $FIFA_points{$b};
    my $score = get_score($home_advantage);
    print "<br>$a vs $b ($score)\n";
    calc_points($a, $b, $score);
    
  }
}

print "\n<A name='standings'>";
for ("A" .. "H") {
  
  my $groupname = $_;
  my $group = $groups{$_};
  
  my @list = ();
  my $team;
  foreach $team (@$group) {
    my $pts_total = $pts{$team};
    my $gf = $for{$team};
    my $ga = $against{$team};
    my $diff = $gf - $ga;
    $diff = $diff / 100 + ($gf / 1000);
    my $adj_pts = $pts_total + $diff;
    my $string = sprintf("%02.4f|%02d|$team|$gf|$ga", $adj_pts,$pts_to
+tal);
    push(@list, $string);
  }
  my @list2 = sort(@list);
  @list2 = reverse(@list2);
  
  show_group($groupname, \@list2);
}

$q->end_html;

sub show_group {
  my $name = shift;
  my $reflist = shift;
  
  print "\n<hr><h2>Standings: Group $name</h2>";
  #print @$reflist;
  print "<table border='0' width='500'><tr><td><b>Team</b></td><td><b>
+F</b></td><td><b>A</b></td><td><b>Pts</b></td>";
  foreach (@$reflist) {
    my($adj, $pts, $team, $gf, $ga) = split(/\|/, $_);
    print "\n<tr> <td>$team</td>";
    printf("<td>%2d</td><td>%2d</td><td>%2d</td></tr>", $gf, $ga, $pts
+);
  
  }
  print "</table>";

}

sub calc_points {
  my $hm = shift;
  my $aw = shift;
  my $score = shift;
  my($hg, $ag) = split(/\-/, $score, 2);
  if($hg > $ag) {
    add_pts($hm, 3);
  }
  elsif($ag > $hg) {
    add_pts($aw, 3);
  }
  else {
    add_pts($aw, 1);
    add_pts($hm, 1);
  }
  update_gd($hm, $hg, $ag);
  update_gd($aw, $ag, $hg);
}

sub add_pts {
  my $tm = shift;
  my $pts = shift;
  
  my $tot = $pts{$tm} || 0;
  $tot += $pts;
  $pts{$tm} = $tot;

}

sub update_gd {
  my $tm = shift;
  my $f = shift;
  my $a = shift;
  
  my $gf = $for{$tm} || 0;
  my $ga = $against{$tm} || 0;
  
  $gf += $f;
  $for{$tm} = $gf;
  
  $ga += $a;
  $against{$tm} = $ga;
}

sub get_score {
  my ($points_diff) = @_;
  my $score = 0;
  my $other = 0;
  if (abs $points_diff <= 30) {
    $score = 0;
  }
  elsif (abs $points_diff <= 80) {
    $score = 1;
  }
  elsif (abs $points_diff <= 130) {
    $score = 2;
  }
  elsif (abs $points_diff <= 200) {
    $score = 3;
  }
  else {
    $score = 4;
  }

  my $random_factor = rand;
  if ($random_factor > 0.85) {
    $score += 2;
    $other += 2;
  }
  elsif ($random_factor <= 0.95 and $random_factor > 0.60) {
    $score += 1;
    $other += 1;
  }
  
  
  
  if($random_factor > 0.95) {
    # a surprise result
    my $var = rand();
    if($var > 0.5) {
      $other = 1;
      $score = 0;
    }
    else {
      $score = 1;
      $other = 0;
    } 
  
  }

  if ($points_diff == abs $points_diff) {
    return "${score}-${other}";
  }
  else {
    return "${other}-${score}";
  }
}
[download]

definitely perlmoth++ btw... :)