X-Git-Url: http://git.shiar.net/gitweb.cgi/perl/schtarr.git/blobdiff_plain/4e5d2696326f3562419f2fa5c3b2f81611c6af49..576f66c9fde876c86b20c3da21ce254cd3f3ba78:/Data-StarCraft/lib/Data/StarCraft/Tileset.pm

diff --git a/Data-StarCraft/lib/Data/StarCraft/Tileset.pm b/Data-StarCraft/lib/Data/StarCraft/Tileset.pm
index 0b17b07..1dc8d60 100644
--- a/Data-StarCraft/lib/Data/StarCraft/Tileset.pm
+++ b/Data-StarCraft/lib/Data/StarCraft/Tileset.pm
@@ -2,44 +2,244 @@ package Data::StarCraft::Tileset;
 
 use strict;
 use warnings;
+use Carp;
 use Data::Dumper;
 
+use List::Util qw(sum);
+
+our $VERSION = '0.11';
+
 sub open {
 	my ($class, $filename) = @_;
 	my $self = bless {}, $class;
 	open my $groupfile, '<', "$filename.cv5" or return;
 	$self->readgroups($groupfile);
-	# vf4 = minitile type
-	# vr4 = minitile sprites
-	# vx4 = minitile map?
+	if (open my $groupfile, '<', "$filename.vx4") {
+		$self->readvx4($groupfile);
+	}
+	if (open my $groupfile, '<', "$filename.vf4") {
+		$self->readvf4($groupfile);
+	}
+	if (open my $groupfile, '<', "$filename.vr4") {
+		$self->readvr4($groupfile);
+	}
+	if (open my $groupfile, '<', "$filename.wpe") {
+		$self->readwpe($groupfile);
+	}
 	return $self;
 }
 
 sub _read {
 	my $self = shift;
 	my ($fh, $size, $seek) = @_;
+
 	seek $fh, $seek, 0 if $seek;
 	read($fh, my $in, $size) eq $size or return undef;
 	return $in;
 }
 
