screp

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