screp

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use Data::Dumper;
   5 use Data::StarCraft::Replay;
   6
   7 our $VERSION = '1.01';
   8
   9 my $SHOWWARN = 0;
  10 my $ACTGIF = undef;
  11 my $APMSVG = undef;
  12 my $DBNAME = undef;
  13 my $DBGAME = undef;
  14
  15 use Getopt::Long qw(:config bundling auto_version auto_help);
  16 GetOptions(
  17         "verbose|v!" => \$SHOWWARN,
  18         "apm|a=s" => \$APMSVG,
  19         "act" => \$ACTGIF,
  20         "dbname|D=s" => \$DBNAME,
  21         "dbid|d=s" => \$DBGAME,
  22 );
  23
  24 use constant { APM_FIRSTFRAME => 80 / .042 };
  25
  26 my @race = (qw(Z T P), (undef) x 3, '-');
  27
  28 sub showtime {
  29         my $time = shift() * .042;
  30         my $minutes = int($time / 60);
  31         return sprintf "%d:%04.1f", $minutes, $time - $minutes * 60;
  32 }
  33
  34 sub unpackhash {
  35         my ($template, $expr, @elements) = @_;
  36         my @data = unpack $template, $expr;
  37         my %map;
  38         $map{$_} = shift @data for @elements;
  39         return (\%map, @data);
  40 }
  41
  42 local $_ = Data::StarCraft::Replay::_read(undef, \*STDIN, 633)
  43         and my ($head, @headdata) = unpackhash("CVa3Va12Z28v2Z16Z24CZ26a38a*", $_, qw(
  44                 engine frames mag1 time mag2 name width height
  45                 unknown1 creator unknown2 map unknown3
  46         ))
  47         or die "Couldn't read replay header\n";
  48
  49 $_ eq "\0\0\110" or warn sprintf(
  50         "Mismatch in first header constant: %s\n",
  51         join ",", map ord, split //, $_
  52 ) for $head->{mag1};
  53 $_ eq "\10"x8 . "\0"x4 or warn sprintf(
  54         "Mismatch in second header constant: %s\n",
  55         join ",", map ord, split //, $_
  56 ) for $head->{mag2};
  57 delete $head->{$_} for qw(mag1 mag2 unknown1 unknown2);
  58
  59 my @playdata = unpack "Va32"x12 . "V8C8", $headdata[0]
  60         or die "Couldn't parse player data in replay header\n";
  61
  62 my (@player, @slot);
  63 for (0 .. 11) {
  64         my $number = shift @playdata;
  65         defined $player[$number] and warn "Player #$number redefined";
  66         my ($data) = unpackhash("VcccZ25", shift @playdata, qw(
  67                 slot type race team name
  68         ));
  69         defined $race[$_] ? ($data->{race} = $race[$_]) :
  70                 warn "Unknown race #$_ for player $number"
  71                 for $data->{race};
  72         $slot[$data->{slot}] = $number if $data->{slot} < 16;
  73         $player[$number] = $data;
  74 }
  75 $player[$_]->{color} = shift @playdata for 0 .. 7;
  76 $player[$_]->{index} = shift @playdata for 0 .. 7;
  77
  78 sub showplayer {
  79         my $id = shift;
  80         my $playdata = $player[$slot[$id]];
  81         return defined $playdata ?
  82                 sprintf '%s (%s)', $playdata->{name}, $playdata->{race} : "#$id";
  83 }
  84
  85 printf "%s: %s\n", $_, $head->{$_} for qw(name creator);
  86 use Date::Format;
  87 printf "created: %s\n", time2str('%Y-%m-%d %X', $_) for $head->{time};
  88 printf "map: %s (%dx%d)\n", map $head->{$_}, qw(map width height);
  89 printf "frames: %s (%s)\n", $_, showtime($_) for $head->{frames};
  90 print "\n";
  91
  92 if ($SHOWWARN) {
  93         print Dumper $head;
  94         print Dumper \@player;
  95         #printf ":%s\n", join ",", map sprintf('%X', ord $_), split // for @headdata;
  96         print "\n";
  97 }
  98
  99 my $map = Data::StarCraft::Replay->new->open(\*STDIN);
 100
 101 if ($SHOWWARN) {
 102         for (@$map) {
 103                 my ($time, $player, $desc, @data) = @$_;
 104                 printf("@%s #%d %s: %s\n",
 105                         showtime($time), $player, $desc, join(", ", @data)
 106                 );
 107         }
 108 }
 109
 110 my %cmdmacro = map {$_ => 1} (
 111         (map {$_, "cancel $_"}
 112                 qw/train build hatch research upgrade arm/,
 113         ),
 114         qw/hotkey vision part rally/,
 115         # rally
 116 );
 117
 118 my %stats; # player => count
 119 for (@$map) {
 120         $stats{$_->[1]}{actions}++;
 121         $stats{$_->[1]}{gameactions}++ if $_->[0] >= APM_FIRSTFRAME;
 122         $stats{$_->[1]}{last} = $_->[0] if $_->[2] eq "part";
 123         $stats{$_->[1]}{$cmdmacro{$_->[2]} ? "macro" : "micro"}++;
 124         $stats{$_->[1]}{count}{$_->[2]}++;
 125 }
 126
 127 for my $player (sort keys %stats) {
 128         $stats{$player}{$_} = $player[$slot[$player]]{$_}
 129                 for keys %{ $player[$slot[$player]] };
 130         my $row = $stats{$player};
 131         $row->{last} ||= $map->[-1][0];
 132 #       printf("%-16s%6d actions (%3d micro,%4d macro);%4d APM\n",
 133         my $name = showplayer($player);
 134         printf("%d %-16s%6d actions in%7d frames (%s) = %d APM\n",
 135                 $row->{slot},
 136                 $name, $row->{actions}, $row->{last},
 137                 showtime($row->{last}),
 138 #               $row->{micro} / $row->{last} * 60 / .042 * 1.05,
 139 #               $row->{macro} / $row->{last} * 60 / .042 * 1.05,
 140                 $row->{gameactions} / ($row->{last} - APM_FIRSTFRAME) * 60 / .042,
 141         );
 142
 143         if (0) {
 144                 my @order; # pos => [ [ pct, cmd ] ]
 145                 my $i = 2;
 146                 push @{$order[++$i % 16]}, [ ($_->[0] / $row->{last}), $_->[6] ]
 147                         for grep {$_->[1] == $player and $_->[2] eq "build"} @$map;
 148                 print "build order:\n";
 149                 for (@order) {
 150                         my $lastpos = 0;
 151                         for (@$_) {
 152                                 my ($pos, $txt) = @$_;
 153                                 print ' ' x ($pos*60 - $lastpos);
 154                                 $txt = substr $txt, 0, 8;
 155                                 print $txt;
 156                                 $lastpos = $pos + length $txt;
 157                         }
 158                         print "\n";
 159                 }
 160         }
 161
 162         printf("action distribution: %s\n",
 163                 join(", ", map {
 164                         sprintf "%s (%d%%)", $_, $row->{count}{$_} / $row->{actions} * 100
 165                 } (
 166                         sort {$row->{count}{$b} <=> $row->{count}{$a}}
 167                         keys %{ $row->{count} }
 168                 )[0..7]),
 169         ) if 0;
 170 }
 171
 172 if ($ACTGIF) {
 173         open my $imgfile, '>', "test.gif" or die;
 174         binmode $imgfile;
 175         select $imgfile;
 176
 177         use GD;
 178         my $ani = GD::Image->new($head->{width}, $head->{height});
 179         my $bg = $ani->colorAllocate(0, 0, 0);
 180         my @plot = (
 181                 $ani->colorAllocate(255, 0, 0),
 182                 $ani->colorAllocate(255, 255, 0),
 183                 $ani->colorAllocate(0, 255, 0),
 184                 $ani->colorAllocate(0, 255, 255),
 185                 $ani->colorAllocate(0, 0, 255),
 186                 $ani->colorAllocate(255, 0, 255),
 187         );
 188
 189         print $ani->gifanimbegin;
 190 #       print $ani->gifanimadd;
 191         {
 192                 my $frame = GD::Image->new($ani->getBounds);
 193                 print $frame->gifanimadd;
 194                 my $length = 30 / .042;
 195                 my $last = 0;
 196                 for (@$map) {
 197                         my ($time, $player, $cmd, @data) = @$_;
 198 #$time < $length * 10 or last;
 199                         while ($time > $last + $length) {
 200                                 $last += $length;
 201                                 print $frame->gifanimadd(0, 0, 0, 32);
 202 #                               $frame = GD::Image->new($ani->getBounds);
 203                         }
 204                         if ($cmd eq "build") {
 205                                 $frame->setPixel($data[1]>>5, $data[2]>>5, $plot[$player]);
 206                         }
 207                         elsif ($cmd eq "move" or $cmd eq "attack") {
 208                                 $frame->setPixel($data[0]>>5, $data[1]>>5, $plot[$player]);
 209 #                                       if $data[2] == 0xFFFF_FFFF;
 210                         }
 211                 }
 212 #               add_frame_data($frame);
 213                 print $frame->gifanimadd;
 214         }
 215         print $ani->gifanimend;
 216         select STDOUT;
 217 }
 218
 219 use Games::StarCraft::DB;
 220 my $Db = Games::StarCraft::DB->connect({RaiseError => 1})
 221         or die "No database: $DBI::errstr\n";
 222 sub findaccount ($) {
 223         my ($name) = @_;
 224         my $query = $Db->query(q{
 225                 SELECT DISTINCT account FROM play
 226                 WHERE name = ? AND account IS NOT NULL
 227         }, $name);
 228         return $query->rows == 1 ? $query->list : undef;
 229 }
 230
 231 if ($DBGAME) {{
 232         print "\n";
 233         my $game = $Db->query("SELECT * FROM game WHERE id=?", $DBGAME)->hash;
 234         if (not $game) {
 235                 printf "Database game # %d not found\n", $DBGAME;
 236                 last;
 237         }
 238         if ($game->{map} ne $head->{map}) {
 239                 printf "Replay map (%s) does not match database map (%s)\n",
 240                         $head->{map}, $game->{map};
 241                 last;
 242         }
 243
 244         $Db->begin;
 245         $Db->insert("game", {
 246                 frames => $head->{frames},
 247 #               map => $head->{map},
 248 #               start => time2str('%Y-%m-%d %X', $head->{time}),
 249         #       endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
 250 #               durationguess => \"endreplay - start",
 251         });
 252         $Db->update("play", {
 253                 name => $_->{name}, #TODO: --force
 254                 race => $_->{race}, #      --force
 255                 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
 256                 team => $_->{team},
 257                 color => $_->{color},
 258         }, {
 259                 game => $DBGAME,
 260                 slot => $_->{slot},
 261         }) for values %stats;
 262         $Db->commit;
 263 }}
 264
 265 if ($DBNAME) {
 266         print "\n";
 267         my @repstats = stat $DBNAME or die "no rep: $!\n";
 268         my ($name) = $DBNAME =~ m{.*/([^.]+)};
 269
 270         my %placetxt = (
 271                 bn => "bnet",
 272                 gr => "groningen",
 273                 md => "mdhq",
 274         );
 275         my ($placeid) = $name =~ /.*([a-z]{2})/;
 276         my $place = defined $placetxt{$placeid} ? $placetxt{$placeid} : undef;
 277
 278         my $winslot;
 279         if (@ARGV == 1 and $ARGV[0] =~ /^\d$/) {
 280                 $winslot = $ARGV[0];
 281         }
 282
 283         $Db->begin;
 284         $Db->insert("game", {
 285                 name => $name,
 286                 frames => $head->{frames},
 287                 map => $head->{map},
 288                 start => time2str('%Y-%m-%d %X', $head->{time}),
 289                 endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
 290 #               durationguess => \"endreplay - start",
 291                 place => $place,
 292         });
 293         my $gameid = $Db->last_insert_id((undef)x4, {sequence => "game_id_seq"});
 294         $Db->update("game", {durationguess => \"endreplay - start"}, {id => $gameid});
 295         $Db->insert("play", {
 296                 game => $gameid,
 297                 slot => $_->{slot},
 298                 name => $_->{name},
 299                 race => $_->{race},
 300                 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
 301                 team => $_->{team},
 302                 color => $_->{color},
 303                 account => findaccount($_->{name}),
 304                 result => defined $winslot ? $_->{slot} == $winslot ? 1 : -1 : 0,
 305         }) for values %stats;
 306         $Db->commit;
 307 }
 308
 309 if ($APMSVG) {
 310         my @seq;  # player => time (s) => actions
 311         $seq[$_->[1]][$_->[0] * .042]++ for @$map;
 312         my $flatten = 120;
 313         my @apm;
 314         for my $player (0 .. $#seq) {
 315                 my $range = 0;
 316                    $range += $seq[$player][$_] || 0 for 0 .. $flatten - 1;
 317                 my $leadfill = $range / $flatten;
 318                 for my $frame (0 .. $#{$seq[$player]}) {
 319                         $range += $seq[$player][$frame] || 0;
 320                         $range -= $frame < $flatten ? $leadfill :
 321                                 $seq[$player][$frame - $flatten] || 0;
 322                         $apm[$player][$frame] = $range / $flatten;
 323                 }
 324         }
 325
 326         BEGIN { unshift @INC, '.' }
 327         use SVG::TT::Graph::TimeSeries;
 328         my $graph = SVG::TT::Graph::TimeSeries->new({
 329                 height => 1200,
 330                 width => 1600,
 331                 style_sheet => "apm.css",
 332                 show_data_values => 0,
 333                 show_data_points => 0,
 334                 x_label_format => '%k:%M',
 335                 key => 1,
 336                 timescale_divisions => "5 minutes",
 337         #       compress => 1,
 338         });
 339
 340         for my $player (0 .. $#apm) {
 341                 $graph->add_data({
 342                         data => [map {
 343                                 time2str('%Y-%m-%d %X', 946681200 + $_),
 344                                 $apm[$player][$_] * 60
 345                         } 0 .. $#{$apm[$player]} ],
 346                         title => showplayer($player),
 347                 });
 348         }
 349
 350         my ($name) = $APMSVG =~ /([^.]+)/;
 351         my $title = "APM timeline" . ($name && " for $name");
 352         my $lead = sprintf "\n<title>%s</title>", $title;
 353
 354         my $svg = $graph->burn();
 355         s/^[ \t\r]+\n//gm,  # remove lines with only whitespace (many useless ^M)
 356         s/[ \t\r]+$//gm,    # trailing whitespace
 357         s/ {4}\r*/\t/g,     # tabs for indenting
 358         s/^(<svg width=")1600(" height=")1200("[^>]*>)/${1}100%${2}100%$3$lead/m,
 359                 for $svg; # cleanup xml
 360
 361         open my $apmfile, '>', "$APMSVG.svg";
 362         print $apmfile $svg;
 363 }
 364
 365 __END__
 366
 367 =head1 NAME
 368
 369 screp - StarCraft replay parser
 370
 371 =head1 SYNOPSIS
 372
 373 screp [options] < [replay data]
 374
 375  Options:
 376    --verbose
 377    --apm
 378    --act
 379    --dbname
 380    --dbid
 381
 382 =head1 OPTIONS
 383
 384 =head1 AUTHOR
 385
 386 Mischa POSLAWSKY <perl@shiar.org>
 387
 388 =head1 STUFF
 389