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

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