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 if (defined $mapsep{$SHOWMAP}) {
  66         my $MAPCHARSEP = $mapsep{$SHOWMAP};
  67
  68         my $tiles = $SHOWMAP eq "num" ? [ map sprintf('%5d', $_), @{$map->tiles} ]
  69                 : $map->tiles;#_parsed;
  70
  71         if ($SHOWMAP eq "ppm") {
  72                 use Imager;
  73                 my $img = Imager->new(xsize => $map->width * 4, ysize => $map->width * 4);
  74
  75                 use Data::StarCraft::Tileset;
  76                 my $era = world($map);
  77                 if ($era eq '?') {
  78                         warn 'Tileset '.$map->era.' not recognized; fallback to jungle';
  79                         $era = 'jungle';
  80                 }
  81                 my $tileset = Data::StarCraft::Tileset->open("/home/shiar/sc/tileset_$era")
  82                         or die "No tileset for world $era";
  83
  84                 my ($x, $y) = (0, 0);
  85                 for (@$tiles) {
  86                         # 128x128 ~ 6s
  87 #                       my $tile = $tileset->tileavg($_);
  88 #                       $img->setpixel(x => $x, y => $y, color => $tile->{col});
  89
  90                         # 512x512 ~ 7s
  91                         my $tile = $tileset->tile($_);
  92                         $img->paste(src => $tile->{sprite}, left => $x*4, top => $y*4);
  93
  94                         # 4096x4096 ~ 75s
  95 #                       my $tile = $tileset->sprite($tileset->{map}->[$_]);
  96 #                       $img->setscanline(
  97 #                               x => $x*32, y => $y*32 + $_, pixels => pack('(CCCx)*',
  98 #                                       map { @{ $tileset->{palette}->[$_] } } @$tile[$_*32 .. $_*32+31]
  99 #                               ),
 100 #                       ) for 0..31;
 101                 }
 102                 continue {
 103                         $x++;
 104                         if ($x >= $map->width) {
 105                                 $y++;
 106                                 $x = 0;
 107                         }
 108                 }
 109
 110                 $img->write(fd => fileno(STDOUT), type => 'png')
 111                         or die 'Cannot output image: ', $img->errstr;
 112         }
 113
 114 =cut
 115         while (my @line = splice @$tiles, 0, $map->width) {
 116                 printf "%s\n", join $MAPCHARSEP, @line;
 117         }
 118 =cut
 119 }
 120
 121 =head1 scmap
 122
 123 From replay:
 124
 125         old/screptomap somereplay.rep | ./scmap -m=ppm > map.ppm
 126
 127 From map:
 128
 129         ./scmtomap starcraft/maps/ladder/'(4)Lost Temple.scm'
 130         ./scmap -m=ppm < file000001.xxx > map.ppm
 131
 132 =cut