game capture prototype

[perl/schtarr.git] / capture

diff --git a/capture b/capture
new file mode 100644 (file)
index 0000000..91304aa
--- /dev/null
+++ b/capture
@@ -0,0 +1,144 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use Data::Dumper;
+use Image::Magick;
+use constant {DEBUG => 0};
+
+our $VERSION = '1.00';
+
+my @digitchar = (0..9, ':', ' ');
+my @digittime = (
+       [744, 372, 372, 744], # 0
+       [186, 1116], # 1
+       [558, 558, 558, 558], # 2
+       [372, 372, 558, 558], # 3
+       [372, 372, 1116, 186], # 4
+       [558, 558, 558, -558], # 5
+       [744, 558, 558, 558], # 6
+       [255, 640, 1025, 895, 539], ## 7
+       [1020, 648, 510, 648, 1020], ## 8
+       [558, 558, 558, 744], # 9
+       [372], ## /
+       [], # -
+);
+my @digitgreen = (
+       [1344, 393, 255, 393, 1344], # 0
+       [255, 409, 1530], # 1
+       [863, 709, 664, 799, 648], # 2
+       [579, 393, 510, 648, 1089], # 3
+       [640, 709, 709, 1530, 255], # 4
+       [523, 895, 510, 770, 1150], # 5
+       [1344, 786, 648, 648, 1089], # 6
+       [255, 640, 1025, 895, 539], # 7
+       [1020, 648, 510, 648, 1020], # 8
+       [903, 648, 510, 648, 1344], # 9
+       [199, 887, 709], ## /
+
+#      [1344, 417, 263, 393, 1344, 32], # 0
+#      [255, 417, 1530, 40], # 1
+#      [863, 725, 680, 807, 656, 16], # 2
+#      [579, 401, 518, 656, 1089, 24], # 3
+#      [640, 717, 725, 1530, 287, 8], # 4
+#      [523, 903, 526, 778, 1158, 24], ## 5
+#      [1344, 786, 656, 656, 1097, 24], ## 6
+#      [255, 648, 1033, 911, 547, 8], # 7
+#      [1028, 656, 526, 664, 1028, 24], # 8
+#      [903, 656, 526, 656, 1344, 32], # 9
+#      [199, 887, 725, 16], ## /
+
+       [], # -
+);
+
+my %colorgreen = (
+#      8 => [8, 8],
+       69 => [0, 0],
+       130 => [8, 8],
+       154 => [33, 33],
+       255 => [16, 24],
+);
+
+sub getrect2 {
+       my ($digit, $valid, $data, $w, $h, $x1, $x2) = @_;
+
+       my ($str, @char);
+       my $count = -1;
+       for my $x ($x1 .. $x2) {
+               my $colval = 0;
+               for my $y (0 .. $h - 1) {
+                       my @val;
+                       push @val => $data->[($x + $y*$w) * 3 + $_] >> 8 for 0 .. 2;
+printf("  [%s]\n", join ', ', @val) if DEBUG >= 2;
+                       my $match = $valid->{$val[1]} or next;
+                       $val[0] == $match->[0] and $val[2] == $match->[1] or next;
+print "  ok\n" if DEBUG >= 2;
+                       $colval += $val[1];
+               }
+
+               if ($colval > 0 and ($count < 0 or $count++ < 6)) {
+                       push @char => $colval;
+               } elsif (@char) {
+printf " %d: [%s], # %d\n", $x, join(', ', @char), $count if DEBUG >= 1;
+                       my @matches;
+                       for my $match (@$digit) {
+                               if (scalar @$match == scalar @char) {
+                                       my $offset = 0;
+                                       $offset += abs $char[$_] - $match->[$_] for 0 .. $#char;
+                                       push @matches => $offset;
+                               } else {
+                                       push @matches => -1;
+                               }
+                       }
+                       undef @char;
+                       $count = 0;
+
+                       my $best;
+                       $matches[$_] == 0 and $best = $_ for 0 .. $#matches;
+                       if (not defined $best) {
+                               my @best;
+                               $matches[$_] > 0 and push @best, $_
+                                       for sort {$matches[$a] <=> $matches[$b]} 0 .. $#matches;
+printf "candidates: (%s)\n", join ', ', map {"$_ ($matches[$_])"} @best;
+                               $best = shift @best;
+                       }
+                       $str .= defined $best ? $best eq '' ? '' : $digitchar[$best] : '?';
+               }
+       }
+       return $str;
+}
+
+my $map = Image::Magick->new(128, 128);
+my $curtime = 0;
+
+for my $i ($ARGV[0] .. $ARGV[1]) {
+       my $image = Image::Magick->new;
+       my $err = $image->Read(sprintf 's%05d.png', $i);
+       $err and die $err;
+       my @pixels = $image->GetPixels(map=>'RGB', x=>452, width=>187, y=>6, height=>6);
+       my $min = getrect2(\@digitgreen, \%colorgreen, \@pixels, 187, 6, 0, 39);
+       my $gas = getrect2(\@digitgreen, \%colorgreen, \@pixels, 187, 6, 68, 107);
+       my $unit = getrect2(\@digitgreen, \%colorgreen, \@pixels, 187, 6, 136, 181);
+       my ($unitcur, $unitmax) = split /:/, $unit, 2;
+
+       @pixels = $image->GetPixels(map=>'RGB', x=>587, width=>34, y=>396, height=>6);
+       my $time = getrect2(\@digittime, {186 => [189, 239]}, \@pixels, 34, 6, 0, 33);
+       my $sec;
+       $time =~ /^(\d\d):(\d\d)$/ and $sec = $1*60 + $2;
+
+       printf "%d:\t%s\t%s\t%s\t%s\t%s\n", $i, $sec, $min, $gas, $unitcur, $unitmax;
+       $image->Crop(width=>128, height=>128, x=>6, y=>348);
+#      $image->Set(delay => $sec > $curtime ? ($sec - $curtime) / 5 : 10);
+       $image->Set(10);
+       push @$map => $image;
+       $curtime = $sec;
+}
+
+my $err = $map->Write('map.gif');
+$err and die $err;
+#print $map->Layers(method => 'optimize');
+
+print "\n";
+print "\n";
+