screp

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use Data::Dumper;
   5
   6 our $VERSION = '1.01';
   7
   8 my $SHOWWARN = 0;
   9 my $APMSVG = undef;
  10 my $DBNAME = undef;
  11 my $DBGAME = undef;
  12
  13 use Getopt::Long qw(:config bundling auto_version auto_help);
  14 GetOptions(
  15         "verbose|v!" => \$SHOWWARN,
  16         "apm|a=s" => \$APMSVG,
  17         "dbname|D=s" => \$DBNAME,
  18         "dbid|d=s" => \$DBGAME,
  19 );
  20
  21 use constant { APM_FIRSTFRAME => 80 / .042 };
  22
  23 {
  24
  25 package Data::StarCraft::Replay;
  26
  27 use Data::Dumper;
  28
  29 use constant {
  30         CMD_REPEAT => 4,
  31 };
  32
  33 my %build = (
  34         0x19 => "morph",
  35         0x1E => "build",
  36         0x1F => "warp",
  37         0x24 => "add-on",
  38         0x2E => "evolve",
  39         0x47 => "land",
  40 );
  41 my %unit = (
  42         0x00 => "Marine",
  43         0x01 => "Ghost",
  44         0x02 => "Vulture",
  45         0x03 => "Goliath",
  46         #               undef,
  47         0x05 => "Siege Tank",
  48         #               undef,
  49         0x07 => "SCV",
  50         0x08 => "Wraith",
  51         0x09 => "Science Vessel",
  52         #               undef,
  53         0x0B => "Dropship",
  54         0x0C => "Battlecruiser",
  55         #               undef,
  56         0x0E => "Nuke",
  57         #               (undef) x 0x11,
  58         0x20 => "Firebat",
  59         #               undef,
  60         0x22 => "Medic",
  61         #               undef,
  62         #               undef,
  63         0x25 => "Zergling",
  64         0x26 => "Hydralisk",
  65         0x27 => "Ultralisk",
  66         #               undef,
  67         0x29 => "Drone",
  68         0x2A => "Overlord",
  69         0x2B => "Mutalisk",
  70         0x2C => "Guardian",
  71         0x2D => "Queen",
  72         0x2E => "Defiler",
  73         0x2F => "Scourge",
  74         #               undef,
  75         #               undef,
  76         0x32 => "Infested Terran",
  77         #               (undef) x 7,
  78         0x3A => "Valkyrie",
  79         #               undef,
  80         0x3C => "Corsair",
  81         0x3D => "Dark Templar",
  82         0x3E => "Devourer",
  83         #               undef,
  84         0x40 => "Probe",
  85         0x41 => "Zealot",
  86         0x42 => "Dragoon",
  87         0x43 => "High Templar",
  88         #               undef,
  89         0x45 => "Shuttle",
  90         0x46 => "Scout",
  91         0x47 => "Arbiter",
  92         0x48 => "Carrier",
  93         #               (undef) x 0x0A,
  94         0x53 => "Reaver",
  95         0x54 => "Observer",
  96         #               (undef) x 0x12,
  97         0x67 => "Lurker",
  98         #               undef,
  99         #               undef,
 100         0x6A => "Command Center",
 101         0x6B => "ComSat",
 102         0x6C => "Nuclear Silo",
 103         0x6D => "Supply Depot",
 104         0x6E => "Refinery", # refinery?
 105         0x6F => "Barracks",
 106         0x70 => "Academy", # Academy?
 107         0x71 => "Factory",
 108         0x72 => "Starport",
 109         0x73 => "Control Tower",
 110         0x74 => "Science Facility",
 111         0x75 => "Covert Ops",
 112         0x76 => "Physics Lab",
 113         #               undef,
 114         0x78 => "Machine Shop",
 115         #               undef,
 116         0x7A => "Engineering Bay",
 117         0x7B => "Armory",
 118         0x7C => "Missile Turret",
 119         0x7D => "Bunker",
 120         #               (undef) x 4,
 121         0x82 => "Infested CC",
 122         0x83 => "Hatchery",
 123         0x84 => "Lair",
 124         0x85 => "Hive",
 125         0x86 => "Nydus Canal",
 126         0x87 => "Hydralisk Den",
 127         0x88 => "Defiler Mound",
 128         0x89 => "Greater Spire",
 129         0x8A => "Queens Nest",
 130         0x8B => "Evolution Chamber",
 131         0x8C => "Ultralisk Cavern",
 132         0x8D => "Spire",
 133         0x8E => "Spawning Pool",
 134         0x8F => "Creep Colony",
 135         0x90 => "Spore Colony",
 136         #               undef,
 137         0x92 => "Sunken Colony",
 138         #               undef,
 139         #               undef,
 140         0x95 => "Extractor",
 141         #               (undef) x 4,
 142         0x9A => "Nexus",
 143         0x9B => "Robotics Facility",
 144         0x9C => "Pylon",
 145         0x9D => "Assimilator",
 146         #               undef,
 147         0x9F => "Observatory",
 148         0xA0 => "Gateway",
 149         #               undef,
 150         0xA2 => "Photon Cannon",
 151         0xA3 => "Citadel of Adun",
 152         0xA4 => "Cybernetics Core",
 153         0xA5 => "Templar Archives",
 154         0xA6 => "Forge",
 155         0xA7 => "Stargate",
 156         #               undef,
 157         0xA9 => "Fleet Beacon",
 158         0xAA => "Arbiter Tribunal",
 159         0xAB => "Robotics Support Bay",
 160         0xAC => "Shield Battery",
 161         #               (undef) x 0x14,
 162         0xC0 => "Larva",
 163         0xC1 => "Rine/Bat",
 164         0xC2 => "Dark Archon",
 165         0xC3 => "Archon",
 166         0xC4 => "Scarab",
 167         0xC5 => "Interceptor",
 168         0xC6 => "Interceptor/Scarab",
 169 );
 170 my @upgrade = (
 171         "Terran Infantry Armor",
 172         "Terran Vehicle Plating",
 173         "Terran Ship Plating",
 174         "Zerg Carapace",
 175         "Zerg Flyer Carapace",
 176         "Protoss Ground Armor",
 177         "Protoss Air Armor",
 178         "Terran Infantry Weapons",
 179         "Terran Vehicle Weapons",
 180         "Terran Ship Weapons",
 181         "Zerg Melee Attacks",
 182         "Zerg Missile Attacks",
 183         "Zerg Flyer Attacks",
 184         "Protoss Ground Weapons",
 185         "Protoss Air Weapons",
 186         "Protoss Plasma Shields",
 187         # 0x10
 188         "U-238 Shells (Marine Range)",
 189         "Ion Thrusters (Vulture Speed)",
 190         undef,
 191         "Titan Reactor (Science Vessel Energy)",
 192         "Ocular Implants (Ghost Sight)",
 193         "Moebius Reactor (Ghost Energy)",
 194         "Apollo Reactor (Wraith Energy)",
 195         "Colossus Reactor (Battle Cruiser Energy)",
 196         "Ventral Sacs (Overlord Transport)",
 197         "Antennae (Overlord Sight)",
 198         "Pneumatized Carapace (Overlord Speed)",
 199         "Metabolic Boost (Zergling Speed)",
 200         "Adrenal Glands (Zergling Attack)",
 201         "Muscular Augments (Hydralisk Speed)",
 202         "Grooved Spines (Hydralisk Range)",
 203         "Gamete Meiosis (Queen Energy)",
 204         # 0x20
 205         "Defiler Energy",
 206         "Singularity Charge (Dragoon Range)",
 207         "Leg Enhancement (Zealot Speed)",
 208         "Scarab Damage",
 209         "Reaver Capacity",
 210         "Gravitic Drive (Shuttle Speed)",
 211         "Sensor Array (Observer Sight)",
 212         "Gravitic Booster (Observer Speed)",
 213         "Khaydarin Amulet (Templar Energy)",
 214         "Apial Sensors (Scout Sight)",
 215         "Gravitic Thrusters (Scout Speed)",
 216         "Carrier Capacity",
 217         "Khaydarin Core (Arbiter Energy)",
 218         undef,
 219         undef,
 220         "Argus Jewel (Corsair Energy)",
 221         # 0x30
 222         undef,
 223         "Argus Talisman (Dark Archon Energy)",
 224         "Caduceus Reactor (Medic Energy)",
 225         "Chitinous Plating (Ultralisk Armor)",
 226         "Anabolic Synthesis (Ultralisk Speed)",
 227         "Charon Boosters (Goliath Range)",
 228 );
 229 my @research = (
 230         "Stim Pack",
 231         "Lockdown",
 232         "EMP Shockwave",
 233         "Spider Mines",
 234         undef,
 235         "Siege Tank",
 236         undef,
 237         "Irradiate",
 238         "Yamato Gun",
 239         "Cloaking Field (wraith)",
 240         "Personal Cloaking (ghost)",
 241         "Burrow",
 242         undef,
 243         "Spawn Broodling",
 244         undef,
 245         "Plague",
 246         # 0x10
 247         "Consume",
 248         "Ensnare",
 249         undef,
 250         "Psionic Storm",
 251         "Hallucination",
 252         "Recall",
 253         "Stasis Field",
 254         undef,
 255         "Restoration",
 256         "Disruption Web",
 257         undef,
 258         "Mind Control",
 259         undef,
 260         undef,
 261         "Optical Flare",
 262         "Maelstrom",
 263         # 0x20
 264         "Lurker Aspect",
 265 );
 266 my %action = (
 267         0x00 => "Move",
 268         0x02 => "Unallowed Move?",
 269         0x06 => "Force move",
 270         0x08 => "Attack",
 271         0x09 => "Gather",
 272         0x0E => "Attack Move",
 273         0x13 => "Failed Casting (?)",
 274         0x17 => "#23 (?)",
 275         0x1B => "Infest CC",
 276         0x22 => "Repair",
 277         0x27 => "Clear Rally",
 278         0x28 => "Set Rally",
 279         0x4F => "Gather",
 280         0x50 => "Gather",
 281         0x70 => "Unload",
 282         0x71 => "Yamato",
 283         0x73 => "Lockdown",
 284         0x77 => "Dark Swarm",
 285         0x78 => "Parasite",
 286         0x79 => "Spawn Broodling",
 287         0x7A => "EMP",
 288         0x7E => "Launch Nuke",
 289         0x84 => "Lay Mine",
 290         0x8B => "ComSat Scan",
 291         0x8D => "Defense Matrix",
 292         0x8E => "Psionic Storm",
 293         0x8F => "Recall",
 294         0x90 => "Plague",
 295         0x91 => "Consume",
 296         0x92 => "Ensnare",
 297         0x93 => "Stasis",
 298         0x94 => "Hallucination",
 299         0x98 => "Patrol",
 300         0xB1 => "Heal",
 301         0xB4 => "Restore",
 302         0xB5 => "Disruption Web",
 303         0xB6 => "Mind Control",
 304         0xB8 => "Feedback",
 305         0xB9 => "Optic Flare",
 306         0xBA => "Maelstrom",
 307         0xC0 => "Irradiate",
 308 );
 309
 310 my %cmdread = (
 311         0x09 => ["select", 1, 2 | CMD_REPEAT],
 312         0x0A => ["add", 1, 2 | CMD_REPEAT],
 313         0x0B => ["deselect", 1, 2 | CMD_REPEAT],
 314         0x0C => ["build", 1, \%build, 2, 2, 2, \%unit],
 315         0x0D => ["vision", 2],
 316         0x0E => ["ally", 2, 2],
 317         0x13 => ["hotkey", 1, [qw"assign select"], 1],
 318         0x14 => ["move", 2, 2, 2, 2, 1], # 1 = queued?
 319         0x15 => ["action", 2, 2, 2, 2, 1, \%action, 1, [qw"normal queued"]],
 320         0x18 => ["cancel"],
 321         0x19 => ["cancel hatch"],
 322         0x1A => ["stop", 1],
 323 #       0x1B => ["move-thing??"], # tim: after hotkey (unit, reaver??) select; soon after reselected and moved
 324         0x1E => ["return cargo", 1],
 325         0x1F => ["train", 2, \%unit],
 326         0x20 => ["cancel train", 2], # == 254
 327         0x21 => ["cloak", 1],
 328         0x22 => ["decloak", 1],
 329         0x23 => ["hatch", 2, \%unit],
 330         0x25 => ["unsiege", 1],
 331         0x26 => ["siege", 1],
 332         0x27 => ["arm", 0], # scarab/interceptor
 333         0x28 => ["unload all", 1],
 334         0x29 => ["unload", 2],
 335         0x2A => ["merge archon", 0],
 336         0x2B => ["hold position", 1],
 337         0x2C => ["burrow", 1],
 338         0x2D => ["unburrow", 1],
 339         0x2E => ["cancel nuke", 0],
 340         0x2F => ["lift", 2, 2],
 341         0x30 => ["research", 1, \@research],
 342         0x31 => ["cancel research", 0],
 343         0x32 => ["upgrade", 1, \@upgrade],
 344 #       0x33 => ["forge-thing??"], # right after forge select: probably unpowered, iirc cancel research
 345         0x35 => ["morph", 2, \%unit],
 346         0x36 => ["stim", 0],
 347         0x57 => ["part", 1, {qw"1 quit  6 drop"}],
 348         0x5A => ["merge dark archon", 0],
 349 );
 350
 351 sub new {
 352         my ($class) = @_;
 353         bless [], $class;
 354 }
 355
 356 sub _read {
 357         my $self = shift;
 358         my ($fh, $size, $seek) = @_;
 359         seek *$fh, $seek, 0 if $seek;
 360         read(*$fh, my $in, $size) eq $size or return undef;
 361         return $in;
 362 }
 363
 364 sub open {
 365         my $self = shift;
 366         my ($file) = @_;
 367
 368         while (not eof $file) {
 369                 local $_ = $self->_read($file, 5)
 370                         and my ($time, $size) = unpack "VC", $_
 371                         or die "Couldn't read time block head\n";
 372                 local $_ = $self->_read($file, $size)
 373                         and my @block = unpack "C*", $_
 374                         or die "Couldn't read time block data\n";
 375                 while (@block) {
 376                         my $player = shift @block;
 377                         my $cmd = shift @block;
 378                         if (not defined $cmdread{$cmd}) {
 379                                 warn sprintf "command #%X not defined: %d bytes ignored\n",
 380                                         $cmd, scalar @block;
 381                                 push @$self, [$time, $player, "??? $cmd"] if $SHOWWARN;
 382                                 last;
 383                         }
 384
 385                         sub readbyte {
 386                                 my ($data, $byte) = @_;
 387                                 my $out = shift @$data;
 388                                 if (($byte & 3) == 2) {
 389                                         @$data ? ($out += shift(@$data) << 8)
 390                                                 : warn "high byte not present\n";
 391                                 }
 392                                 return $out;
 393                         }
 394
 395                         my @format = @{ $cmdread{$cmd} };
 396                         my $desc = shift @format;
 397                         my @data;
 398                         for my $bit (@format) {
 399                                 if (ref $bit) {
 400                                         if (ref $bit eq "ARRAY") {
 401                                                 $data[-1] = defined $bit->[$data[-1]] ? $bit->[$data[-1]]
 402                                                         : "? ($data[-1])";
 403                                         } else {
 404                                                 $data[-1] = defined $bit->{$data[-1]} ? $bit->{$data[-1]}
 405                                                         : "? ($data[-1])";
 406                                         }
 407                                         next;
 408                                 }
 409                                 $bit & 3 or next;
 410                                 if ($bit & CMD_REPEAT) {
 411                                         push @data, readbyte(\@block, $bit) for 1 .. shift @data;
 412                                 } else {
 413                                         push @data, readbyte(\@block, $bit);
 414                                 }
 415                         }
 416                         $desc eq "move" and $data[2] == 0 and $desc = "rally";
 417                         push @$self, [$time, $player, $desc, @data];
 418                 }
 419         }
 420         return $self;
 421 }
 422
 423 }
 424
 425 my @race = (qw(Z T P), (undef) x 3, '-');
 426
 427 sub showtime {
 428         my $time = shift() * .042;
 429         my $minutes = int($time / 60);
 430         return sprintf "%d:%04.1f", $minutes, $time - $minutes * 60;
 431 }
 432
 433 sub unpackhash {
 434         my ($template, $expr, @elements) = @_;
 435         my @data = unpack $template, $expr;
 436         my %map;
 437         $map{$_} = shift @data for @elements;
 438         return (\%map, @data);
 439 }
 440
 441 local $_ = Data::StarCraft::Replay::_read(undef, \*STDIN, 633)
 442         and my ($head, @headdata) = unpackhash("CVa3Va12Z28v2Z16Z24CZ26a38a*", $_, qw(
 443                 engine frames mag1 time mag2 name width height
 444                 unknown1 creator unknown2 map unknown3
 445         ))
 446         or die "Couldn't read replay header\n";
 447
 448 $_ eq "\0\0\110" or warn sprintf(
 449         "Mismatch in first header constant: %s\n",
 450         join ",", map ord, split //, $_
 451 ) for $head->{mag1};
 452 $_ eq "\10"x8 . "\0"x4 or warn sprintf(
 453         "Mismatch in second header constant: %s\n",
 454         join ",", map ord, split //, $_
 455 ) for $head->{mag2};
 456 delete $head->{$_} for qw(mag1 mag2 unknown1 unknown2);
 457
 458 my @playdata = unpack "Va32"x12 . "V8C8", $headdata[0]
 459         or die "Couldn't parse player data in replay header\n";
 460
 461 my (@player, @slot);
 462 for (0 .. 11) {
 463         my $number = shift @playdata;
 464         defined $player[$number] and warn "Player #$number redefined";
 465         my ($data) = unpackhash("VcccZ25", shift @playdata, qw(
 466                 slot type race team name
 467         ));
 468         defined $race[$_] ? ($data->{race} = $race[$_]) :
 469                 warn "Unknown race #$_ for player $number"
 470                 for $data->{race};
 471         $slot[$data->{slot}] = $number if $data->{slot} < 16;
 472         $player[$number] = $data;
 473 }
 474 $player[$_]->{color} = shift @playdata for 0 .. 7;
 475 $player[$_]->{index} = shift @playdata for 0 .. 7;
 476
 477 sub showplayer {
 478         my $id = shift;
 479         my $playdata = $player[$slot[$id]];
 480         return defined $playdata ?
 481                 sprintf '%s (%s)', $playdata->{name}, $playdata->{race} : "#$id";
 482 }
 483
 484 printf "%s: %s\n", $_, $head->{$_} for qw(name creator);
 485 use Date::Format;
 486 printf "created: %s\n", time2str('%Y-%m-%d %X', $_) for $head->{time};
 487 printf "map: %s (%dx%d)\n", map $head->{$_}, qw(map width height);
 488 printf "frames: %s (%s)\n", $_, showtime($_) for $head->{frames};
 489 print "\n";
 490
 491 if ($SHOWWARN) {
 492         print Dumper $head;
 493         print Dumper \@player;
 494         #printf ":%s\n", join ",", map sprintf('%X', ord $_), split // for @headdata;
 495         print "\n";
 496 }
 497
 498 my $map = Data::StarCraft::Replay->new->open(\*STDIN);
 499
 500 if ($SHOWWARN) {
 501         for (@$map) {
 502                 my ($time, $player, $desc, @data) = @$_;
 503                 printf("@%s #%d %s: %s\n",
 504                         showtime($time), $player, $desc, join(", ", @data)
 505                 );
 506         }
 507 }
 508
 509 my %cmdmacro = map {$_ => 1} (
 510         (map {$_, "cancel $_"}
 511                 qw/train build hatch research upgrade arm/,
 512         ),
 513         qw/hotkey vision part rally/,
 514         # rally
 515 );
 516
 517 my %stats; # player => count
 518 for (@$map) {
 519         $stats{$_->[1]}{actions}++;
 520         $stats{$_->[1]}{gameactions}++ if $_->[0] >= APM_FIRSTFRAME;
 521         $stats{$_->[1]}{last} = $_->[0] if $_->[2] eq "part";
 522         $stats{$_->[1]}{$cmdmacro{$_->[2]} ? "macro" : "micro"}++;
 523         $stats{$_->[1]}{count}{$_->[2]}++;
 524 }
 525
 526 for my $player (sort keys %stats) {
 527         $stats{$player}{$_} = $player[$slot[$player]]{$_}
 528                 for keys %{ $player[$slot[$player]] };
 529         my $row = $stats{$player};
 530         $row->{last} ||= $map->[-1][0];
 531 #       printf("%-16s%6d actions (%3d micro,%4d macro);%4d APM\n",
 532         my $name = showplayer($player);
 533         printf("%d %-16s%6d actions in%7d frames (%s) = %d APM\n",
 534                 $row->{slot},
 535                 $name, $row->{actions}, $row->{last},
 536                 showtime($row->{last}),
 537 #               $row->{micro} / $row->{last} * 60 / .042 * 1.05,
 538 #               $row->{macro} / $row->{last} * 60 / .042 * 1.05,
 539                 $row->{gameactions} / ($row->{last} - APM_FIRSTFRAME) * 60 / .042,
 540         );
 541
 542         if (0) {
 543                 my @order; # pos => [ [ pct, cmd ] ]
 544                 my $i = 2;
 545                 push @{$order[++$i % 16]}, [ ($_->[0] / $row->{last}), $_->[6] ]
 546                         for grep {$_->[1] == $player and $_->[2] eq "build"} @$map;
 547                 print "build order:\n";
 548                 for (@order) {
 549                         my $lastpos = 0;
 550                         for (@$_) {
 551                                 my ($pos, $txt) = @$_;
 552                                 print ' ' x ($pos*60 - $lastpos);
 553                                 $txt = substr $txt, 0, 8;
 554                                 print $txt;
 555                                 $lastpos = $pos + length $txt;
 556                         }
 557                         print "\n";
 558                 }
 559         }
 560
 561         printf("action distribution: %s\n",
 562                 join(", ", map {
 563                         sprintf "%s (%d%%)", $_, $row->{count}{$_} / $row->{actions} * 100
 564                 } (
 565                         sort {$row->{count}{$b} <=> $row->{count}{$a}}
 566                         keys %{ $row->{count} }
 567                 )[0..7]),
 568         ) if 0;
 569 }
 570
 571 use Games::StarCraft::DB;
 572 my $Db = Games::StarCraft::DB->connect({RaiseError => 1})
 573         or die "No database: $DBI::errstr\n";
 574 sub findaccount ($) {
 575         my ($name) = @_;
 576         my $query = $Db->query(q{
 577                 SELECT DISTINCT account FROM play
 578                 WHERE name = ? AND account IS NOT NULL
 579         }, $name);
 580         return $query->rows == 1 ? $query->list : undef;
 581 }
 582
 583 if ($DBGAME) {{
 584         print "\n";
 585         my $game = $Db->query("SELECT * FROM game WHERE id=?", $DBGAME)->hash;
 586         if (not $game) {
 587                 printf "Database game # %d not found\n", $DBGAME;
 588                 last;
 589         }
 590         if ($game->{map} ne $head->{map}) {
 591                 printf "Replay map (%s) does not match database map (%s)\n",
 592                         $head->{map}, $game->{map};
 593                 last;
 594         }
 595
 596         $Db->begin;
 597         $Db->insert("game", {
 598                 frames => $head->{frames},
 599 #               map => $head->{map},
 600 #               start => time2str('%Y-%m-%d %X', $head->{time}),
 601         #       endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
 602 #               durationguess => \"endreplay - start",
 603         });
 604         $Db->update("play", {
 605                 name => $_->{name}, #TODO: --force
 606                 race => $_->{race}, #      --force
 607                 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
 608                 team => $_->{team},
 609                 color => $_->{color},
 610         }, {
 611                 game => $DBGAME,
 612                 slot => $_->{slot},
 613         }) for values %stats;
 614         $Db->commit;
 615 }}
 616
 617 if ($DBNAME) {
 618         print "\n";
 619         my @repstats = stat $DBNAME or die "no rep: $!\n";
 620         my ($name) = $DBNAME =~ m{.*/([^.]+)};
 621
 622         my %placetxt = (
 623                 bn => "bnet",
 624                 gr => "groningen",
 625                 md => "mdhq",
 626         );
 627         my ($placeid) = $name =~ /.*([a-z]{2})/;
 628         my $place = defined $placetxt{$placeid} ? $placetxt{$placeid} : undef;
 629
 630         my $winslot;
 631         if (@ARGV == 1 and $ARGV[0] =~ /^\d$/) {
 632                 $winslot = $ARGV[0];
 633         }
 634
 635         $Db->begin;
 636         $Db->insert("game", {
 637                 name => $name,
 638                 frames => $head->{frames},
 639                 map => $head->{map},
 640                 start => time2str('%Y-%m-%d %X', $head->{time}),
 641                 endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
 642 #               durationguess => \"endreplay - start",
 643                 place => $place,
 644         });
 645         my $gameid = $Db->last_insert_id((undef)x4, {sequence => "game_id_seq"});
 646         $Db->update("game", {durationguess => \"endreplay - start"}, {id => $gameid});
 647         $Db->insert("play", {
 648                 game => $gameid,
 649                 slot => $_->{slot},
 650                 name => $_->{name},
 651                 race => $_->{race},
 652                 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
 653                 team => $_->{team},
 654                 color => $_->{color},
 655                 account => findaccount($_->{name}),
 656                 result => defined $winslot ? $_->{slot} == $winslot ? 1 : -1 : 0,
 657         }) for values %stats;
 658         $Db->commit;
 659 }
 660
 661 if ($APMSVG) {
 662         my @seq;  # player => time (s) => actions
 663         $seq[$_->[1]][$_->[0] * .042]++ for @$map;
 664         my $flatten = 120;
 665         my @apm;
 666         for my $player (0 .. $#seq) {
 667                 my $range = 0;
 668                    $range += $seq[$player][$_] || 0 for 0 .. $flatten - 1;
 669                 my $leadfill = $range / $flatten;
 670                 for my $frame (0 .. $#{$seq[$player]}) {
 671                         $range += $seq[$player][$frame] || 0;
 672                         $range -= $frame < $flatten ? $leadfill :
 673                                 $seq[$player][$frame - $flatten] || 0;
 674                         $apm[$player][$frame] = $range / $flatten;
 675                 }
 676         }
 677
 678         BEGIN { unshift @INC, '.' }
 679         use SVG::TT::Graph::TimeSeries;
 680         my $graph = SVG::TT::Graph::TimeSeries->new({
 681                 height => 1200,
 682                 width => 1600,
 683                 style_sheet => "apm.css",
 684                 show_data_values => 0,
 685                 show_data_points => 0,
 686                 x_label_format => '%k:%M',
 687                 key => 1,
 688                 timescale_divisions => "5 minutes",
 689         #       compress => 1,
 690         });
 691
 692         for my $player (0 .. $#apm) {
 693                 $graph->add_data({
 694                         data => [map {
 695                                 time2str('%Y-%m-%d %X', 946681200 + $_),
 696                                 $apm[$player][$_] * 60
 697                         } 0 .. $#{$apm[$player]} ],
 698                         title => showplayer($player),
 699                 });
 700         }
 701
 702         my ($name) = $APMSVG =~ /([^.]+)/;
 703         my $title = "APM timeline" . ($name && " for $name");
 704         my $lead = sprintf "\n<title>%s</title>", $title;
 705
 706         my $svg = $graph->burn();
 707         s/^[ \t\r]+\n//gm,  # remove lines with only whitespace (many useless ^M)
 708         s/[ \t\r]+$//gm,    # trailing whitespace
 709         s/ {4}\r*/\t/g,     # tabs for indenting
 710         s/^(<svg width=")1600(" height=")1200("[^>]*>)/${1}100%${2}100%$3$lead/m,
 711                 for $svg; # cleanup xml
 712
 713         open my $apmfile, '>', "$APMSVG.svg";
 714         print $apmfile $svg;
 715 }
 716
 717 __END__
 718
 719 =head1 NAME
 720
 721 screp - StarCraft replay parser
 722
 723 =head1 SYNOPSIS
 724
 725 screp [options] < [replay data]
 726
 727  Options:
 728    --verbose
 729    --apm
 730    --dbname
 731    --dbid
 732
 733 =head1 OPTIONS
 734
 735 =head1 AUTHOR
 736
 737 Mischa POSLAWSKY <perl@shiar.org>
 738
 739 =head1 STUFF
 740