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                 defined $self->{$type} and warn "duplicate map chunk $type\n";
  34                 $self->{$type} = $self->_read($file, $size);
  35         }
  36         return $self;
  37 }
  38
  39 sub version {
  40         my $self = shift;
  41         return 'v' . ord $self->{VER};
  42 }
  43
  44 sub info {
  45         my $self = shift;
  46         my ($x, $y) = unpack "vv", $self->{DIM};
  47         return {
  48                 x => $x,
  49                 y => $y,
  50         };
  51 }
  52
  53 sub width {
  54         return $_[0]->info->{x};
  55 }
  56
  57 sub tiles {
  58         my $self = shift;
  59         my @map = unpack 'v*', $self->{MTXM};
  60         @map == $#map + 1 or warn(sprintf
  61                 "couldn't parse map: only %d tiles\n", scalar @map
  62         ), return;
  63         return \@map;
  64 }
  65
  66 our %tilechar;
  67
  68 my @mapunit = ( # character => width, height, ids
  69         '$' => [2,1, 176..178], # minerals
  70         '*' => [2,1, 188], # gas
  71         '@' => [2,2, 214], # start pos
  72 );
  73
  74 our %unitchar;
  75 while (my ($char, $matches) = splice @mapunit, 0, 2) {
  76         my @charinfo = ($char, splice @$matches, 0, 2);
  77         $unitchar{$_} = \@charinfo for @$matches;
  78 }
  79
  80 sub tiles_parsed {
  81         my $self = shift;
  82         my $map = $self->tiles or return;
  83         if ($self->{DEBUG}) {
  84                 use Tie::IxHash;
  85                 tie my %unknown, 'Tie::IxHash';
  86                 defined $tilechar{$map->[$_]} or warn(sprintf
  87                         "unknown tile %d at (%d,%d)\n",
  88                         $map->[$_], $_ % $self->width, $_ / $self->width
  89                 ), $unknown{$map->[$_]} = $_ for 0 .. $#$map;
  90                 warn sprintf "unknown: %s\n", join ",", keys %unknown if keys %unknown;
  91         }
  92         $_ = defined $tilechar{$_} ? $tilechar{$_} : '?' for @$map;
  93         for ($self->units) {
  94                 my ($chr, $width, $height) = defined $unitchar{$_->{id}} ?
  95                         @{ $unitchar{$_->{id}} } : ('#', 1, 1);
  96                 for my $x ($_->{x} .. $_->{x} + $width - 1) {
  97                         for my $y ($_->{y} .. $_->{y} + $height - 1) {
  98                                 $map->[$x + $y * $self->width] = $chr;
  99                         }
 100                 }
 101         }
 102         return $map;
 103 }
 104
 105 sub units {
 106         my $self = shift;
 107         my @units;
 108         for (my $i = 0; $i < length $self->{UNIT}; $i += 36) {
 109                 # d1, d2, x*32, y*32, unitid, bytes1, playerid, bytes2, mineral, bytes3
 110                 my @pack = unpack "v5x6Cx3vx14", substr $self->{UNIT}, $i, 36;
 111                 push @units, {
 112                         id => $pack[4],
 113                         player => $pack[5],
 114                         amount => $pack[6],
 115                         x => $pack[2] >> 5,
 116                         y => $pack[3] >> 5,
 117 #                       d1 => $pack[0],
 118 #                       d2 => $pack[1],
 119                 };
 120         }
 121         return @units;
 122 }
 123
 124 sub units_parsed {
 125         my $self = shift;
 126         my @units;
 127         for ($self->units) {
 128                 my ($chr, $width, $height) = defined $unitchar{$_->{id}} ?
 129                         @{ $unitchar{delete $_->{id}} } : ('#', 1, 1);
 130                 $_->{chr} = $chr;
 131                 $_->{width} = $width;
 132                 push @units, $_;
 133         }
 134         return @units;
 135 }
 136
 137 sub colors {
 138         my $self = shift;
 139         my @colormap = (
 140                 qw(
 141                         FF0000 0000FF 209070 88409C E87824 5C2C14 FFFFFF DCDC3C
 142                         0F930F FCFC8F EFCEBD 547CDC
 143                 ),
 144                 12 => "pale green", "gray", "pale yellow", "cyan",
 145                 17 => "black", "neon blue",
 146                 21 => "lavender", "black",
 147                 30 => "sky blue",
 148                 33 => "purple",
 149         );
 150         my @players;
 151         for (unpack "C*", $self->{COLR}) {
 152                 push @players, $colormap[$_] || "? (#$_)";
 153         }
 154         return \@players;
 155 }
 156
 157 sub era {
 158         my $self = shift;
 159         return unpack "v", $self->{ERA};
 160 }
 161
 162 1;
 163