X-Git-Url: http://git.shiar.net/perl/schtarr.git/blobdiff_plain/d7d9369b4d1bddef20d56636d7e7e85c507bb11a..HEAD:/scmap

diff --git a/scmap b/scmap
index cd564d3..33f7f8b 100755
--- a/scmap
+++ b/scmap
@@ -47,185 +47,11 @@ if ($SHOWMAP eq "head") {
 
 sub world {
 	my $self = shift;
-	# ERA:          0        1     2 3 4      5 6 7
-	my @worlds = qw(badlands space 0 0 jungle 0 0 twilight);
-	return $worlds[$self->era] || "?";
+	# ERA:          0        1        2       3        4      5      6   7
+	my @worlds = qw(badlands platform install ashworld jungle desert ice twilight);
+	return $worlds[$self->era & 7] || "?";
 }
 
-my %mapcol = (
-	# jungle world
-	'~' => '0 0 3', # water
-	'W' => '3 3 7', # coast/water object
-	'D' => '8 7 5', # D shore
-
-	'j' => '2 3 0', # jungle
-	'd' => '3 3 0', # dirt
-	'm' => '3 3 1', # mud
-	'o' => '3 3 2', # rocky
-	'O' => '11 10 6', # object on lower ground
-	'l' => '4 4 2', # ruins
-
-	'R' => '3 9 3',   # raised jungle
-	'r' => '8 14 8',
-	'x' => '6 9 2',   # high jungle
-	'h' => '10 10 4', # high dirt
-	'q' => '12 11 0', # high ruins
-	'i' => '13 9 0', # temple
-
-	'R' => '2 5 2',   # raised jungle
-	'r' => '4 6 4',
-	'x' => '5 7 3',   # high jungle
-	'h' => '7 7 3', # high dirt
-	'q' => '8 8 5', # high ruins
-	'Q' => '15 15 8', # object on higher ground
-	'i' => '10 9 5', # temple
-	'b' => '5 4 3', # asphalt/basilica
-	'a' => '13 11 5', # high basilica
-	'A' => '13 12 10', # bas. sides
-
-	'/' => '15 15 11',
-	'\\' => '13 13 9',
-	'=' => '11 12 8',
-
-	'7' => '3 3 1', # D>H
-	'6' => '4 4 1',
-	'5' => '4 4 2',
-	'4' => '5 5 2',
-	'3' => '5 5 3',
-	'2' => '6 6 3',
-	'1' => '7 7 4',
-
-	# common
-	'$' => '0 13 15', # mineral patch
-	'*' => '4 15 8', # gas geyser
-	'@' => '14 4 3', # start location
-	'#' => '15 12 0', # unknown unit
-
-	' ' => '15 15 15', # defined unencountered
-	'?' => '0 0 0',    # undefined
-	'!' => '15 0 15',  # marked
-	'-' => '0 15 0',   # debug
-);
-my @eramapcol = (
-	{ # badlands (era 0)
-		# d:   dirt
-		# o?:  mud 
-		# h:   high dirt
-		# ~:   water
-		# j:   grass
-		# x/o: high grass
-		# s:   structure
-		# b:   asphalt
-		# i?:  rocky ground
-
-		'b' => '3 3 2', # asphalt
-		'j' => '5 4 0', # grass
-		'd' => '4 3 1', # dirt
-		'q' => '4 3 2', # dirt ↔ asphalt
-		'o' => '8 8 5', # high grass (also mud?)
-		'm' => '3 2 14', # ?
-		'O' => '11 10 6', # object on lower ground
-		'l' => '4 3 2', # asphalt↔dirt
-
-		'h' => '8 7 5', # high dirt
-		'x' => '9 8 5', # high grass ↔ high dirt?
-
-		'/' => '15 14 11',
-		'r' => '9 9 9', # structure
-	},
-
-	{ # space platform
-	},
-
-	{ # desert
-		#    tar
-		#    dirt
-		#    dried mud
-		#    sand dunes
-		#    rocky ground
-		#    crags
-		#    sandy sunken pit
-		#    compound
-		#    high dirt
-		#    high sand dunes
-		#    high crags
-		#    high sandy sunken pit
-		#    high compound
-	},
-
-	{ # ice
-		#    ice
-		#    snow
-		#    moguls
-		#    dirt
-		#    rocky snow
-		#    grass
-		#    water
-		#    outpost
-		#    high snow
-		#    high dirt
-		#    high grass
-		#    high water
-		#    high outpost
-	},
-
-	{ # jungle (era 4)
-		# ~: water
-		# d: dirt
-		# m: mud
-		# j: jungle
-		# o: rocky ground
-		# l: ruins
-		# r: raised jungle
-		#    temple
-		# h: high dirt
-		# x: high jungle
-		# q: high ruins
-		#    high raised jungle
-		# i: high temple
-	},
-
-	{ # ash
-		#    magma
-		# d: dirt
-		# l: lava
-		# o: shale
-		#    broken rock
-		#    high dirt
-		#    high lava
-		#    high shale
-	},
-
-	{ # installation
-	},
-
-	{ # twilight (era 7)
-		#    water
-		#    dirt
-		#    mud
-		#    crushed rock
-		#    crevices
-		#    flagstones
-		#    sunken ground
-		#    basilica
-		#    high dirt
-		#    high crushed rock
-		#    high flagstones
-		#    high sunken ground
-		#    high basilica
-#		'b' => '5 4 3', # basilica
-#		'p' => '3 3 2', # ?
-#		'r' => '3 9 3', # sunken stuff
-	},
-);
-my %addmapcol = !$SHOWWARN ? () : (
-	'?' => '15 0 0',
-	'm' => '2 2 1',
-);
-
-#%mapcol = (%mapcol, %{$eramapcol[$map->era]}, %addmapcol);
-%mapcol = (%mapcol, %{$eramapcol[4]}, %addmapcol);
-
 #        MTXM TILE
 # ?      ?    yes
 # v205 = yes  no
@@ -236,45 +62,178 @@ my %mapsep = (
 	ascii => '',
 );
 
+use Inline with => 'Imager';
+use Inline C => <<'EOS';
+void blendpixel(Imager img, int offset, Imager::Color color) {
+	int ch;
+	float opacity = (float)color->channel[3] / 255;
+	for (ch = 0; ch < img->channels; ++ch) {
+		img->idata[offset * img->channels + ch] *= 1 - opacity;
+		img->idata[offset * img->channels + ch] += color->channel[ch] * opacity;
+	}
+	return;
+}
+
+EOS
+
+my %UNITINFO = ( # unitid => color|image, width, height
+	176 => [min => [ 47, 195, 255], 2, 1], # minerals
+	188 => [gas => [ 15, 255,  63], 2, 1], # gas
+	214 => [pos => [255, 255,   0], 2, 2], # start pos
+);
+$UNITINFO{$_} = $UNITINFO{176} for 177, 178;
+
+my $STYLE = {
+		wall => [0, 0, 255, 127],
+		edge => [0, 0, 255, 15],
+		ramp => [0, 255, 0, 47],
+		rock => [255, 0, 0, 255],
+};
+$_ = Imager::Color->new(@$_) for values %$STYLE;
+
 if (defined $mapsep{$SHOWMAP}) {
 	my $MAPCHARSEP = $mapsep{$SHOWMAP};
 
 	my $tiles = $SHOWMAP eq "num" ? [ map sprintf('%5d', $_), @{$map->tiles} ]
-		: $map->tiles_parsed;
+		: $map->tiles;#_parsed;
 
 	if ($SHOWMAP eq "ppm") {
-		printf "P3\n%d %d\n15\n", $map->info->{x}, $map->info->{y};
-		if ($SHOWWARN) {
-			my %uncolored;
-			defined $mapcol{$_} or $uncolored{$_}++ for @$tiles, '?';
-			warn "no color for tile '$_'\n" for keys %uncolored;
+		use Imager;
+		my $img = Imager->new(xsize => $map->width * 4, ysize => $map->height * 4);
+
+		use Data::StarCraft::Tileset;
+		my $era = world($map);
+		if ($era eq '?') {
+			warn 'Tileset '.$map->era.' not recognized; fallback to jungle';
+			$era = 'jungle';
 		}
-		$_ = $mapcol{$_} || $mapcol{'?'} || '0 0 0' for @$tiles;
-		if (0){
-			sub surround {
-				my ($unit, $match, $color) = @_;
-				my $pos = $unit->{x} + $unit->{y} * $map->width;
-				for my $delta (
-					$pos+1, $pos-1,
-					$pos+$map->width, $pos-$map->width,
-					$pos+1+$map->width, $pos+1-$map->width,
-				) {
-					$tiles->[$delta] =~ s/($match)/$1 + $color/e
-						unless $tiles->[$delta] eq $mapcol{$unit->{chr}};
+		my $tileset = Data::StarCraft::Tileset->open("/home/shiar/sc/tileset_$era")
+			or die "No tileset for world $era";
+
+		my ($x, $y) = (0, 0);
+		for (@$tiles) {
+			# 128x128 ~ 6s
+#			my $tile = $tileset->tileavg($_);
+#			$img->setpixel(x => $x, y => $y, color => $tile->{col});
+
+			# 512x512 ~ 7s
+			my $tile = $tileset->tile($_);
+BLENDTILE:
+			for (my $offset = 0; $offset < 4*4; $offset++) {
+				for (my $y = 0; $y < 4; $y++) {
+					my $subtype = $tile->{subtype}->[$offset];
+					if ($subtype & 8) {
+						# obstructions
+						blendpixel($tile->{sprite}, $offset, $STYLE->{wall});
+					}
+					elsif (($subtype & 1) == 0) {
+						# unwalkable
+						blendpixel($tile->{sprite}, $offset, $STYLE->{edge});
+					}
+					elsif ($subtype & 16) {
+						# ramps
+						my $mask = Imager->new(xsize => 4, ysize => 4, channels => 4);
+						$mask->box(color => $STYLE->{ramp}, filled => 1);
+						$tile->{sprite}->rubthrough(src => $mask);
+						last BLENDTILE;
+					}
+					elsif ($tile->{build}) {
+						# unbuildable
+						blendpixel($tile->{sprite}, $offset, $STYLE->{rock});
+					}
 				}
 			}
-			for ($map->units_parsed) {
-				if ($_->{chr} eq '$') {
-					surround($_, qr/\d+$/, 7);
-				} elsif ($_->{chr} eq '*') {
-					surround($_, qr/\d+(?= \d+$)/, 3);
-				}
+			$img->paste(src => $tile->{sprite}, left => $x*4, top => $y*4);
+
+			# 4096x4096 ~ 75s
+#			my $tile = $tileset->sprite($tileset->{map}->[$_]);
+#			$img->setscanline(
+#				x => $x*32, y => $y*32 + $_, pixels => pack('(CCCx)*',
+#					map { @{ $tileset->{palette}->[$_] } } @$tile[$_*32 .. $_*32+31]
+#				),
+#			) for 0..31;
+		}
+		continue {
+			$x++;
+			if ($x >= $map->width) {
+				$y++;
+				$x = 0;
+			}
+		}
+
+		my $overlaymin = Imager->new(
+			xsize => $img->getwidth,
+			ysize => $img->getheight,
+			channels => 4,
+		);
+		my $overlaygas = $overlaymin->copy;
+		for my $unit ($map->units) {
+			my $info = $UNITINFO{ $unit->{id} } or next;
+			my ($name, $color, $xsize, $ysize) = @$info or next;
+			if ($name eq 'min') {
+				next if $unit->{amount} <= 8;
+				$overlaymin->circle(
+					x      => 4 * ($unit->{x} + $xsize/2),
+					y      => 4 * ($unit->{y} + $ysize/2),
+					r      => 4 * ($unit->{amount} <= 40 ? 2 : 4),
+					color  => $color,
+					filled => 1,
+					aa     => 1,
+				);
+			}
+			elsif ($name eq 'gas') {
+				$overlaygas->circle(
+					x      => 4 * ($unit->{x} + $xsize/2),
+					y      => 4 * ($unit->{y} + $ysize/2),
+					r      => 4 * ($unit->{amount} <= 40 ? 2 : 4),
+					color  => $color,
+					filled => 1,
+					aa     => 1,
+				);
+			}
+		}
+		$img->compose(src => $overlaymin, opacity => 0.1875);
+		$img->compose(src => $overlaygas, opacity => 0.125);
+
+		for my $unit ($map->units) {
+			my $info = $UNITINFO{ $unit->{id} }
+				or warn("No unit styling for unit #$unit->{id}"), next;
+			my ($name, $color, $xsize, $ysize, $sprite) = @$info;
+			if ($sprite) {
+				$img->paste(src => $sprite, x => $unit->{x}, y => $unit->{y});
+			}
+			else {
+				$img->box(
+					xmin   => 4 * $unit->{x},
+					ymin   => 4 * $unit->{y},
+					xmax   => 4 * ($unit->{x} + ($xsize || 1)),
+					ymax   => 4 * ($unit->{y} + ($ysize || 1)),
+					color  => $color,
+					filled => 1,
+				);
 			}
 		}
+
+		$img->write(fd => fileno(STDOUT), type => 'png')
+			or die 'Cannot output image: ', $img->errstr;
 	}
 
+=cut
 	while (my @line = splice @$tiles, 0, $map->width) {
 		printf "%s\n", join $MAPCHARSEP, @line;
 	}
+=cut
 }
 
+=head1 scmap
+
+From replay:
+
+	old/screptomap somereplay.rep | ./scmap -m=ppm > map.ppm
+
+From map:
+
+	./scmtomap starcraft/maps/ladder/'(4)Lost Temple.scm'
+	./scmap -m=ppm < file000001.xxx > map.ppm
+
+=cut