5 use Data::StarCraft::Replay;
15 use Getopt::Long qw(:config bundling auto_version auto_help);
17 "verbose|v!" => \$SHOWWARN,
18 "apm|a=s" => \$APMSVG,
20 "dbname|D=s" => \$DBNAME,
21 "dbid|d=s" => \$DBGAME,
24 use constant { APM_FIRSTFRAME => 80 / .042 };
26 my @race = (qw(Z T P), (undef) x 3, '-');
29 my $time = shift() * .042;
30 my $minutes = int($time / 60);
31 return sprintf "%d:%04.1f", $minutes, $time - $minutes * 60;
35 my ($template, $expr, @elements) = @_;
36 my @data = unpack $template, $expr;
38 $map{$_} = shift @data for @elements;
39 return (\%map, @data);
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
47 or die "Couldn't read replay header\n";
49 $_ eq "\0\0\110" or warn sprintf(
50 "Mismatch in first header constant: %s\n",
51 join ",", map ord, split //, $_
53 $_ eq "\10"x8 . "\0"x4 or warn sprintf(
54 "Mismatch in second header constant: %s\n",
55 join ",", map ord, split //, $_
57 delete $head->{$_} for qw(mag1 mag2 unknown1 unknown2);
59 my @playdata = unpack "Va32"x12 . "V8C8", $headdata[0]
60 or die "Couldn't parse player data in replay header\n";
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
69 defined $race[$_] ? ($data->{race} = $race[$_]) :
70 warn "Unknown race #$_ for player $number"
72 $slot[$data->{slot}] = $number if $data->{slot} < 16;
73 $player[$number] = $data;
75 $player[$_]->{color} = shift @playdata for 0 .. 7;
76 $player[$_]->{index} = shift @playdata for 0 .. 7;
80 my $playdata = $player[$slot[$id]];
81 return defined $playdata ?
82 sprintf '%s (%s)', $playdata->{name}, $playdata->{race} : "#$id";
85 printf "%s: %s\n", $_, $head->{$_} for qw(name creator);
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};
94 print Dumper \@player;
95 #printf ":%s\n", join ",", map sprintf('%X', ord $_), split // for @headdata;
99 my $map = Data::StarCraft::Replay->new->open(\*STDIN);
103 my ($time, $player, $desc, @data) = @$_;
104 printf("@%s #%d %s: %s\n",
105 showtime($time), $player, $desc, join(", ", @data)
110 my %cmdmacro = map {$_ => 1} (
111 (map {$_, "cancel $_"}
112 qw/train build hatch research upgrade arm/,
114 qw/hotkey vision part rally/,
118 my %stats; # player => count
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]}++;
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",
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,
144 my @order; # pos => [ [ pct, cmd ] ]
146 push @{$order[++$i % 16]}, [ ($_->[0] / $row->{last}), $_->[6] ]
147 for grep {$_->[1] == $player and $_->[2] eq "build"} @$map;
148 print "build order:\n";
152 my ($pos, $txt) = @$_;
153 print ' ' x ($pos*60 - $lastpos);
154 $txt = substr $txt, 0, 8;
156 $lastpos = $pos + length $txt;
162 printf("action distribution: %s\n",
164 sprintf "%s (%d%%)", $_, $row->{count}{$_} / $row->{actions} * 100
166 sort {$row->{count}{$b} <=> $row->{count}{$a}}
167 keys %{ $row->{count} }
173 open my $imgfile, '>', "test.gif" or die;
178 my $ani = GD::Image->new($head->{width}, $head->{height});
179 my $bg = $ani->colorAllocate(0, 0, 0);
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),
189 print $ani->gifanimbegin;
190 # print $ani->gifanimadd;
192 my $frame = GD::Image->new($ani->getBounds);
193 print $frame->gifanimadd;
194 my $length = 30 / .042;
197 my ($time, $player, $cmd, @data) = @$_;
198 #$time < $length * 10 or last;
199 while ($time > $last + $length) {
201 print $frame->gifanimadd(0, 0, 0, 32);
202 # $frame = GD::Image->new($ani->getBounds);
204 if ($cmd eq "build") {
205 $frame->setPixel($data[1]>>5, $data[2]>>5, $plot[$player]);
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;
212 # add_frame_data($frame);
213 print $frame->gifanimadd;
215 print $ani->gifanimend;
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 ($) {
224 my $query = $Db->query(q{
225 SELECT DISTINCT account FROM play
226 WHERE name = ? AND account IS NOT NULL
228 return $query->rows == 1 ? $query->list : undef;
233 my $game = $Db->query("SELECT * FROM game WHERE id=?", $DBGAME)->hash;
235 printf "Database game # %d not found\n", $DBGAME;
238 if ($game->{map} ne $head->{map}) {
239 printf "Replay map (%s) does not match database map (%s)\n",
240 $head->{map}, $game->{map};
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",
252 $Db->update("play", {
253 name => $_->{name}, #TODO: --force
254 race => $_->{race}, # --force
255 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
257 color => $_->{color},
261 }) for values %stats;
267 my @repstats = stat $DBNAME or die "no rep: $!\n";
268 my ($name) = $DBNAME =~ m{.*/([^.]+)};
275 my ($placeid) = $name =~ /.*([a-z]{2})/;
276 my $place = defined $placetxt{$placeid} ? $placetxt{$placeid} : undef;
279 if (@ARGV == 1 and $ARGV[0] =~ /^\d$/) {
284 $Db->insert("game", {
286 frames => $head->{frames},
288 start => time2str('%Y-%m-%d %X', $head->{time}),
289 endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
290 # durationguess => \"endreplay - start",
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", {
300 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
302 color => $_->{color},
303 account => findaccount($_->{name}),
304 result => defined $winslot ? $_->{slot} == $winslot ? 1 : -1 : 0,
305 }) for values %stats;
310 my @seq; # player => time (s) => actions
311 $seq[$_->[1]][$_->[0] * .042]++ for @$map;
314 for my $player (0 .. $#seq) {
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;
326 BEGIN { unshift @INC, '.' }
327 use SVG::TT::Graph::TimeSeries;
328 my $graph = SVG::TT::Graph::TimeSeries->new({
331 style_sheet => "apm.css",
332 show_data_values => 0,
333 show_data_points => 0,
334 x_label_format => '%k:%M',
336 timescale_divisions => "5 minutes",
340 for my $player (0 .. $#apm) {
343 time2str('%Y-%m-%d %X', 946681200 + $_),
344 $apm[$player][$_] * 60
345 } 0 .. $#{$apm[$player]} ],
346 title => showplayer($player),
350 my ($name) = $APMSVG =~ /([^.]+)/;
351 my $title = "APM timeline" . ($name && " for $name");
352 my $lead = sprintf "\n<title>%s</title>", $title;
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
361 open my $apmfile, '>', "$APMSVG.svg";
369 screp - StarCraft replay parser
373 screp [options] < [replay data]
386 Mischa POSLAWSKY <perl@shiar.org>