use strict;
use warnings;
use Data::Dumper;
-
+use Data::StarCraft::Replay;
+ our $VERSION = '1.01';
+
my $SHOWWARN = 0;
+my $ACTGIF = undef;
my $APMSVG = undef;
+ my $DBNAME = undef;
+ my $DBGAME = undef;
- use Getopt::Long;
+ use Getopt::Long qw(:config bundling auto_version auto_help);
GetOptions(
"verbose|v!" => \$SHOWWARN,
"apm|a=s" => \$APMSVG,
+ "act" => \$ACTGIF,
+ "dbname|D=s" => \$DBNAME,
+ "dbid|d=s" => \$DBGAME,
);
use constant { APM_FIRSTFRAME => 80 / .042 };
-{
-
-package Data::StarCraft::Replay;
-
-use Data::Dumper;
-
-use constant {
- CMD_REPEAT => 4,
-};
-
-my %build = (
- 0x19 => "morph",
- 0x1E => "build",
- 0x1F => "warp",
- 0x24 => "add-on",
- 0x2E => "evolve",
- 0x47 => "land",
-);
-my %unit = (
- 0x00 => "Marine",
- 0x01 => "Ghost",
- 0x02 => "Vulture",
- 0x03 => "Goliath",
- # undef,
- 0x05 => "Siege Tank",
- # undef,
- 0x07 => "SCV",
- 0x08 => "Wraith",
- 0x09 => "Science Vessel",
- # undef,
- 0x0B => "Dropship",
- 0x0C => "Battlecruiser",
- # undef,
- 0x0E => "Nuke",
- # (undef) x 0x11,
- 0x20 => "Firebat",
- # undef,
- 0x22 => "Medic",
- # undef,
- # undef,
- 0x25 => "Zergling",
- 0x26 => "Hydralisk",
- 0x27 => "Ultralisk",
- # undef,
- 0x29 => "Drone",
- 0x2A => "Overlord",
- 0x2B => "Mutalisk",
- 0x2C => "Guardian",
- 0x2D => "Queen",
- 0x2E => "Defiler",
- 0x2F => "Scourge",
- # undef,
- # undef,
- 0x32 => "Infested Terran",
- # (undef) x 7,
- 0x3A => "Valkyrie",
- # undef,
- 0x3C => "Corsair",
- 0x3D => "Dark Templar",
- 0x3E => "Devourer",
- # undef,
- 0x40 => "Probe",
- 0x41 => "Zealot",
- 0x42 => "Dragoon",
- 0x43 => "High Templar",
- # undef,
- 0x45 => "Shuttle",
- 0x46 => "Scout",
- 0x47 => "Arbiter",
- 0x48 => "Carrier",
- # (undef) x 0x0A,
- 0x53 => "Reaver",
- 0x54 => "Observer",
- # (undef) x 0x12,
- 0x67 => "Lurker",
- # undef,
- # undef,
- 0x6A => "Command Center",
- 0x6B => "ComSat",
- 0x6C => "Nuclear Silo",
- 0x6D => "Supply Depot",
- 0x6E => "Refinery", # refinery?
- 0x6F => "Barracks",
- 0x70 => "Academy", # Academy?
- 0x71 => "Factory",
- 0x72 => "Starport",
- 0x73 => "Control Tower",
- 0x74 => "Science Facility",
- 0x75 => "Covert Ops",
- 0x76 => "Physics Lab",
- # undef,
- 0x78 => "Machine Shop",
- # undef,
- 0x7A => "Engineering Bay",
- 0x7B => "Armory",
- 0x7C => "Missile Turret",
- 0x7D => "Bunker",
- # (undef) x 4,
- 0x82 => "Infested CC",
- 0x83 => "Hatchery",
- 0x84 => "Lair",
- 0x85 => "Hive",
- 0x86 => "Nydus Canal",
- 0x87 => "Hydralisk Den",
- 0x88 => "Defiler Mound",
- 0x89 => "Greater Spire",
- 0x8A => "Queens Nest",
- 0x8B => "Evolution Chamber",
- 0x8C => "Ultralisk Cavern",
- 0x8D => "Spire",
- 0x8E => "Spawning Pool",
- 0x8F => "Creep Colony",
- 0x90 => "Spore Colony",
- # undef,
- 0x92 => "Sunken Colony",
- # undef,
- # undef,
- 0x95 => "Extractor",
- # (undef) x 4,
- 0x9A => "Nexus",
- 0x9B => "Robotics Facility",
- 0x9C => "Pylon",
- 0x9D => "Assimilator",
- # undef,
- 0x9F => "Observatory",
- 0xA0 => "Gateway",
- # undef,
- 0xA2 => "Photon Cannon",
- 0xA3 => "Citadel of Adun",
- 0xA4 => "Cybernetics Core",
- 0xA5 => "Templar Archives",
- 0xA6 => "Forge",
- 0xA7 => "Stargate",
- # undef,
- 0xA9 => "Fleet Beacon",
- 0xAA => "Arbiter Tribunal",
- 0xAB => "Robotics Support Bay",
- 0xAC => "Shield Battery",
- # (undef) x 0x14,
- 0xC0 => "Larva",
- 0xC1 => "Rine/Bat",
- 0xC2 => "Dark Archon",
- 0xC3 => "Archon",
- 0xC4 => "Scarab",
- 0xC5 => "Interceptor",
- 0xC6 => "Interceptor/Scarab",
-);
-my @upgrade = (
- "Terran Infantry Armor",
- "Terran Vehicle Plating",
- "Terran Ship Plating",
- "Zerg Carapace",
- "Zerg Flyer Carapace",
- "Protoss Ground Armor",
- "Protoss Air Armor",
- "Terran Infantry Weapons",
- "Terran Vehicle Weapons",
- "Terran Ship Weapons",
- "Zerg Melee Attacks",
- "Zerg Missile Attacks",
- "Zerg Flyer Attacks",
- "Protoss Ground Weapons",
- "Protoss Air Weapons",
- "Protoss Plasma Shields",
- # 0x10
- "U-238 Shells (Marine Range)",
- "Ion Thrusters (Vulture Speed)",
- undef,
- "Titan Reactor (Science Vessel Energy)",
- "Ocular Implants (Ghost Sight)",
- "Moebius Reactor (Ghost Energy)",
- "Apollo Reactor (Wraith Energy)",
- "Colossus Reactor (Battle Cruiser Energy)",
- "Ventral Sacs (Overlord Transport)",
- "Antennae (Overlord Sight)",
- "Pneumatized Carapace (Overlord Speed)",
- "Metabolic Boost (Zergling Speed)",
- "Adrenal Glands (Zergling Attack)",
- "Muscular Augments (Hydralisk Speed)",
- "Grooved Spines (Hydralisk Range)",
- "Gamete Meiosis (Queen Energy)",
- # 0x20
- "Defiler Energy",
- "Singularity Charge (Dragoon Range)",
- "Leg Enhancement (Zealot Speed)",
- "Scarab Damage",
- "Reaver Capacity",
- "Gravitic Drive (Shuttle Speed)",
- "Sensor Array (Observer Sight)",
- "Gravitic Booster (Observer Speed)",
- "Khaydarin Amulet (Templar Energy)",
- "Apial Sensors (Scout Sight)",
- "Gravitic Thrusters (Scout Speed)",
- "Carrier Capacity",
- "Khaydarin Core (Arbiter Energy)",
- undef,
- undef,
- "Argus Jewel (Corsair Energy)",
- # 0x30
- undef,
- "Argus Talisman (Dark Archon Energy)",
- "Caduceus Reactor (Medic Energy)",
- "Chitinous Plating (Ultralisk Armor)",
- "Anabolic Synthesis (Ultralisk Speed)",
- "Charon Boosters (Goliath Range)",
-);
-my @research = (
- "Stim Pack",
- "Lockdown",
- "EMP Shockwave",
- "Spider Mines",
- undef,
- "Siege Tank",
- undef,
- "Irradiate",
- "Yamato Gun",
- "Cloaking Field (wraith)",
- "Personal Cloaking (ghost)",
- "Burrow",
- undef,
- "Spawn Broodling",
- undef,
- "Plague",
- # 0x10
- "Consume",
- "Ensnare",
- undef,
- "Psionic Storm",
- "Hallucination",
- "Recall",
- "Stasis Field",
- undef,
- "Restoration",
- "Disruption Web",
- undef,
- "Mind Control",
- undef,
- undef,
- "Optical Flare",
- "Maelstrom",
- # 0x20
- "Lurker Aspect",
-);
-my %action = (
- 0x00 => "Move",
- 0x02 => "Unallowed Move?",
- 0x06 => "Force move",
- 0x08 => "Attack",
- 0x09 => "Gather",
- 0x0E => "Attack Move",
- 0x13 => "Failed Casting (?)",
- 0x17 => "#23 (?)",
- 0x1B => "Infest CC",
- 0x22 => "Repair",
- 0x27 => "Clear Rally",
- 0x28 => "Set Rally",
- 0x4F => "Gather",
- 0x50 => "Gather",
- 0x70 => "Unload",
- 0x71 => "Yamato",
- 0x73 => "Lockdown",
- 0x77 => "Dark Swarm",
- 0x78 => "Parasite",
- 0x79 => "Spawn Broodling",
- 0x7A => "EMP",
- 0x7E => "Launch Nuke",
- 0x84 => "Lay Mine",
- 0x8B => "ComSat Scan",
- 0x8D => "Defense Matrix",
- 0x8E => "Psionic Storm",
- 0x8F => "Recall",
- 0x90 => "Plague",
- 0x91 => "Consume",
- 0x92 => "Ensnare",
- 0x93 => "Stasis",
- 0x94 => "Hallucination",
- 0x98 => "Patrol",
- 0xB1 => "Heal",
- 0xB4 => "Restore",
- 0xB5 => "Disruption Web",
- 0xB6 => "Mind Control",
- 0xB8 => "Feedback",
- 0xB9 => "Optic Flare",
- 0xBA => "Maelstrom",
- 0xC0 => "Irradiate",
-);
-
-my %cmdread = (
- 0x09 => ["select", 1, 2 | CMD_REPEAT],
- 0x0A => ["add", 1, 2 | CMD_REPEAT],
- 0x0B => ["deselect", 1, 2 | CMD_REPEAT],
- 0x0C => ["build", 1, \%build, 2, 2, 2, \%unit],
- 0x0D => ["vision", 2],
- 0x0E => ["ally", 2, 2],
- 0x13 => ["hotkey", 1, [qw"assign select"], 1],
- 0x14 => ["move", 2, 2, 2, 2, 1], # 1 = queued?
- 0x15 => ["action", 2, 2, 2, 2, 1, \%action, 1, [qw"normal queued"]],
- 0x18 => ["cancel"],
- 0x19 => ["cancel hatch"],
- 0x1A => ["stop", 1],
-# 0x1B => ["move-thing??"], # tim: after hotkey (unit, reaver??) select; soon after reselected and moved
- 0x1E => ["return cargo", 1],
- 0x1F => ["train", 2, \%unit],
- 0x20 => ["cancel train", 2], # == 254
- 0x21 => ["cloak", 1],
- 0x22 => ["decloak", 1],
- 0x23 => ["hatch", 2, \%unit],
- 0x25 => ["unsiege", 1],
- 0x26 => ["siege", 1],
- 0x27 => ["arm", 0], # scarab/interceptor
- 0x28 => ["unload all", 1],
- 0x29 => ["unload", 2],
- 0x2A => ["merge archon", 0],
- 0x2B => ["hold position", 1],
- 0x2C => ["burrow", 1],
- 0x2D => ["unburrow", 1],
- 0x2E => ["cancel nuke", 0],
- 0x2F => ["lift", 2, 2],
- 0x30 => ["research", 1, \@research],
- 0x31 => ["cancel research", 0],
- 0x32 => ["upgrade", 1, \@upgrade],
-# 0x33 => ["forge-thing??"], # right after forge select: probably unpowered, iirc cancel research
- 0x35 => ["morph", 2, \%unit],
- 0x36 => ["stim", 0],
- 0x57 => ["part", 1, {qw"1 quit 6 drop"}],
- 0x5A => ["merge dark archon", 0],
-);
-
-sub new {
- my ($class) = @_;
- bless [], $class;
-}
-
-sub _read {
- my $self = shift;
- my ($fh, $size, $seek) = @_;
- seek *$fh, $seek, 0 if $seek;
- read(*$fh, my $in, $size) eq $size or return undef;
- return $in;
-}
-
-sub open {
- my $self = shift;
- my ($file) = @_;
-
- while (not eof $file) {
- local $_ = $self->_read($file, 5)
- and my ($time, $size) = unpack "VC", $_
- or die "Couldn't read time block head\n";
- local $_ = $self->_read($file, $size)
- and my @block = unpack "C*", $_
- or die "Couldn't read time block data\n";
- while (@block) {
- my $player = shift @block;
- my $cmd = shift @block;
- if (not defined $cmdread{$cmd}) {
- warn sprintf "command #%X not defined: %d bytes ignored\n",
- $cmd, scalar @block;
- push @$self, [$time, $player, "??? $cmd"] if $SHOWWARN;
- last;
- }
-
- sub readbyte {
- my ($data, $byte) = @_;
- my $out = shift @$data;
- if (($byte & 3) == 2) {
- @$data ? ($out += shift(@$data) << 8)
- : warn "high byte not present\n";
- }
- return $out;
- }
-
- my @format = @{ $cmdread{$cmd} };
- my $desc = shift @format;
- my @data;
- for my $bit (@format) {
- if (ref $bit) {
- if (ref $bit eq "ARRAY") {
- $data[-1] = defined $bit->[$data[-1]] ? $bit->[$data[-1]]
- : "? ($data[-1])";
- } else {
- $data[-1] = defined $bit->{$data[-1]} ? $bit->{$data[-1]}
- : "? ($data[-1])";
- }
- next;
- }
- $bit & 3 or next;
- if ($bit & CMD_REPEAT) {
- push @data, readbyte(\@block, $bit) for 1 .. shift @data;
- } else {
- push @data, readbyte(\@block, $bit);
- }
- }
- $desc eq "move" and $data[2] == 0 and $desc = "rally";
- push @$self, [$time, $player, $desc, @data];
- }
- }
- return $self;
-}
-
-}
-
my @race = (qw(Z T P), (undef) x 3, '-');
sub showtime {
my $number = shift @playdata;
defined $player[$number] and warn "Player #$number redefined";
my ($data) = unpackhash("VcccZ25", shift @playdata, qw(
- slot type race unknown name
+ slot type race team name
));
defined $race[$_] ? ($data->{race} = $race[$_]) :
warn "Unknown race #$_ for player $number"
}
for my $player (sort keys %stats) {
+ $stats{$player}{$_} = $player[$slot[$player]]{$_}
+ for keys %{ $player[$slot[$player]] };
my $row = $stats{$player};
$row->{last} ||= $map->[-1][0];
# printf("%-16s%6d actions (%3d micro,%4d macro);%4d APM\n",
my $name = showplayer($player);
- printf("%-16s%6d actions in%7d frames (%s) = %d APM\n",
+ printf("%d %-16s%6d actions in%7d frames (%s) = %d APM\n",
+ $row->{slot},
$name, $row->{actions}, $row->{last},
showtime($row->{last}),
# $row->{micro} / $row->{last} * 60 / .042 * 1.05,
) if 0;
}
+if ($ACTGIF) {
+ open my $imgfile, '>', "test.gif" or die;
+ binmode $imgfile;
+ select $imgfile;
+
+ use GD;
+ my $ani = GD::Image->new($head->{width}, $head->{height});
+ my $bg = $ani->colorAllocate(0, 0, 0);
+ my @plot = (
+ $ani->colorAllocate(255, 0, 0),
+ $ani->colorAllocate(255, 255, 0),
+ $ani->colorAllocate(0, 255, 0),
+ $ani->colorAllocate(0, 255, 255),
+ $ani->colorAllocate(0, 0, 255),
+ $ani->colorAllocate(255, 0, 255),
+ );
+
+ print $ani->gifanimbegin;
+# print $ani->gifanimadd;
+ {
+ my $frame = GD::Image->new($ani->getBounds);
+ print $frame->gifanimadd;
+ my $length = 30 / .042;
+ my $last = 0;
+ for (@$map) {
+ my ($time, $player, $cmd, @data) = @$_;
+#$time < $length * 10 or last;
+ while ($time > $last + $length) {
+ $last += $length;
+ print $frame->gifanimadd(0, 0, 0, 32);
+# $frame = GD::Image->new($ani->getBounds);
+ }
+ if ($cmd eq "build") {
+ $frame->setPixel($data[1]>>5, $data[2]>>5, $plot[$player]);
+ }
+ elsif ($cmd eq "move" or $cmd eq "attack") {
+ $frame->setPixel($data[0]>>5, $data[1]>>5, $plot[$player]);
+# if $data[2] == 0xFFFF_FFFF;
+ }
+ }
+# add_frame_data($frame);
+ print $frame->gifanimadd;
+ }
+ print $ani->gifanimend;
+ select STDOUT;
+}
+
+ use Games::StarCraft::DB;
+ my $Db = Games::StarCraft::DB->connect({RaiseError => 1})
+ or die "No database: $DBI::errstr\n";
+ sub findaccount ($) {
+ my ($name) = @_;
+ my $query = $Db->query(q{
+ SELECT DISTINCT account FROM play
+ WHERE name = ? AND account IS NOT NULL
+ }, $name);
+ return $query->rows == 1 ? $query->list : undef;
+ }
+
+ if ($DBGAME) {{
+ print "\n";
+ my $game = $Db->query("SELECT * FROM game WHERE id=?", $DBGAME)->hash;
+ if (not $game) {
+ printf "Database game # %d not found\n", $DBGAME;
+ last;
+ }
+ if ($game->{map} ne $head->{map}) {
+ printf "Replay map (%s) does not match database map (%s)\n",
+ $head->{map}, $game->{map};
+ last;
+ }
+
+ $Db->begin;
+ $Db->insert("game", {
+ frames => $head->{frames},
+ # map => $head->{map},
+ # start => time2str('%Y-%m-%d %X', $head->{time}),
+ # endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
+ # durationguess => \"endreplay - start",
+ });
+ $Db->update("play", {
+ name => $_->{name}, #TODO: --force
+ race => $_->{race}, # --force
+ apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
+ team => $_->{team},
+ color => $_->{color},
+ }, {
+ game => $DBGAME,
+ slot => $_->{slot},
+ }) for values %stats;
+ $Db->commit;
+ }}
+
+ if ($DBNAME) {
+ print "\n";
+ my @repstats = stat $DBNAME or die "no rep: $!\n";
+ my ($name) = $DBNAME =~ m{.*/([^.]+)};
+
+ my %placetxt = (
+ bn => "bnet",
+ gr => "groningen",
+ md => "mdhq",
+ );
+ my ($placeid) = $name =~ /.*([a-z]{2})/;
+ my $place = defined $placetxt{$placeid} ? $placetxt{$placeid} : undef;
+
+ my $winslot;
+ if (@ARGV == 1 and $ARGV[0] =~ /^\d$/) {
+ $winslot = $ARGV[0];
+ }
+
+ $Db->begin;
+ $Db->insert("game", {
+ name => $name,
+ frames => $head->{frames},
+ map => $head->{map},
+ start => time2str('%Y-%m-%d %X', $head->{time}),
+ endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
+ # durationguess => \"endreplay - start",
+ place => $place,
+ });
+ my $gameid = $Db->last_insert_id((undef)x4, {sequence => "game_id_seq"});
+ $Db->update("game", {durationguess => \"endreplay - start"}, {id => $gameid});
+ $Db->insert("play", {
+ game => $gameid,
+ slot => $_->{slot},
+ name => $_->{name},
+ race => $_->{race},
+ apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
+ team => $_->{team},
+ color => $_->{color},
+ account => findaccount($_->{name}),
+ result => defined $winslot ? $_->{slot} == $winslot ? 1 : -1 : 0,
+ }) for values %stats;
+ $Db->commit;
+ }
+
if ($APMSVG) {
my @seq; # player => time (s) => actions
$seq[$_->[1]][$_->[0] * .042]++ for @$map;
print $apmfile $svg;
}
+ __END__
+
+ =head1 NAME
+
+ screp - StarCraft replay parser
+
+ =head1 SYNOPSIS
+
+ screp [options] < [replay data]
+
+ Options:
+ --verbose
+ --apm
++ --act
+ --dbname
+ --dbid
+
+ =head1 OPTIONS
+
+ =head1 AUTHOR
+
+ Mischa POSLAWSKY <perl@shiar.org>
+
+ =head1 STUFF
+
git.shiar.nl / perl / schtarr.git / commitdiff