scmap

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use Data::Dumper;
   5
   6 my $SHOWWARN = 0;
   7 my $SHOWMAP = "head"; # ascii, num, ppm
   8 my $SHOWCOL = 0;
   9
  10 use Getopt::Long;
  11 GetOptions(
  12         "verbose|v!" => \$SHOWWARN,
  13         "map|m=s" => \$SHOWMAP,
  14         "color|c" => \$SHOWCOL,
  15 );
  16
  17 use Data::StarCraft::Map;
  18 my $map = Data::StarCraft::Map->new->open(\*STDIN);
  19 $map->{DEBUG} = 1 if $SHOWWARN;
  20
  21 if ($SHOWMAP ne "ppm") {
  22         printf("%s size %dx%d, %d player\n",
  23                 $map->version,
  24                 $map->info->{x}, $map->info->{y},
  25                 scalar grep {$_->{id} == 214} $map->units,
  26         );
  27         print "\n";
  28 }
  29
  30 if ($SHOWMAP eq "head") {
  31         if ($map->{STR}) {
  32                 my @str = split /\0/, substr $map->{STR}, 2051;
  33                 $SHOWCOL ? (
  34                         s/([\001-\007])/sprintf '\e[0;%dm', 30+ord($1)/eg
  35                         and $_ .= "\e[0;37m"
  36                 ) : s/[\001-\017]//g, print "* $_\n" for @str;
  37                 print "\n";
  38         }
  39         printf "%-4s %d\n", $_, defined $map->{$_} ? length $map->{$_} : 0
  40                 for sort keys %$map;
  41         print "\n";
  42         printf "%s: %s\n", $_, join ",", unpack "C*", $map->{$_}
  43                 for sort grep { defined $map->{$_} and length $map->{$_} < 32 }
  44                         keys %$map;
  45         print "\n";
  46 }
  47
  48 sub world {
  49         my $self = shift;
  50         # ERA:          0        1        2       3        4      5      6   7
  51         my @worlds = qw(badlands platform install ashworld jungle desert ice twilight);
  52         return $worlds[$self->era & 7] || "?";
  53 }
  54
  55 #        MTXM TILE
  56 # ?      ?    yes
  57 # v205 = yes  no
  58
  59 my %mapsep = (
  60         num => ',',
  61         ppm => '  ',
  62         ascii => '',
  63 );
  64
  65 use Inline with => 'Imager';
  66 use Inline C => <<'EOS';
  67 void blendpixel(Imager img, int offset, Imager::Color color) {
  68         int ch;
  69         float opacity = (float)color->channel[3] / 255;
  70         for (ch = 0; ch < img->channels; ++ch) {
  71                 img->idata[offset * img->channels + ch] *= 1 - opacity;
  72                 img->idata[offset * img->channels + ch] += color->channel[ch] * opacity;
  73         }
  74         return;
  75 }
  76
  77 EOS
  78
  79 my %UNITINFO = ( # unitid => color|image, width, height
  80         176 => [min => [ 47, 195, 255], 2, 1], # minerals
  81         188 => [gas => [ 15, 255,  63], 2, 1], # gas
  82         214 => [pos => [255, 255,   0], 2, 2], # start pos
  83 );
  84 $UNITINFO{$_} = $UNITINFO{176} for 177, 178;
  85
  86 my $STYLE = {
  87                 wall => [0, 0, 255, 127],
  88                 edge => [0, 0, 255, 15],
  89                 ramp => [0, 255, 0, 47],
  90                 rock => [255, 0, 0, 255],
  91 };
  92 $_ = Imager::Color->new(@$_) for values %$STYLE;
  93
  94 if (defined $mapsep{$SHOWMAP}) {
  95         my $MAPCHARSEP = $mapsep{$SHOWMAP};
  96
  97         my $tiles = $SHOWMAP eq "num" ? [ map sprintf('%5d', $_), @{$map->tiles} ]
  98                 : $map->tiles;#_parsed;
  99
 100         if ($SHOWMAP eq "ppm") {
 101                 use Imager;
 102                 my $img = Imager->new(xsize => $map->width * 4, ysize => $map->height * 4);
 103
 104                 use Data::StarCraft::Tileset;
 105                 my $era = world($map);
 106                 if ($era eq '?') {
 107                         warn 'Tileset '.$map->era.' not recognized; fallback to jungle';
 108                         $era = 'jungle';
 109                 }
 110                 my $tileset = Data::StarCraft::Tileset->open("/home/shiar/sc/tileset_$era")
 111                         or die "No tileset for world $era";
 112
 113                 my ($x, $y) = (0, 0);
 114                 for (@$tiles) {
 115                         # 128x128 ~ 6s
 116 #                       my $tile = $tileset->tileavg($_);
 117 #                       $img->setpixel(x => $x, y => $y, color => $tile->{col});
 118
 119                         # 512x512 ~ 7s
 120                         my $tile = $tileset->tile($_);
 121 BLENDTILE:
 122                         for (my $offset = 0; $offset < 4*4; $offset++) {
 123                                 for (my $y = 0; $y < 4; $y++) {
 124                                         my $subtype = $tile->{subtype}->[$offset];
 125                                         if ($subtype & 8) {
 126                                                 # obstructions
 127                                                 blendpixel($tile->{sprite}, $offset, $STYLE->{wall});
 128                                         }
 129                                         elsif (($subtype & 1) == 0) {
 130                                                 # unwalkable
 131                                                 blendpixel($tile->{sprite}, $offset, $STYLE->{edge});
 132                                         }
 133                                         elsif ($subtype & 16) {
 134                                                 # ramps
 135                                                 my $mask = Imager->new(xsize => 4, ysize => 4, channels => 4);
 136                                                 $mask->box(color => $STYLE->{ramp}, filled => 1);
 137                                                 $tile->{sprite}->rubthrough(src => $mask);
 138                                                 last BLENDTILE;
 139                                         }
 140                                         elsif ($tile->{build}) {
 141                                                 # unbuildable
 142                                                 blendpixel($tile->{sprite}, $offset, $STYLE->{rock});
 143                                         }
 144                                 }
 145                         }
 146                         $img->paste(src => $tile->{sprite}, left => $x*4, top => $y*4);
 147
 148                         # 4096x4096 ~ 75s
 149 #                       my $tile = $tileset->sprite($tileset->{map}->[$_]);
 150 #                       $img->setscanline(
 151 #                               x => $x*32, y => $y*32 + $_, pixels => pack('(CCCx)*',
 152 #                                       map { @{ $tileset->{palette}->[$_] } } @$tile[$_*32 .. $_*32+31]
 153 #                               ),
 154 #                       ) for 0..31;
 155                 }
 156                 continue {
 157                         $x++;
 158                         if ($x >= $map->width) {
 159                                 $y++;
 160                                 $x = 0;
 161                         }
 162                 }
 163
 164                 my $overlaymin = Imager->new(
 165                         xsize => $img->getwidth,
 166                         ysize => $img->getheight,
 167                         channels => 4,
 168                 );
 169                 my $overlaygas = $overlaymin->copy;
 170                 for my $unit ($map->units) {
 171                         my $info = $UNITINFO{ $unit->{id} } or next;
 172                         my ($name, $color, $xsize, $ysize) = @$info or next;
 173                         if ($name eq 'min') {
 174                                 next if $unit->{amount} <= 8;
 175                                 $overlaymin->circle(
 176                                         x      => 4 * ($unit->{x} + $xsize/2),
 177                                         y      => 4 * ($unit->{y} + $ysize/2),
 178                                         r      => 4 * ($unit->{amount} <= 40 ? 2 : 4),
 179                                         color  => $color,
 180                                         filled => 1,
 181                                         aa     => 1,
 182                                 );
 183                         }
 184                         elsif ($name eq 'gas') {
 185                                 $overlaygas->circle(
 186                                         x      => 4 * ($unit->{x} + $xsize/2),
 187                                         y      => 4 * ($unit->{y} + $ysize/2),
 188                                         r      => 4 * ($unit->{amount} <= 40 ? 2 : 4),
 189                                         color  => $color,
 190                                         filled => 1,
 191                                         aa     => 1,
 192                                 );
 193                         }
 194                 }
 195                 $img->compose(src => $overlaymin, opacity => 0.1875);
 196                 $img->compose(src => $overlaygas, opacity => 0.125);
 197
 198                 for my $unit ($map->units) {
 199                         my $info = $UNITINFO{ $unit->{id} }
 200                                 or warn("No unit styling for unit #$unit->{id}"), next;
 201                         my ($name, $color, $xsize, $ysize, $sprite) = @$info;
 202                         if ($sprite) {
 203                                 $img->paste(src => $sprite, x => $unit->{x}, y => $unit->{y});
 204                         }
 205                         else {
 206                                 $img->box(
 207                                         xmin   => 4 * $unit->{x},
 208                                         ymin   => 4 * $unit->{y},
 209                                         xmax   => 4 * ($unit->{x} + ($xsize || 1)),
 210                                         ymax   => 4 * ($unit->{y} + ($ysize || 1)),
 211                                         color  => $color,
 212                                         filled => 1,
 213                                 );
 214                         }
 215                 }
 216
 217                 $img->write(fd => fileno(STDOUT), type => 'png')
 218                         or die 'Cannot output image: ', $img->errstr;
 219         }
 220
 221 =cut
 222         while (my @line = splice @$tiles, 0, $map->width) {
 223                 printf "%s\n", join $MAPCHARSEP, @line;
 224         }
 225 =cut
 226 }
 227
 228 =head1 scmap
 229
 230 From replay:
 231
 232         old/screptomap somereplay.rep | ./scmap -m=ppm > map.ppm
 233
 234 From map:
 235
 236         ./scmtomap starcraft/maps/ladder/'(4)Lost Temple.scm'
 237         ./scmap -m=ppm < file000001.xxx > map.ppm
 238
 239 =cut