capture

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Getopt::Long 2.33 qw(HelpMessage :config bundling);
   7 use Data::Dumper;
   8 use Time::HiRes qw(sleep alarm);
   9 use Imager;
  10
  11 our $VERSION = '2.01';
  12
  13 GetOptions(
  14         "verbose|v!" => \our $DEBUG,
  15         "map|m!" => \our $GETMAP,
  16 ) or HelpMessage(-exitval => 2);
  17
  18 my %digittime = (
  19         '.####.'.
  20         '#....#'.
  21         '#....#'.
  22         '.####.' => 0,
  23         '...#..'.
  24         '######' => 1,
  25         '##..#.'.
  26         '#.#..#'.
  27         '#.#..#'.
  28         '#..##.' => 2,
  29         '.#..#.'.
  30         '#....#'.
  31         '#.#..#'.
  32         '.#.##.' => 3,
  33         '..##..'.
  34         '..#.#.'.
  35         '######'.
  36         '..#...' => 4,
  37         '.#.##.'.
  38         '#..#.#'.
  39         '#..#.#'.
  40         '.##..#' => 5,
  41         '.####.'.
  42         '#..#.#'.
  43         '#..#.#'.
  44         '.##..#' => 6,
  45         '.....#'.
  46         '###..#'.
  47         '...###'.
  48         '.....#' => 7,
  49         '.#.##.'.
  50         '#.#..#'.
  51         '#.#..#'.
  52         '.#.##.' => 8,
  53         '#..##.'.
  54         '#.#..#'.
  55         '#.#..#'.
  56         '.####.' => 9,
  57         '#..#..' => ':',
  58 );
  59
  60 my %digitgreen = (
  61         '.#####.'.
  62         '#.....#'.
  63         '#.....#'.
  64         '#.....#'.
  65         '.#####.' => 0,
  66         '....#..'.
  67         '....#..'.
  68         '#######' => 1,
  69         '##...#.'.
  70         '#.#...#'.
  71         '#.#...#'.
  72         '#..#...'.
  73         '#...##.' => 2,
  74         '.#...#.'.
  75         '#.....#'.
  76         '#..#..#'.
  77         '#..#..#'.
  78         '.##.##.' => 3,
  79         '..##...'.
  80         '..#.#..'.
  81         '..#..#.'.
  82         '#######'.
  83         '..#....' => 4,
  84         '.#.....'.
  85         '#...###'.
  86         '#...#.#'.
  87         '#...#.#'.
  88         '.###..#' => 5,
  89         '.#####.'.
  90         '#...#.#'.
  91         '#...#.#'.
  92         '#...#.#'.
  93         '.###..#' => 6,
  94         '......#'.
  95         '##....#'.
  96         '..##..#'.
  97         '....###'.
  98         '......#' => 7,
  99         '.##.##.'.
 100         '#..#..#'.
 101         '#..#..#'.
 102         '#..#..#'.
 103         '.##.##.' => 8,
 104         '#..###.'.
 105         '#.#...#'.
 106         '#.#...#'.
 107         '#.#...#'.
 108         '.#####.' => 9,
 109         '#......'.
 110         '..##...'.
 111         '.....##' => ':',
 112 );
 113
 114 my $i = 0;
 115
 116 =cut
 117 sub filter_color {
 118         my $input = shift;
 119         my ($r, $g, $b) = @_;
 120         Imager::transform2({
 121                 rpnexpr => <<'EOT',
 122 x y getp1 !pix
 123 @pix red r eq
 124 @pix green g eq and
 125 @pix blue b eq and
 126 35 0 0 rgb 46 0 0 rgb ifp
 127 EOT
 128                 constants => {r => $r, g => $g, b => $b},
 129         }, $input)->convert(preset => 'red')->rotate(right => 90);
 130 }
 131 =cut
 132
 133 sub filter_color {
 134         my $input = shift;
 135         my @output; # line => cols_ascii
 136         for my $y (reverse 0 .. $input->getheight-1) {
 137                 my $colors = $input->getsamples(y => $y);
 138                 for (my $x = 0; length $colors; $x++) {
 139                         my $pixel = substr $colors, 0, 3, '';
 140                         my $match = '.';
 141                         for (@_) {
 142                                 $pixel eq $_ and $match = '#', last;
 143                         }
 144                         $output[$x] .= $match;
 145                 }
 146         }
 147         return \@output;
 148 }
 149
 150 sub getchars {
 151         my $input = shift;
 152         my ($charmap, $width, $y1, $y2) = @_;
 153         my @chars = '';
 154         for my $y ($y1 .. $y2) {
 155 #               my $row = scalar $input->getsamples(y => $y);
 156                 my $row = $input->[$y];
 157                 if ($row eq '.' x $width) {
 158                         push @chars => '';  # next character
 159                 } else {
 160                         $chars[-1] .= $row;  # add line
 161                 }
 162         }
 163         return join '',
 164                 map { defined $charmap->{$_} ? $charmap->{$_} : '?' }
 165                 grep { $_ ne '' } @chars;
 166 }
 167
 168 sub parsestats {
 169         my $input = shift;  # (452,6)-(639,13)
 170         $input->write(file => sprintf "tests%05d.png", $i) or warn $input->errstr
 171                 if $DEBUG;
 172         my $stats = filter_color($input,
 173                 "\020\377\030", "\317\030\030", # CF1818/C81818
 174                 "\310\030\030", # ?/10FF18
 175         );
 176         my $min = getchars($stats, \%digitgreen, 7, 0, 39);
 177         my $gas = getchars($stats, \%digitgreen, 7, 68, 107);
 178         my $unit = getchars($stats, \%digitgreen, 7, 136, 181);
 179         my @unit = split /:/, $unit, 2;
 180         @unit == 2 or @unit = ('?') x 2;
 181         return ($min, $gas, @unit);
 182 }
 183
 184 sub parsetimer {
 185         my $input = shift;  # (587,396)-(621,402)
 186         $input->write(file => sprintf "testt%05d.png", $i) or warn $input->errstr
 187                 if $DEBUG;
 188         my $play = filter_color($input,
 189                 "\276\272\357", # BEBAEF
 190         );
 191         my $time = getchars($play, \%digittime, 6, 0, 33);
 192         return (
 193                 $time =~ /^(?:(\d):)?(\d\d):(\d\d)$/ ?
 194                         (defined $1 ? $1*3600 : 0) + $2*60 + $3 :
 195                         undef,
 196                 $time
 197         );
 198 }
 199
 200 open my $outstats, '>', 'map.txt' or die $!;
 201 my $outmap = 'map%05d.png';
 202
 203 sub capturemap {
 204         my $map = screenshot(right=>134, left=>6, top=>348, bottom=>476);
 205         $map->write(file => sprintf $outmap, $i) or warn $map->errstr;
 206 }
 207
 208 sub capturestats {
 209         my @stats = parsestats(
 210                 screenshot(left=>452, top=>6, right=>639, bottom=>13)
 211         );
 212         my ($sec, $time) = parsetimer(
 213                 screenshot(left=>587, right=>621, top=>396, bottom=>402)
 214         );
 215         $time ne '?' or next;
 216         printf {$outstats} "%d:\t%s\t%s\t%s\t%s\t%s\n",
 217                 $i, defined $sec ? $sec : "($time)", @stats;
 218 }
 219
 220 if ($ARGV[0]) {
 221         my $filename = $ARGV[0] || 's%05d.png';
 222         for ($i = 0;;) {
 223                 my (@stats, $sec, $time, $map);
 224
 225                 my $img = Imager->new;
 226                 $img->read(file => sprintf $filename, $i)
 227                         or warn($img->errstr), next;
 228
 229                 @stats = parsestats(
 230                         $img->crop(left=>452, width=>187, top=>6, height=>7)
 231                 );
 232                 ($sec, $time) = parsetimer(
 233                         $img->crop(left=>587, width=>34, top=>396, height=>6),
 234                 );
 235                 $map = $img->crop(width=>128, height=>128, left=>6, top=>348);
 236
 237                 printf {$outstats} "%d:\t%s\t%s\t%s\t%s\t%s\n",
 238                         $i, defined $sec ? $sec : "($time)", @stats;
 239                 $map->write(file => sprintf $outmap, $i) or warn $map->errstr;
 240                 last;
 241         }
 242 } else {
 243         require Imager::Screenshot;
 244         import Imager::Screenshot qw(screenshot);
 245
 246         ($SIG{ALRM} = \&capturemap), alarm 5, 1 if $GETMAP;
 247         while (1) {
 248                 $i++;
 249                 capturestats();
 250                 sleep .2 if $GETMAP;
 251         }
 252         alarm 0 if $GETMAP;
 253 }
 254
 255 =cut
 256
 257 exec 'mencoder' => (
 258         'mf://map0*.png',
 259         '-o' => 'map.avi',
 260         '-mf' => 'type=png:fps=2',
 261         '-ovc' => 'lavc',
 262         '-lavcopts' => 'vcodec=mpeg4:mbd=1:v4mv:vbitrate=64',
 263         '-info' => 'artist=Shiar:name="StarCraft game progress"',
 264         '-msglevel' => 'all=3',
 265 );
 266
 267 =head1 NAME
 268
 269 capture - Read and parse StarCraft game screenshots
 270
 271 =head1 SYNOPSIS
 272
 273 B<capture> [OPTIONS] [INPUT]
 274
 275 capture --map dump%04d.png
 276
 277 =head1 OPTIONS
 278
 279 =over 8
 280
 281 =item --verbose | -v
 282
 283 Debug mode.
 284 Stores captured statistics areas as test[ts]?????.png images.
 285
 286 =item --map | -m
 287
 288 Capture the minimap area every second (StarCraft won't update more often,
 289 regardless of game speed).
 290 Images are stored as map?????.png in the current directory.
 291
 292 =back
 293
 294 =head1 AUTHOR
 295
 296 Mischa POSLAWSKY <perl@shiar.org>
 297
 298 =head1 LICENSE
 299
 300 You may distribute under the terms of either the GNU General Public License
 301 or the Artistic License, as specified in the Perl README file.
 302