Data-StarCraft/lib/Data/StarCraft/Tileset.pm

   1 package Data::StarCraft::Tileset;
   2
   3 use strict;
   4 use warnings;
   5 use Carp;
   6 use Data::Dumper;
   7
   8 use List::Util qw(sum);
   9
  10 our $VERSION = '0.11';
  11
  12 sub open {
  13         my ($class, $filename) = @_;
  14         my $self = bless {}, $class;
  15         open my $groupfile, '<', "$filename.cv5" or return;
  16         $self->readgroups($groupfile);
  17         if (open my $groupfile, '<', "$filename.vx4") {
  18                 $self->readvx4($groupfile);
  19         }
  20         if (open my $groupfile, '<', "$filename.vf4") {
  21                 $self->readvf4($groupfile);
  22         }
  23         if (open my $groupfile, '<', "$filename.vr4") {
  24                 $self->readvr4($groupfile);
  25         }
  26         if (open my $groupfile, '<', "$filename.wpe") {
  27                 $self->readwpe($groupfile);
  28         }
  29         return $self;
  30 }
  31
  32 sub _read {
  33         my $self = shift;
  34         my ($fh, $size, $seek) = @_;
  35
  36         seek $fh, $seek, 0 if $seek;
  37         read($fh, my $in, $size) eq $size or return undef;
  38         return $in;
  39 }
  40
  41 sub readwpe {
  42         my $self = shift;
  43         my ($fh) = @_;
  44
  45         # wpe = palette
  46         while (defined (my $line = $self->_read($fh, 4))) {
  47                 push @{ $self->{palette} }, [ unpack 'CCCX', $line ];
  48         }
  49         return;
  50 }
  51
  52 sub readvx4 {
  53         my $self = shift;
  54         my ($fh) = @_;
  55
  56         # vx4 = minitile map (4x4 references per megatile)
  57         while (defined (my $line = $self->_read($fh, 16*2))) {
  58                 push @{ $self->{tileref} }, [ unpack 'v*', $line ];
  59         }
  60         return;
  61 }
  62
  63 sub readvr4 {
  64         my $self = shift;
  65         my ($fh) = @_;
  66
  67         # vr4 = minitile sprites
  68         while (defined (my $line = $self->_read($fh, 8**2))) {
  69                 push @{ $self->{minibmp} }, [ unpack 'C*', $line ];
  70         }
  71         return;
  72 }
  73
  74 sub readvf4 {
  75         my $self = shift;
  76         my ($fh) = @_;
  77
  78         # vf4 = minitile type
  79         while (defined (my $line = $self->_read($fh, 2))) {
  80                 push @{ $self->{minitype} }, unpack 'v', $line;
  81         }
  82         return;
  83 }
  84
  85 sub col {
  86         my $self = shift;
  87         my ($minitile) = @_;
  88
  89         return $self->{bmp}->[$minitile] if defined $self->{bmp}->[$minitile];
  90
  91         my $pixels = $self->{minibmp}->[$minitile];
  92         my $pal = $self->{palette};
  93
  94         my @rgb;
  95         for my $color (@$pixels) {
  96 #               $rgb[$_] += $self->{palette}->[$color]->[$_] for 0 .. 2;
  97 #                       # ^ wow, this is really slow
  98                 $rgb[0] += $pal->[$color]->[0];
  99                 $rgb[1] += $pal->[$color]->[1];
 100                 $rgb[2] += $pal->[$color]->[2];
 101         }
 102         return $self->{bmp}->[$minitile] = [map {$_ >> 6} @rgb];
 103 }
 104
 105 =head2 col
 106
 107 Average color [r,g,b] for minitile.
 108
 109 For example, using the Jungle tileset:
 110
 111         my @rgb = $t->col(719)
 112
 113 is a water minitile, giving a blue color C<[38, 38, 57]>.
 114
 115 =cut
 116
 117 sub sprite {
 118         my $self = shift;
 119         my ($id) = @_;
 120
 121         my $minitiles = $self->{tileref}->[$id]
 122                 or croak "tile ref $id does not exist";
 123         my @pix;
 124         for my $tiley (0 .. 3) {
 125                 for my $y (0 .. 7) {
 126                         for my $tilex (0 .. 3) {
 127                                 # minitile number is half of tileref
 128                                 # if odd, the minitile is mirrored
 129                                 my $minitile = $minitiles->[$tilex + $tiley*4];
 130
 131                                 for my $x ($minitile & 1 ? (reverse 0 .. 7) : (0 .. 7)) {
 132                                         push @pix, $self->{minibmp}->[$minitile >> 1]->[$x + $y*8];
 133                                 }
 134                         }
 135                 }
 136         }
 137         return \@pix;
 138 }
 139
 140 =head2 sprite
 141
 142 Returns bitmap of an entire tile, as 32x32 color indexes.
 143
 144 For example, the green value of the bottom center pixel of tile #1 would be:
 145
 146         $t->{palette}->[ $t->sprite(1)->[31*32 + 15] ]->[2]
 147
 148 =cut
 149
 150 use Inline with => 'Imager';
 151 use Inline C => <<'EOS';
 152 Imager tileimg(SV* self, AV* tiledata) {
 153         Imager img = i_img_8_new(4, 4, 3);
 154
 155         int bit;
 156         for (bit = 0; bit < 4 * 4 * 3; ++bit) {
 157                 SV **bitval = av_fetch(tiledata, bit, 0);
 158                 if (bitval && SvOK(*bitval))
 159                         img->idata[bit] = (int)SvIV(*bitval);
 160         }
 161
 162         return img;
 163 }
 164
 165 SV* colavg(SV* self, Imager img) {
 166         int ch;
 167         int pixel;
 168         int rgb[3];
 169
 170         for (pixel = 0; pixel < 4 * 4; ++pixel) {
 171                 for (ch = 0; ch < 3; ++ch) {
 172                         rgb[ch] += img->idata[pixel*3 + ch];
 173                 }
 174         }
 175
 176         AV* perlrgb = newAV();
 177         for (ch = 0; ch < 3; ++ch) {
 178                 av_push(perlrgb, newSViv(rgb[ch] >> 4));
 179         }
 180         return newRV_noinc(perlrgb);
 181 }
 182
 183 EOS
 184
 185 sub tile {
 186         my $self = shift;
 187         my ($id) = @_;
 188
 189         my $tile = $self->{map}->[$id];
 190         my $minitiles = $self->{tileref}->[$tile] || [];
 191         return {
 192                 id => $tile,
 193                 group   => $self->{group}->[$id >> 4],
 194                 subtype => [ map { $self->{minitype}->[$_] } $tile*16 .. $tile*16+15 ],
 195                 sprite  => $self->tileimg( [ map { @{ $self->col($_ >> 1) } } @$minitiles ] ),
 196         };
 197 }
 198
 199 sub tileavg {
 200         my $self = shift;
 201         my $tile = $self->tile(shift);
 202
 203         my $info = $tile->{group};
 204         $info->{walk} = sum(@{ $tile->{subtype} }) >> 4;
 205         $info->{col} = $self->colavg($tile->{sprite});
 206         return $info;
 207 }
 208
 209 =head2 tile
 210
 211 Tile details. For example a water tile:
 212
 213         $t->tile(96)
 214
 215 would give:
 216
 217         group => {
 218                 walk   => 0,
 219                 height => 0,
 220                 build  => 128,
 221         },
 222         subtype => [ 1,1,1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1 ],
 223         sprite => Imager->new(4, 4, 3),
 224
 225 =cut
 226
 227 sub readgroups {
 228         my $self = shift;
 229         my ($fh) = @_;
 230
 231         # cv5 = tile groups
 232         my @tilemap;
 233         while (defined (my $line = $self->_read($fh, 52))) {
 234                 my @data = unpack "vCC v24", $line;
 235                 my %row = (
 236                         build => $data[1] & 0xF0,
 237                         height => $data[2] & 0xF,
 238 #                       rawdata => [@data[0..10]],
 239                 );
 240                 push @{ $self->{group} }, \%row;
 241                 push @{ $self->{map} }, $_ for @data[11..26];
 242         }
 243         return;
 244         # index (ground_height unknown4 buildable unknown3) u6 u7 u8 u9 u10 u11 u12 u13
 245         # 1 (ground_height unknown4 buildable unknown3) 35 0 doodad_group 0 58 6 6 0
 246 }
 247
 248 1;
 249