+sub readwpe {
+	my $self = shift;
+	my ($fh) = @_;
+
+	# wpe = palette
+	while (defined (my $line = $self->_read($fh, 4))) {
+		push @{ $self->{palette} }, [ unpack 'CCCX', $line ];
+	}
+	return;
+}
+
+sub readvx4 {
+	my $self = shift;
+	my ($fh) = @_;
+
+	# vx4 = minitile map (4x4 references per megatile)
+	while (defined (my $line = $self->_read($fh, 16*2))) {
+		push @{ $self->{tileref} }, [ unpack 'v*', $line ];
+	}
+	return;
+}
+
+sub readvr4 {
+	my $self = shift;
+	my ($fh) = @_;
+
+	# vr4 = minitile sprites
+	while (defined (my $line = $self->_read($fh, 8**2))) {
+		push @{ $self->{minibmp} }, [ unpack 'C*', $line ];
+	}
+	return;
+}
+
+sub readvf4 {
+	my $self = shift;
+	my ($fh) = @_;
+
+	# vf4 = minitile type
+	while (defined (my $line = $self->_read($fh, 2))) {
+		push @{ $self->{minitype} }, unpack 'v', $line;
+	}
+	return;
+}
+
+sub col {
+	my $self = shift;
+	my ($minitile) = @_;
+
+	return $self->{bmp}->[$minitile] if defined $self->{bmp}->[$minitile];
+
+	my $pixels = $self->{minibmp}->[$minitile];
+	my $pal = $self->{palette};
+
+	my @rgb;
+	for my $color (@$pixels) {
+#		$rgb[$_] += $self->{palette}->[$color]->[$_] for 0 .. 2;
+#			# ^ wow, this is really slow
+		$rgb[0] += $pal->[$color]->[0];
+		$rgb[1] += $pal->[$color]->[1];
+		$rgb[2] += $pal->[$color]->[2];
+	}
+	return $self->{bmp}->[$minitile] = [map {$_ >> 6} @rgb];
+}
+
+=head2 col
+
+Average color [r,g,b] for minitile.
+
+For example, using the Jungle tileset:
+
+	my @rgb = $t->col(719)
+
+is a water minitile, giving a blue color C<[38, 38, 57]>.
+
+=cut
+
+sub sprite {
+	my $self = shift;
+	my ($id) = @_;
+
+	my $minitiles = $self->{tileref}->[$id]
+		or croak "tile ref $id does not exist";
+	my @pix;
+	for my $tiley (0 .. 3) {
+		for my $y (0 .. 7) {
+			for my $tilex (0 .. 3) {
+				# minitile number is half of tileref
+				# if odd, the minitile is mirrored
+				my $minitile = $minitiles->[$tilex + $tiley*4];
+
+				for my $x ($minitile & 1 ? (reverse 0 .. 7) : (0 .. 7)) {
+					push @pix, $self->{minibmp}->[$minitile >> 1]->[$x + $y*8];
+				}
+			}
+		}
+	}
+	return \@pix;
+}
+
+=head2 sprite
+
+Returns bitmap of an entire tile, as 32x32 color indexes.
+
+For example, the green value of the bottom center pixel of tile #1 would be:
+
+	$t->{palette}->[ $t->sprite(1)->[31*32 + 15] ]->[2]
+
+=cut
+
+use Inline with => 'Imager';
+use Inline C => <<'EOS';
+Imager tileimg(SV* self, AV* tiledata) {
+	Imager img = i_img_8_new(4, 4, 3);
+
+	int bit;
+	for (bit = 0; bit < 4 * 4 * 3; ++bit) {
+		SV **bitval = av_fetch(tiledata, bit, 0);
+		if (bitval && SvOK(*bitval))
+			img->idata[bit] = (int)SvIV(*bitval);
+	}
+
+	return img;
+}
+
+SV* colavg(SV* self, Imager img) {
+	int ch;
+	int pixel;
+	int rgb[3];
+
+	for (pixel = 0; pixel < 4 * 4; ++pixel) {
+		for (ch = 0; ch < 3; ++ch) {
+			rgb[ch] += img->idata[pixel*3 + ch];
+		}
+	}
+
+	AV* perlrgb = newAV();
+	for (ch = 0; ch < 3; ++ch) {
+		av_push(perlrgb, newSViv(rgb[ch] >> 4));
+	}
+	return newRV_noinc(perlrgb);
+}
+
+EOS
+
+sub tile {
+	my $self = shift;
+	my ($id) = @_;
+
+	my $tile = $self->{map}->[$id];
+	my $minitiles = $self->{tileref}->[$tile] || [];
+	return {
+		id => $tile,
+		group   => $self->{group}->[$id >> 4],
+		subtype => [ map { $self->{minitype}->[$_] } $tile*16 .. $tile*16+15 ],
+		sprite  => $self->tileimg( [ map { @{ $self->col($_ >> 1) } } @$minitiles ] ),
+	};
+}
+
+sub tileavg {
+	my $self = shift;
+	my $tile = $self->tile(shift);
+
+	my $info = $tile->{group};
+	$info->{walk} = sum(@{ $tile->{subtype} }) >> 4;
+	$info->{col} = $self->colavg($tile->{sprite});
+	return $info;
+}
+
+=head2 tile
+
+Tile details. For example a water tile:
+
+	$t->tile(96)
+
+would give:
+
+	group => {
+		walk   => 0,
+		height => 0,
+		build  => 128,
+	},
+	subtype => [ 1,1,1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1 ],
+	sprite => Imager->new(4, 4, 3),
+
+=cut
+
 sub readgroups {
 	my $self = shift;
 	my ($fh) = @_;
-	my $id = 0;
+
+	# cv5 = tile groups
 	my @tilemap;
 	while (defined (my $line = $self->_read($fh, 52))) {
 		my @data = unpack "vCC v24", $line;
 		my %row = (
 			build => $data[1] & 0xF0,
 			height => $data[2] & 0xF,
-			walk => undef,
+#			rawdata => [@data[0..10]],
 		);
-		$self->{group}->[$id] = \%row;
-		push @tilemap, $_ for @data[11..26];
-		$id++;
+		push @{ $self->{group} }, \%row;
+		push @{ $self->{map} }, $_ for @data[11..26];
 	}
-	$self->{tile} = \@tilemap;
 	return;
 	# index (ground_height unknown4 buildable unknown3) u6 u7 u8 u9 u10 u11 u12 u13
 	# 1 (ground_height unknown4 buildable unknown3) 35 0 doodad_group 0 58 6 6 0