Data-StarCraft/lib/Data/StarCraft/Map.pm

   1 package Data::StarCraft::Map;
   2
   3 use strict;
   4 use warnings;
   5 use Data::Dumper;
   6
   7 our $VERSION = "0.10";
   8 our $DEBUG = 0;
   9
  10 sub new {
  11         my ($class) = @_;
  12         bless {}, $class;
  13 }
  14
  15 sub _read {
  16         my $self = shift;
  17         my ($fh, $size, $seek) = @_;
  18         seek *$fh, $seek, 0 if $seek;
  19         read(*$fh, my $in, $size) eq $size or return undef;
  20         return $in;
  21 }
  22
  23 sub open {
  24         my $self = shift;
  25         my ($file) = @_;
  26
  27         while (not eof $file) {
  28                 local $_ = $self->_read($file, 8)
  29                         and my ($type, $size) = unpack "a4V", $_
  30                         or die "Couldn't chunk header\n";
  31                 $type =~ s/ +$//;
  32 #printf STDERR "%s: %s\n", $type, $size;
  33                 if (defined $self->{$type}) {
  34                         # redefinitions (partially) override earlier data from start
  35                         warn "duplicate map chunk $type\n";
  36                         my $prepend = $self->_read($file, $size);
  37                         substr($self->{$type}, 0, length($prepend)) = $prepend;
  38                         next;
  39                 }
  40                 else {
  41                         $self->{$type} = $self->_read($file, $size);
  42                 }
  43         }
  44         return $self;
  45 }
  46
  47 sub version {
  48         my $self = shift;
  49         return 'v' . ord $self->{VER};
  50 }
  51
  52 sub info {
  53         my $self = shift;
  54         my ($x, $y) = unpack "vv", $self->{DIM};
  55         return {
  56                 x => $x,
  57                 y => $y,
  58         };
  59 }
  60
  61 sub width {
  62         return $_[0]->info->{x};
  63 }
  64
  65 sub height {
  66         return $_[0]->info->{y};
  67 }
  68
  69 sub tiles {
  70         my $self = shift;
  71         my @map = unpack 'v*', $self->{MTXM};
  72         @map == $#map + 1 or warn(sprintf
  73                 "Couldn't parse map: only %d tiles\n", scalar @map
  74         ), return;
  75         warn sprintf("Only %d tiles in MTXM, but expecting %dx%d",
  76                 scalar @map, $self->width, $self->height
  77         ) if scalar @map != $self->width * $self->height;
  78         return \@map;
  79 }
  80
  81 our %tilechar;
  82
  83 my @mapunit = ( # character => width, height, ids
  84         '$' => [2,1, 176..178], # minerals
  85         '*' => [2,1, 188], # gas
  86         '@' => [2,2, 214], # start pos
  87 );
  88
  89 our %unitchar;
  90 while (my ($char, $matches) = splice @mapunit, 0, 2) {
  91         my @charinfo = ($char, splice @$matches, 0, 2);
  92         $unitchar{$_} = \@charinfo for @$matches;
  93 }
  94
  95 sub tiles_parsed {
  96         my $self = shift;
  97         my $map = $self->tiles or return;
  98         if ($self->{DEBUG}) {
  99                 use Tie::IxHash;
 100                 tie my %unknown, 'Tie::IxHash';
 101                 defined $tilechar{$map->[$_]} or warn(sprintf
 102                         "unknown tile %d at (%d,%d)\n",
 103                         $map->[$_], $_ % $self->width, $_ / $self->width
 104                 ), $unknown{$map->[$_]} = $_ for 0 .. $#$map;
 105                 warn sprintf "unknown: %s\n", join ",", keys %unknown if keys %unknown;
 106         }
 107         $_ = defined $tilechar{$_} ? $tilechar{$_} : '?' for @$map;
 108         for ($self->units) {
 109                 my ($chr, $width, $height) = defined $unitchar{$_->{id}} ?
 110                         @{ $unitchar{$_->{id}} } : ('#', 1, 1);
 111                 for my $x ($_->{x} .. $_->{x} + $width - 1) {
 112                         for my $y ($_->{y} .. $_->{y} + $height - 1) {
 113                                 $map->[$x + $y * $self->width] = $chr;
 114                         }
 115                 }
 116         }
 117         return $map;
 118 }
 119
 120 sub units {
 121         my $self = shift;
 122         my @units;
 123         for (my $i = 0; $i < length $self->{UNIT}; $i += 36) {
 124                 # d1, d2, x*32, y*32, unitid, bytes1, playerid, bytes2, mineral, bytes3
 125                 my @pack = unpack "v5x6Cx3vx14", substr $self->{UNIT}, $i, 36;
 126                 push @units, {
 127                         id => $pack[4],
 128                         player => $pack[5],
 129                         amount => $pack[6],
 130                         x => $pack[2] >> 5,
 131                         y => $pack[3] >> 5,
 132 #                       d1 => $pack[0],
 133 #                       d2 => $pack[1],
 134                 };
 135         }
 136         return @units;
 137 }
 138
 139 sub units_parsed {
 140         my $self = shift;
 141         my @units;
 142         for ($self->units) {
 143                 my ($chr, $width, $height) = defined $unitchar{$_->{id}} ?
 144                         @{ $unitchar{delete $_->{id}} } : ('#', 1, 1);
 145                 $_->{chr} = $chr;
 146                 $_->{width} = $width;
 147                 push @units, $_;
 148         }
 149         return @units;
 150 }
 151
 152 sub colors {
 153         my $self = shift;
 154         my @colormap = (
 155                 qw(
 156                         FF0000 0000FF 209070 88409C E87824 5C2C14 FFFFFF DCDC3C
 157                         0F930F FCFC8F EFCEBD 547CDC
 158                 ),
 159                 12 => "pale green", "gray", "pale yellow", "cyan",
 160                 17 => "black", "neon blue",
 161                 21 => "lavender", "black",
 162                 30 => "sky blue",
 163                 33 => "purple",
 164         );
 165         my @players;
 166         for (unpack "C*", $self->{COLR}) {
 167                 push @players, $colormap[$_] || "? (#$_)";
 168         }
 169         return \@players;
 170 }
 171
 172 sub era {
 173         my $self = shift;
 174         return unpack "v", $self->{ERA};
 175 }
 176
 177 1;
 178