13 use Getopt::Long qw(:config bundling auto_version auto_help);
15 "verbose|v!" => \$SHOWWARN,
16 "apm|a=s" => \$APMSVG,
17 "dbname|D=s" => \$DBNAME,
18 "dbid|d=s" => \$DBGAME,
21 use constant { APM_FIRSTFRAME => 80 / .042 };
25 package Data::StarCraft::Replay;
51 0x09 => "Science Vessel",
54 0x0C => "Battlecruiser",
76 0x32 => "Infested Terran",
81 0x3D => "Dark Templar",
87 0x43 => "High Templar",
100 0x6A => "Command Center",
102 0x6C => "Nuclear Silo",
103 0x6D => "Supply Depot",
104 0x6E => "Refinery", # refinery?
106 0x70 => "Academy", # Academy?
109 0x73 => "Control Tower",
110 0x74 => "Science Facility",
111 0x75 => "Covert Ops",
112 0x76 => "Physics Lab",
114 0x78 => "Machine Shop",
116 0x7A => "Engineering Bay",
118 0x7C => "Missile Turret",
121 0x82 => "Infested CC",
125 0x86 => "Nydus Canal",
126 0x87 => "Hydralisk Den",
127 0x88 => "Defiler Mound",
128 0x89 => "Greater Spire",
129 0x8A => "Queens Nest",
130 0x8B => "Evolution Chamber",
131 0x8C => "Ultralisk Cavern",
133 0x8E => "Spawning Pool",
134 0x8F => "Creep Colony",
135 0x90 => "Spore Colony",
137 0x92 => "Sunken Colony",
143 0x9B => "Robotics Facility",
145 0x9D => "Assimilator",
147 0x9F => "Observatory",
150 0xA2 => "Photon Cannon",
151 0xA3 => "Citadel of Adun",
152 0xA4 => "Cybernetics Core",
153 0xA5 => "Templar Archives",
157 0xA9 => "Fleet Beacon",
158 0xAA => "Arbiter Tribunal",
159 0xAB => "Robotics Support Bay",
160 0xAC => "Shield Battery",
164 0xC2 => "Dark Archon",
167 0xC5 => "Interceptor",
168 0xC6 => "Interceptor/Scarab",
171 "Terran Infantry Armor",
172 "Terran Vehicle Plating",
173 "Terran Ship Plating",
175 "Zerg Flyer Carapace",
176 "Protoss Ground Armor",
178 "Terran Infantry Weapons",
179 "Terran Vehicle Weapons",
180 "Terran Ship Weapons",
181 "Zerg Melee Attacks",
182 "Zerg Missile Attacks",
183 "Zerg Flyer Attacks",
184 "Protoss Ground Weapons",
185 "Protoss Air Weapons",
186 "Protoss Plasma Shields",
188 "U-238 Shells (Marine Range)",
189 "Ion Thrusters (Vulture Speed)",
191 "Titan Reactor (Science Vessel Energy)",
192 "Ocular Implants (Ghost Sight)",
193 "Moebius Reactor (Ghost Energy)",
194 "Apollo Reactor (Wraith Energy)",
195 "Colossus Reactor (Battle Cruiser Energy)",
196 "Ventral Sacs (Overlord Transport)",
197 "Antennae (Overlord Sight)",
198 "Pneumatized Carapace (Overlord Speed)",
199 "Metabolic Boost (Zergling Speed)",
200 "Adrenal Glands (Zergling Attack)",
201 "Muscular Augments (Hydralisk Speed)",
202 "Grooved Spines (Hydralisk Range)",
203 "Gamete Meiosis (Queen Energy)",
206 "Singularity Charge (Dragoon Range)",
207 "Leg Enhancement (Zealot Speed)",
210 "Gravitic Drive (Shuttle Speed)",
211 "Sensor Array (Observer Sight)",
212 "Gravitic Booster (Observer Speed)",
213 "Khaydarin Amulet (Templar Energy)",
214 "Apial Sensors (Scout Sight)",
215 "Gravitic Thrusters (Scout Speed)",
217 "Khaydarin Core (Arbiter Energy)",
220 "Argus Jewel (Corsair Energy)",
223 "Argus Talisman (Dark Archon Energy)",
224 "Caduceus Reactor (Medic Energy)",
225 "Chitinous Plating (Ultralisk Armor)",
226 "Anabolic Synthesis (Ultralisk Speed)",
227 "Charon Boosters (Goliath Range)",
239 "Cloaking Field (wraith)",
240 "Personal Cloaking (ghost)",
268 0x02 => "Unallowed Move?",
269 0x06 => "Force move",
272 0x0E => "Attack Move",
273 0x13 => "Failed Casting (?)",
277 0x27 => "Clear Rally",
284 0x77 => "Dark Swarm",
286 0x79 => "Spawn Broodling",
288 0x7E => "Launch Nuke",
290 0x8B => "ComSat Scan",
291 0x8D => "Defense Matrix",
292 0x8E => "Psionic Storm",
298 0x94 => "Hallucination",
302 0xB5 => "Disruption Web",
303 0xB6 => "Mind Control",
305 0xB9 => "Optic Flare",
311 0x09 => ["select", 1, 2 | CMD_REPEAT],
312 0x0A => ["add", 1, 2 | CMD_REPEAT],
313 0x0B => ["deselect", 1, 2 | CMD_REPEAT],
314 0x0C => ["build", 1, \%build, 2, 2, 2, \%unit],
315 0x0D => ["vision", 2],
316 0x0E => ["ally", 2, 2],
317 0x13 => ["hotkey", 1, [qw"assign select"], 1],
318 0x14 => ["move", 2, 2, 2, 2, 1], # 1 = queued?
319 0x15 => ["action", 2, 2, 2, 2, 1, \%action, 1, [qw"normal queued"]],
321 0x19 => ["cancel hatch"],
323 # 0x1B => ["move-thing??"], # tim: after hotkey (unit, reaver??) select; soon after reselected and moved
324 0x1E => ["return cargo", 1],
325 0x1F => ["train", 2, \%unit],
326 0x20 => ["cancel train", 2], # == 254
327 0x21 => ["cloak", 1],
328 0x22 => ["decloak", 1],
329 0x23 => ["hatch", 2, \%unit],
330 0x25 => ["unsiege", 1],
331 0x26 => ["siege", 1],
332 0x27 => ["arm", 0], # scarab/interceptor
333 0x28 => ["unload all", 1],
334 0x29 => ["unload", 2],
335 0x2A => ["merge archon", 0],
336 0x2B => ["hold position", 1],
337 0x2C => ["burrow", 1],
338 0x2D => ["unburrow", 1],
339 0x2E => ["cancel nuke", 0],
340 0x2F => ["lift", 2, 2],
341 0x30 => ["research", 1, \@research],
342 0x31 => ["cancel research", 0],
343 0x32 => ["upgrade", 1, \@upgrade],
344 # 0x33 => ["forge-thing??"], # right after forge select: probably unpowered, iirc cancel research
345 0x35 => ["morph", 2, \%unit],
347 0x57 => ["part", 1, {qw"1 quit 6 drop"}],
348 0x5A => ["merge dark archon", 0],
358 my ($fh, $size, $seek) = @_;
359 seek *$fh, $seek, 0 if $seek;
360 read(*$fh, my $in, $size) eq $size or return undef;
368 while (not eof $file) {
369 local $_ = $self->_read($file, 5)
370 and my ($time, $size) = unpack "VC", $_
371 or die "Couldn't read time block head\n";
372 local $_ = $self->_read($file, $size)
373 and my @block = unpack "C*", $_
374 or die "Couldn't read time block data\n";
376 my $player = shift @block;
377 my $cmd = shift @block;
378 if (not defined $cmdread{$cmd}) {
379 warn sprintf "command #%X not defined: %d bytes ignored\n",
381 push @$self, [$time, $player, "??? $cmd"] if $SHOWWARN;
386 my ($data, $byte) = @_;
387 my $out = shift @$data;
388 if (($byte & 3) == 2) {
389 @$data ? ($out += shift(@$data) << 8)
390 : warn "high byte not present\n";
395 my @format = @{ $cmdread{$cmd} };
396 my $desc = shift @format;
398 for my $bit (@format) {
400 if (ref $bit eq "ARRAY") {
401 $data[-1] = defined $bit->[$data[-1]] ? $bit->[$data[-1]]
404 $data[-1] = defined $bit->{$data[-1]} ? $bit->{$data[-1]}
410 if ($bit & CMD_REPEAT) {
411 push @data, readbyte(\@block, $bit) for 1 .. shift @data;
413 push @data, readbyte(\@block, $bit);
416 $desc eq "move" and $data[2] == 0 and $desc = "rally";
417 push @$self, [$time, $player, $desc, @data];
425 my @race = (qw(Z T P), (undef) x 3, '-');
428 my $time = shift() * .042;
429 my $minutes = int($time / 60);
430 return sprintf "%d:%04.1f", $minutes, $time - $minutes * 60;
434 my ($template, $expr, @elements) = @_;
435 my @data = unpack $template, $expr;
437 $map{$_} = shift @data for @elements;
438 return (\%map, @data);
441 local $_ = Data::StarCraft::Replay::_read(undef, \*STDIN, 633)
442 and my ($head, @headdata) = unpackhash("CVa3Va12Z28v2Z16Z24CZ26a38a*", $_, qw(
443 engine frames mag1 time mag2 name width height
444 unknown1 creator unknown2 map unknown3
446 or die "Couldn't read replay header\n";
448 $_ eq "\0\0\110" or warn sprintf(
449 "Mismatch in first header constant: %s\n",
450 join ",", map ord, split //, $_
452 $_ eq "\10"x8 . "\0"x4 or warn sprintf(
453 "Mismatch in second header constant: %s\n",
454 join ",", map ord, split //, $_
456 delete $head->{$_} for qw(mag1 mag2 unknown1 unknown2);
458 my @playdata = unpack "Va32"x12 . "V8C8", $headdata[0]
459 or die "Couldn't parse player data in replay header\n";
463 my $number = shift @playdata;
464 defined $player[$number] and warn "Player #$number redefined";
465 my ($data) = unpackhash("VcccZ25", shift @playdata, qw(
466 slot type race team name
468 defined $race[$_] ? ($data->{race} = $race[$_]) :
469 warn "Unknown race #$_ for player $number"
471 $slot[$data->{slot}] = $number if $data->{slot} < 16;
472 $player[$number] = $data;
474 $player[$_]->{color} = shift @playdata for 0 .. 7;
475 $player[$_]->{index} = shift @playdata for 0 .. 7;
479 my $playdata = $player[$slot[$id]];
480 return defined $playdata ?
481 sprintf '%s (%s)', $playdata->{name}, $playdata->{race} : "#$id";
484 printf "%s: %s\n", $_, $head->{$_} for qw(name creator);
486 printf "created: %s\n", time2str('%Y-%m-%d %X', $_) for $head->{time};
487 printf "map: %s (%dx%d)\n", map $head->{$_}, qw(map width height);
488 printf "frames: %s (%s)\n", $_, showtime($_) for $head->{frames};
493 print Dumper \@player;
494 #printf ":%s\n", join ",", map sprintf('%X', ord $_), split // for @headdata;
498 my $map = Data::StarCraft::Replay->new->open(\*STDIN);
502 my ($time, $player, $desc, @data) = @$_;
503 printf("@%s #%d %s: %s\n",
504 showtime($time), $player, $desc, join(", ", @data)
509 my %cmdmacro = map {$_ => 1} (
510 (map {$_, "cancel $_"}
511 qw/train build hatch research upgrade arm/,
513 qw/hotkey vision part rally/,
517 my %stats; # player => count
519 $stats{$_->[1]}{actions}++;
520 $stats{$_->[1]}{gameactions}++ if $_->[0] >= APM_FIRSTFRAME;
521 $stats{$_->[1]}{last} = $_->[0] if $_->[2] eq "part";
522 $stats{$_->[1]}{$cmdmacro{$_->[2]} ? "macro" : "micro"}++;
523 $stats{$_->[1]}{count}{$_->[2]}++;
526 for my $player (sort keys %stats) {
527 $stats{$player}{$_} = $player[$slot[$player]]{$_}
528 for keys %{ $player[$slot[$player]] };
529 my $row = $stats{$player};
530 $row->{last} ||= $map->[-1][0];
531 # printf("%-16s%6d actions (%3d micro,%4d macro);%4d APM\n",
532 my $name = showplayer($player);
533 printf("%d %-16s%6d actions in%7d frames (%s) = %d APM\n",
535 $name, $row->{actions}, $row->{last},
536 showtime($row->{last}),
537 # $row->{micro} / $row->{last} * 60 / .042 * 1.05,
538 # $row->{macro} / $row->{last} * 60 / .042 * 1.05,
539 $row->{gameactions} / ($row->{last} - APM_FIRSTFRAME) * 60 / .042,
543 my @order; # pos => [ [ pct, cmd ] ]
545 push @{$order[++$i % 16]}, [ ($_->[0] / $row->{last}), $_->[6] ]
546 for grep {$_->[1] == $player and $_->[2] eq "build"} @$map;
547 print "build order:\n";
551 my ($pos, $txt) = @$_;
552 print ' ' x ($pos*60 - $lastpos);
553 $txt = substr $txt, 0, 8;
555 $lastpos = $pos + length $txt;
561 printf("action distribution: %s\n",
563 sprintf "%s (%d%%)", $_, $row->{count}{$_} / $row->{actions} * 100
565 sort {$row->{count}{$b} <=> $row->{count}{$a}}
566 keys %{ $row->{count} }
571 use Games::StarCraft::DB;
572 my $Db = Games::StarCraft::DB->connect({RaiseError => 1})
573 or die "No database: $DBI::errstr\n";
574 sub findaccount ($) {
576 my $query = $Db->query(q{
577 SELECT DISTINCT account FROM play
578 WHERE name = ? AND account IS NOT NULL
580 return $query->rows == 1 ? $query->list : undef;
585 my $game = $Db->query("SELECT * FROM game WHERE id=?", $DBGAME)->hash;
587 printf "Database game # %d not found\n", $DBGAME;
590 if ($game->{map} ne $head->{map}) {
591 printf "Replay map (%s) does not match database map (%s)\n",
592 $head->{map}, $game->{map};
597 $Db->insert("game", {
598 frames => $head->{frames},
599 # map => $head->{map},
600 # start => time2str('%Y-%m-%d %X', $head->{time}),
601 # endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
602 # durationguess => \"endreplay - start",
604 $Db->update("play", {
605 name => $_->{name}, #TODO: --force
606 race => $_->{race}, # --force
607 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
609 color => $_->{color},
613 }) for values %stats;
619 my @repstats = stat $DBNAME or die "no rep: $!\n";
620 my ($name) = $DBNAME =~ m{.*/([^.]+)};
627 my ($placeid) = $name =~ /.*([a-z]{2})/;
628 my $place = defined $placetxt{$placeid} ? $placetxt{$placeid} : undef;
631 if (@ARGV == 1 and $ARGV[0] =~ /^\d$/) {
636 $Db->insert("game", {
638 frames => $head->{frames},
640 start => time2str('%Y-%m-%d %X', $head->{time}),
641 endreplay => time2str('%Y-%m-%d %X', $repstats[9]), # mtime
642 # durationguess => \"endreplay - start",
645 my $gameid = $Db->last_insert_id((undef)x4, {sequence => "game_id_seq"});
646 $Db->update("game", {durationguess => \"endreplay - start"}, {id => $gameid});
647 $Db->insert("play", {
652 apm => $_->{gameactions} / ($_->{last} - APM_FIRSTFRAME) * 60 / .042,
654 color => $_->{color},
655 account => findaccount($_->{name}),
656 result => defined $winslot ? $_->{slot} == $winslot ? 1 : -1 : 0,
657 }) for values %stats;
662 my @seq; # player => time (s) => actions
663 $seq[$_->[1]][$_->[0] * .042]++ for @$map;
666 for my $player (0 .. $#seq) {
668 $range += $seq[$player][$_] || 0 for 0 .. $flatten - 1;
669 my $leadfill = $range / $flatten;
670 for my $frame (0 .. $#{$seq[$player]}) {
671 $range += $seq[$player][$frame] || 0;
672 $range -= $frame < $flatten ? $leadfill :
673 $seq[$player][$frame - $flatten] || 0;
674 $apm[$player][$frame] = $range / $flatten;
678 BEGIN { unshift @INC, '.' }
679 use SVG::TT::Graph::TimeSeries;
680 my $graph = SVG::TT::Graph::TimeSeries->new({
683 style_sheet => "apm.css",
684 show_data_values => 0,
685 show_data_points => 0,
686 x_label_format => '%k:%M',
688 timescale_divisions => "5 minutes",
692 for my $player (0 .. $#apm) {
695 time2str('%Y-%m-%d %X', 946681200 + $_),
696 $apm[$player][$_] * 60
697 } 0 .. $#{$apm[$player]} ],
698 title => showplayer($player),
702 my ($name) = $APMSVG =~ /([^.]+)/;
703 my $title = "APM timeline" . ($name && " for $name");
704 my $lead = sprintf "\n<title>%s</title>", $title;
706 my $svg = $graph->burn();
707 s/^[ \t\r]+\n//gm, # remove lines with only whitespace (many useless ^M)
708 s/[ \t\r]+$//gm, # trailing whitespace
709 s/ {4}\r*/\t/g, # tabs for indenting
710 s/^(<svg width=")1600(" height=")1200("[^>]*>)/${1}100%${2}100%$3$lead/m,
711 for $svg; # cleanup xml
713 open my $apmfile, '>', "$APMSVG.svg";
721 screp - StarCraft replay parser
725 screp [options] < [replay data]
737 Mischa POSLAWSKY <perl@shiar.org>