#!/usr/bin/perl
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 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 };
my @race = (qw(Z T P), (undef) x 3, '-');
sub showtime {
my $time = shift() * .042;
my $minutes = int($time / 60);
return sprintf "%d:%04.1f", $minutes, $time - $minutes * 60;
}
sub unpackhash {
my ($template, $expr, @elements) = @_;
my @data = unpack $template, $expr;
my %map;
$map{$_} = shift @data for @elements;
return (\%map, @data);
}
local $_ = Data::StarCraft::Replay::_read(undef, \*STDIN, 633)
and my ($head, @headdata) = unpackhash("CVa3Va12Z28v2Z16Z24CZ26a38a*", $_, qw(
engine frames mag1 time mag2 name width height
unknown1 creator unknown2 map unknown3
))
or die "Couldn't read replay header\n";
$_ eq "\0\0\110" or warn sprintf(
"Mismatch in first header constant: %s\n",
join ",", map ord, split //, $_
) for $head->{mag1};
$_ eq "\10"x8 . "\0"x4 or warn sprintf(
"Mismatch in second header constant: %s\n",
join ",", map ord, split //, $_
) for $head->{mag2};
delete $head->{$_} for qw(mag1 mag2 unknown1 unknown2);
my @playdata = unpack "Va32"x12 . "V8C8", $headdata[0]
or die "Couldn't parse player data in replay header\n";
my (@player, @slot);
for (0 .. 11) {
my $number = shift @playdata;
defined $player[$number] and warn "Player #$number redefined";
my ($data) = unpackhash("VcccZ25", shift @playdata, qw(
slot type race team name
));
defined $race[$_] ? ($data->{race} = $race[$_]) :
warn "Unknown race #$_ for player $number"
for $data->{race};
$slot[$data->{slot}] = $number if $data->{slot} < 16;
$player[$number] = $data;
}
$player[$_]->{color} = shift @playdata for 0 .. 7;
$player[$_]->{index} = shift @playdata for 0 .. 7;
sub showplayer {
my $id = shift;
my $playdata = $player[$slot[$id]];
return defined $playdata ?
sprintf '%s (%s)', $playdata->{name}, $playdata->{race} : "#$id";
}
printf "%s: %s\n", $_, $head->{$_} for qw(name creator);
use Date::Format;
printf "created: %s\n", time2str('%Y-%m-%d %X', $_) for $head->{time};
printf "map: %s (%dx%d)\n", map $head->{$_}, qw(map width height);
printf "frames: %s (%s)\n", $_, showtime($_) for $head->{frames};
print "\n";
if ($SHOWWARN) {
print Dumper $head;
print Dumper \@player;
#printf ":%s\n", join ",", map sprintf('%X', ord $_), split // for @headdata;
print "\n";
}
my $map = Data::StarCraft::Replay->new->open(\*STDIN);
if ($SHOWWARN) {
for (@$map) {
my ($time, $player, $desc, @data) = @$_;
printf("@%s #%d %s: %s\n",
showtime($time), $player, $desc, join(", ", @data)
);
}
}
my %cmdmacro = map {$_ => 1} (
(map {$_, "cancel $_"}
qw/train build hatch research upgrade arm/,
),
qw/hotkey vision part rally/,
# rally
);
my %stats; # player => count
for (@$map) {
$stats{$_->[1]}{actions}++;
$stats{$_->[1]}{gameactions}++ if $_->[0] >= APM_FIRSTFRAME;
$stats{$_->[1]}{last} = $_->[0] if $_->[2] eq "part";
$stats{$_->[1]}{$cmdmacro{$_->[2]} ? "macro" : "micro"}++;
$stats{$_->[1]}{count}{$_->[2]}++;
}
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("%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,
# $row->{macro} / $row->{last} * 60 / .042 * 1.05,
$row->{gameactions} / ($row->{last} - APM_FIRSTFRAME) * 60 / .042,
);
if (0) {
my @order; # pos => [ [ pct, cmd ] ]
my $i = 2;
push @{$order[++$i % 16]}, [ ($_->[0] / $row->{last}), $_->[6] ]
for grep {$_->[1] == $player and $_->[2] eq "build"} @$map;
print "build order:\n";
for (@order) {
my $lastpos = 0;
for (@$_) {
my ($pos, $txt) = @$_;
print ' ' x ($pos*60 - $lastpos);
$txt = substr $txt, 0, 8;
print $txt;
$lastpos = $pos + length $txt;
}
print "\n";
}
}
printf("action distribution: %s\n",
join(", ", map {
sprintf "%s (%d%%)", $_, $row->{count}{$_} / $row->{actions} * 100
} (
sort {$row->{count}{$b} <=> $row->{count}{$a}}
keys %{ $row->{count} }
)[0..7]),
) if 0;
}
if ($ACTGIF) {
open my $imgfile, '>', "test.gif" or die;
binmode $imgfile;
select $imgfile;
require 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;
}
if ($DBGAME or $DBNAME) {
require 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;
my $flatten = 120;
my @apm;
for my $player (0 .. $#seq) {
my $range = 0;
$range += $seq[$player][$_] || 0 for 0 .. $flatten - 1;
my $leadfill = $range / $flatten;
for my $frame (0 .. $#{$seq[$player]}) {
$range += $seq[$player][$frame] || 0;
$range -= $frame < $flatten ? $leadfill :
$seq[$player][$frame - $flatten] || 0;
$apm[$player][$frame] = $range / $flatten;
}
}
BEGIN { unshift @INC, '.' }
require SVG::TT::Graph::TimeSeries;
my $graph = SVG::TT::Graph::TimeSeries->new({
height => 1200,
width => 1600,
style_sheet => "apm.css",
show_data_values => 0,
show_data_points => 0,
x_label_format => '%k:%M',
key => 1,
timescale_divisions => "5 minutes",
# compress => 1,
});
for my $player (0 .. $#apm) {
$graph->add_data({
data => [map {
time2str('%Y-%m-%d %X', 946681200 + $_),
$apm[$player][$_] * 60
} 0 .. $#{$apm[$player]} ],
title => showplayer($player),
});
}
my ($name) = $APMSVG =~ /([^.]+)/;
my $title = "APM timeline" . ($name && " for $name");
my $lead = sprintf "\n%s", $title;
my $svg = $graph->burn();
s/^[ \t\r]+\n//gm, # remove lines with only whitespace (many useless ^M)
s/[ \t\r]+$//gm, # trailing whitespace
s/ {4}\r*/\t/g, # tabs for indenting
s/^(