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         require 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 if ($DBGAME or $DBNAME) {
 220
 221 require Games::StarCraft::DB;
 222 my $Db = Games::StarCraft::DB->connect({RaiseError => 1})
 223         or die "No database: $DBI::errstr\n";
 224
 225 sub findaccount ($) {
 226         my ($name) = @_;
 227         my $query = $Db->query(q{
 228                 SELECT DISTINCT account FROM play
 229                 WHERE name = ? AND account IS NOT NULL
 230         }, $name);
 231         return $query->rows == 1 ? $query->list : undef;
 232 }
 233
 234 if ($DBGAME) {{
 235         print "\n";
 236         my $game = $Db->query("SELECT * FROM game WHERE id=?", $DBGAME)->hash;
 237         if (not $game) {
 238                 printf "Database game # %d not found\n", $DBGAME;
 239                 last;
 240         }
 241         if ($game->{map} ne $head->{map}) {
 242                 printf "Replay map (%s) does not match database map (%s)\n",
 243                         $head->{map}, $game->{map};
 244                 last;
 245         }
 246
 247         $Db->begin;
 248         $Db->insert("game", {
 249                 frames => $head->{frames},
 250 #               map => $head->{map},
 251 #               start => time2str('%Y-%m-%d %X', $head->{time}),
 252         #       endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
 253 #               durationguess => \"endreplay - start",
 254         });
 255         $Db->update("play", {
 256                 name => $_->{name}, #TODO: --force
 257                 race => $_->{race}, #      --force
 258                 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
 259                 team => $_->{team},
 260                 color => $_->{color},
 261         }, {
 262                 game => $DBGAME,
 263                 slot => $_->{slot},
 264         }) for values %stats;
 265         $Db->commit;
 266 }}
 267
 268 if ($DBNAME) {
 269         print "\n";
 270         my @repstats = stat $DBNAME or die "no rep: $!\n";
 271         my ($name) = $DBNAME =~ m{.*/([^.]+)};
 272
 273         my %placetxt = (
 274                 bn => "bnet",
 275                 gr => "groningen",
 276                 md => "mdhq",
 277         );
 278         my ($placeid) = $name =~ /.*([a-z]{2})/;
 279         my $place = defined $placetxt{$placeid} ? $placetxt{$placeid} : undef;
 280
 281         my $winslot;
 282         if (@ARGV == 1 and $ARGV[0] =~ /^\d$/) {
 283                 $winslot = $ARGV[0];
 284         }
 285
 286         $Db->begin;
 287         $Db->insert("game", {
 288                 name => $name,
 289                 frames => $head->{frames},
 290                 map => $head->{map},
 291                 start => time2str('%Y-%m-%d %X', $head->{time}),
 292                 endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
 293 #               durationguess => \"endreplay - start",
 294                 place => $place,
 295         });
 296         my $gameid = $Db->last_insert_id((undef)x4, {sequence => "game_id_seq"});
 297         $Db->update("game", {durationguess => \"endreplay - start"}, {id => $gameid});
 298         $Db->insert("play", {
 299                 game => $gameid,
 300                 slot => $_->{slot},
 301                 name => $_->{name},
 302                 race => $_->{race},
 303                 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
 304                 team => $_->{team},
 305                 color => $_->{color},
 306                 account => findaccount($_->{name}),
 307                 result => defined $winslot ? $_->{slot} == $winslot ? 1 : -1 : 0,
 308         }) for values %stats;
 309         $Db->commit;
 310 }
 311
 312 }
 313
 314 if ($APMSVG) {
 315         my @seq;  # player => time (s) => actions
 316         $seq[$_->[1]][$_->[0] * .042]++ for @$map;
 317         my $flatten = 120;
 318         my @apm;
 319         for my $player (0 .. $#seq) {
 320                 my $range = 0;
 321                    $range += $seq[$player][$_] || 0 for 0 .. $flatten - 1;
 322                 my $leadfill = $range / $flatten;
 323                 for my $frame (0 .. $#{$seq[$player]}) {
 324                         $range += $seq[$player][$frame] || 0;
 325                         $range -= $frame < $flatten ? $leadfill :
 326                                 $seq[$player][$frame - $flatten] || 0;
 327                         $apm[$player][$frame] = $range / $flatten;
 328                 }
 329         }
 330
 331         BEGIN { unshift @INC, '.' }
 332         require SVG::TT::Graph::TimeSeries;
 333         my $graph = SVG::TT::Graph::TimeSeries->new({
 334                 height => 1200,
 335                 width => 1600,
 336                 style_sheet => "apm.css",
 337                 show_data_values => 0,
 338                 show_data_points => 0,
 339                 x_label_format => '%k:%M',
 340                 key => 1,
 341                 timescale_divisions => "5 minutes",
 342         #       compress => 1,
 343         });
 344
 345         for my $player (0 .. $#apm) {
 346                 $graph->add_data({
 347                         data => [map {
 348                                 time2str('%Y-%m-%d %X', 946681200 + $_),
 349                                 $apm[$player][$_] * 60
 350                         } 0 .. $#{$apm[$player]} ],
 351                         title => showplayer($player),
 352                 });
 353         }
 354
 355         my ($name) = $APMSVG =~ /([^.]+)/;
 356         my $title = "APM timeline" . ($name && " for $name");
 357         my $lead = sprintf "\n<title>%s</title>", $title;
 358
 359         my $svg = $graph->burn();
 360         s/^[ \t\r]+\n//gm,  # remove lines with only whitespace (many useless ^M)
 361         s/[ \t\r]+$//gm,    # trailing whitespace
 362         s/ {4}\r*/\t/g,     # tabs for indenting
 363         s/^(<svg width=")1600(" height=")1200("[^>]*>)/${1}100%${2}100%$3$lead/m,
 364                 for $svg; # cleanup xml
 365
 366         open my $apmfile, '>', "$APMSVG.svg";
 367         print $apmfile $svg;
 368 }
 369
 370 __END__
 371
 372 =head1 NAME
 373
 374 screp - StarCraft replay parser
 375
 376 =head1 SYNOPSIS
 377
 378 screp [options] < [replay data]
 379
 380  Options:
 381    --verbose
 382    --apm
 383    --act
 384    --dbname
 385    --dbid
 386
 387 =head1 OPTIONS
 388
 389 =head1 AUTHOR
 390
 391 Mischa POSLAWSKY <perl@shiar.org>
 392
 393 =head1 STUFF
 394