screp

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use Data::Dumper;
   5
   6 use Data::StarCraft::Replay;
   7
   8 my $SHOWWARN = 0;
   9 my $ACTGIF = undef;
  10 my $APMSVG = undef;
  11
  12 use Getopt::Long;
  13 GetOptions(
  14         "verbose|v!" => \$SHOWWARN,
  15         "apm|a=s" => \$APMSVG,
  16         "act" => \$ACTGIF,
  17 );
  18
  19 use constant { APM_FIRSTFRAME => 80 / .042 };
  20
  21 my @race = (qw(Z T P), (undef) x 3, '-');
  22
  23 sub showtime {
  24         my $time = shift() * .042;
  25         my $minutes = int($time / 60);
  26         return sprintf "%d:%04.1f", $minutes, $time - $minutes * 60;
  27 }
  28
  29 sub unpackhash {
  30         my ($template, $expr, @elements) = @_;
  31         my @data = unpack $template, $expr;
  32         my %map;
  33         $map{$_} = shift @data for @elements;
  34         return (\%map, @data);
  35 }
  36
  37 local $_ = Data::StarCraft::Replay::_read(undef, \*STDIN, 633)
  38         and my ($head, @headdata) = unpackhash("CVa3Va12Z28v2Z16Z24CZ26a38a*", $_, qw(
  39                 engine frames mag1 time mag2 name width height
  40                 unknown1 creator unknown2 map unknown3
  41         ))
  42         or die "Couldn't read replay header\n";
  43
  44 $_ eq "\0\0\110" or warn sprintf(
  45         "Mismatch in first header constant: %s\n",
  46         join ",", map ord, split //, $_
  47 ) for $head->{mag1};
  48 $_ eq "\10"x8 . "\0"x4 or warn sprintf(
  49         "Mismatch in second header constant: %s\n",
  50         join ",", map ord, split //, $_
  51 ) for $head->{mag2};
  52 delete $head->{$_} for qw(mag1 mag2 unknown1 unknown2);
  53
  54 my @playdata = unpack "Va32"x12 . "V8C8", $headdata[0]
  55         or die "Couldn't parse player data in replay header\n";
  56
  57 my (@player, @slot);
  58 for (0 .. 11) {
  59         my $number = shift @playdata;
  60         defined $player[$number] and warn "Player #$number redefined";
  61         my ($data) = unpackhash("VcccZ25", shift @playdata, qw(
  62                 slot type race unknown name
  63         ));
  64         defined $race[$_] ? ($data->{race} = $race[$_]) :
  65                 warn "Unknown race #$_ for player $number"
  66                 for $data->{race};
  67         $slot[$data->{slot}] = $number if $data->{slot} < 16;
  68         $player[$number] = $data;
  69 }
  70 $player[$_]->{color} = shift @playdata for 0 .. 7;
  71 $player[$_]->{index} = shift @playdata for 0 .. 7;
  72
  73 sub showplayer {
  74         my $id = shift;
  75         my $playdata = $player[$slot[$id]];
  76         return defined $playdata ?
  77                 sprintf '%s (%s)', $playdata->{name}, $playdata->{race} : "#$id";
  78 }
  79
  80 printf "%s: %s\n", $_, $head->{$_} for qw(name creator);
  81 use Date::Format;
  82 printf "created: %s\n", time2str('%Y-%m-%d %X', $_) for $head->{time};
  83 printf "map: %s (%dx%d)\n", map $head->{$_}, qw(map width height);
  84 printf "frames: %s (%s)\n", $_, showtime($_) for $head->{frames};
  85 print "\n";
  86
  87 if ($SHOWWARN) {
  88         print Dumper $head;
  89         print Dumper \@player;
  90         #printf ":%s\n", join ",", map sprintf('%X', ord $_), split // for @headdata;
  91         print "\n";
  92 }
  93
  94 my $map = Data::StarCraft::Replay->new->open(\*STDIN);
  95
  96 if ($SHOWWARN) {
  97         for (@$map) {
  98                 my ($time, $player, $desc, @data) = @$_;
  99                 printf("@%s #%d %s: %s\n",
 100                         showtime($time), $player, $desc, join(", ", @data)
 101                 );
 102         }
 103 }
 104
 105 my %cmdmacro = map {$_ => 1} (
 106         (map {$_, "cancel $_"}
 107                 qw/train build hatch research upgrade arm/,
 108         ),
 109         qw/hotkey vision part rally/,
 110         # rally
 111 );
 112
 113 my %stats; # player => count
 114 for (@$map) {
 115         $stats{$_->[1]}{actions}++;
 116         $stats{$_->[1]}{gameactions}++ if $_->[0] >= APM_FIRSTFRAME;
 117         $stats{$_->[1]}{last} = $_->[0] if $_->[2] eq "part";
 118         $stats{$_->[1]}{$cmdmacro{$_->[2]} ? "macro" : "micro"}++;
 119         $stats{$_->[1]}{count}{$_->[2]}++;
 120 }
 121
 122 for my $player (sort keys %stats) {
 123         my $row = $stats{$player};
 124         $row->{last} ||= $map->[-1][0];
 125 #       printf("%-16s%6d actions (%3d micro,%4d macro);%4d APM\n",
 126         my $name = showplayer($player);
 127         printf("%-16s%6d actions in%7d frames (%s) = %d APM\n",
 128                 $name, $row->{actions}, $row->{last},
 129                 showtime($row->{last}),
 130 #               $row->{micro} / $row->{last} * 60 / .042 * 1.05,
 131 #               $row->{macro} / $row->{last} * 60 / .042 * 1.05,
 132                 $row->{gameactions} / ($row->{last} - APM_FIRSTFRAME) * 60 / .042,
 133         );
 134
 135         if (0) {
 136                 my @order; # pos => [ [ pct, cmd ] ]
 137                 my $i = 2;
 138                 push @{$order[++$i % 16]}, [ ($_->[0] / $row->{last}), $_->[6] ]
 139                         for grep {$_->[1] == $player and $_->[2] eq "build"} @$map;
 140                 print "build order:\n";
 141                 for (@order) {
 142                         my $lastpos = 0;
 143                         for (@$_) {
 144                                 my ($pos, $txt) = @$_;
 145                                 print ' ' x ($pos*60 - $lastpos);
 146                                 $txt = substr $txt, 0, 8;
 147                                 print $txt;
 148                                 $lastpos = $pos + length $txt;
 149                         }
 150                         print "\n";
 151                 }
 152         }
 153
 154         printf("action distribution: %s\n",
 155                 join(", ", map {
 156                         sprintf "%s (%d%%)", $_, $row->{count}{$_} / $row->{actions} * 100
 157                 } (
 158                         sort {$row->{count}{$b} <=> $row->{count}{$a}}
 159                         keys %{ $row->{count} }
 160                 )[0..7]),
 161         ) if 0;
 162 }
 163
 164 if ($ACTGIF) {
 165         open my $imgfile, '>', "test.gif" or die;
 166         binmode $imgfile;
 167         select $imgfile;
 168
 169         use GD;
 170         my $ani = GD::Image->new($head->{width}, $head->{height});
 171         my $bg = $ani->colorAllocate(0, 0, 0);
 172         my @plot = (
 173                 $ani->colorAllocate(255, 0, 0),
 174                 $ani->colorAllocate(255, 255, 0),
 175                 $ani->colorAllocate(0, 255, 0),
 176                 $ani->colorAllocate(0, 255, 255),
 177                 $ani->colorAllocate(0, 0, 255),
 178                 $ani->colorAllocate(255, 0, 255),
 179         );
 180
 181         print $ani->gifanimbegin;
 182 #       print $ani->gifanimadd;
 183         {
 184                 my $frame = GD::Image->new($ani->getBounds);
 185                 print $frame->gifanimadd;
 186                 my $length = 30 / .042;
 187                 my $last = 0;
 188                 for (@$map) {
 189                         my ($time, $player, $cmd, @data) = @$_;
 190 #$time < $length * 10 or last;
 191                         while ($time > $last + $length) {
 192                                 $last += $length;
 193                                 print $frame->gifanimadd(0, 0, 0, 32);
 194 #                               $frame = GD::Image->new($ani->getBounds);
 195                         }
 196                         if ($cmd eq "build") {
 197                                 $frame->setPixel($data[1]>>5, $data[2]>>5, $plot[$player]);
 198                         }
 199                         elsif ($cmd eq "move" or $cmd eq "attack") {
 200                                 $frame->setPixel($data[0]>>5, $data[1]>>5, $plot[$player]);
 201 #                                       if $data[2] == 0xFFFF_FFFF;
 202                         }
 203                 }
 204 #               add_frame_data($frame);
 205                 print $frame->gifanimadd;
 206         }
 207         print $ani->gifanimend;
 208         select STDOUT;
 209 }
 210
 211 if ($APMSVG) {
 212         my @seq;  # player => time (s) => actions
 213         $seq[$_->[1]][$_->[0] * .042]++ for @$map;
 214         my $flatten = 120;
 215         my @apm;
 216         for my $player (0 .. $#seq) {
 217                 my $range = 0;
 218                    $range += $seq[$player][$_] || 0 for 0 .. $flatten - 1;
 219                 my $leadfill = $range / $flatten;
 220                 for my $frame (0 .. $#{$seq[$player]}) {
 221                         $range += $seq[$player][$frame] || 0;
 222                         $range -= $frame < $flatten ? $leadfill :
 223                                 $seq[$player][$frame - $flatten] || 0;
 224                         $apm[$player][$frame] = $range / $flatten;
 225                 }
 226         }
 227
 228         BEGIN { unshift @INC, '.' }
 229         use SVG::TT::Graph::TimeSeries;
 230         my $graph = SVG::TT::Graph::TimeSeries->new({
 231                 height => 1200,
 232                 width => 1600,
 233                 style_sheet => "apm.css",
 234                 show_data_values => 0,
 235                 show_data_points => 0,
 236                 x_label_format => '%k:%M',
 237                 key => 1,
 238                 timescale_divisions => "5 minutes",
 239         #       compress => 1,
 240         });
 241
 242         for my $player (0 .. $#apm) {
 243                 $graph->add_data({
 244                         data => [map {
 245                                 time2str('%Y-%m-%d %X', 946681200 + $_),
 246                                 $apm[$player][$_] * 60
 247                         } 0 .. $#{$apm[$player]} ],
 248                         title => showplayer($player),
 249                 });
 250         }
 251
 252         my ($name) = $APMSVG =~ /([^.]+)/;
 253         my $title = "APM timeline" . ($name && " for $name");
 254         my $lead = sprintf "\n<title>%s</title>", $title;
 255
 256         my $svg = $graph->burn();
 257         s/^[ \t\r]+\n//gm,  # remove lines with only whitespace (many useless ^M)
 258         s/[ \t\r]+$//gm,    # trailing whitespace
 259         s/ {4}\r*/\t/g,     # tabs for indenting
 260         s/^(<svg width=")1600(" height=")1200("[^>]*>)/${1}100%${2}100%$3$lead/m,
 261                 for $svg; # cleanup xml
 262
 263         open my $apmfile, '>', "$APMSVG.svg";
 264         print $apmfile $svg;
 265 }
 266