1 package Data::StarCraft::Map;
17 my ($fh, $size, $seek) = @_;
18 seek *$fh, $seek, 0 if $seek;
19 read(*$fh, my $in, $size) eq $size or return undef;
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";
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;
41 $self->{$type} = $self->_read($file, $size);
49 return 'v' . ord $self->{VER};
54 my ($x, $y) = unpack "vv", $self->{DIM};
62 return $_[0]->info->{x};
66 return $_[0]->info->{y};
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
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;
83 my @mapunit = ( # character => width, height, ids
84 '$' => [2,1, 176..178], # minerals
85 '*' => [2,1, 188], # gas
86 '@' => [2,2, 214], # start pos
90 while (my ($char, $matches) = splice @mapunit, 0, 2) {
91 my @charinfo = ($char, splice @$matches, 0, 2);
92 $unitchar{$_} = \@charinfo for @$matches;
97 my $map = $self->tiles or return;
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;
107 $_ = defined $tilechar{$_} ? $tilechar{$_} : '?' for @$map;
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;
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;
143 my ($chr, $width, $height) = defined $unitchar{$_->{id}} ?
144 @{ $unitchar{delete $_->{id}} } : ('#', 1, 1);
146 $_->{width} = $width;
156 FF0000 0000FF 209070 88409C E87824 5C2C14 FFFFFF DCDC3C
157 0F930F FCFC8F EFCEBD 547CDC
159 12 => "pale green", "gray", "pale yellow", "cyan",
160 17 => "black", "neon blue",
161 21 => "lavender", "black",
166 for (unpack "C*", $self->{COLR}) {
167 push @players, $colormap[$_] || "? (#$_)";
174 return unpack "v", $self->{ERA};