screp

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