parse-wormedit

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use 5.010;
   5
   6 use Data::Dumper;
   7 use Getopt::Long 2.33 qw(HelpMessage :config bundling);
   8
   9 our $VERSION = '1.02';
  10
  11 GetOptions(\my %opt,
  12         'raw|r',  # full output
  13         'version=i',  # force version
  14 ) or HelpMessage(-exitval => 2);
  15
  16
  17 package Shiar_Parse::WormEdit;
  18
  19 use strict;
  20 use warnings;
  21
  22 our %MAGICID = (
  23         "WormEdit053\000LVL" => 53,
  24         "WormEdit\34195\000LVL" => 95,
  25         "WormEdit\34194\000LVL" => 94,
  26         "WormEdit\34193\000LVL" => 93,
  27 );
  28
  29 my @FORMAT = (
  30         magic       => 'a15',
  31         version     => 'C',
  32         name        => 'Ca32',
  33         description => 'Ca64x256',
  34         levelcount  => [1,
  35                 single => 'C',
  36                 multi  => 'C',
  37                 race   => 'C',
  38                 ctf    => 'C',
  39                 total  => 'C',
  40         ],
  41         moderef     => [1,
  42                 map { (start => $_, end => $_) } [1,
  43                         single     => 'C',
  44                         peaworm    => 'C',
  45                         tron       => 'C',
  46                         deathmatch => 'C',
  47                         foodmatch  => 'C',
  48                         multifood  => 'C',
  49                         timematch  => 'C',
  50                         race       => 'C',
  51                         ctf        => 'Cx',
  52                 ],
  53         ],
  54         sprite     => ['8C',
  55                 line => 'B8',
  56         ],
  57         endtype     => 's',
  58         endstr      => 'Ca255',
  59         enddata     => 'Ca255x256',
  60         hiname      => 'a3',
  61         levels      => ['*', # levelcount->total actually
  62                 id         => 'Ca22',
  63                 name       => 'Ca22',
  64                 size       => 'C',
  65                 peas       => 'C',
  66                 delay      => 'C',
  67                 growth     => 'C',
  68                 bsize      => 'C',
  69                 sprite     => ['8C',
  70                         line => 'B8',
  71                 ],
  72                 balls      => ['32C',
  73                         y   => 'C',
  74                         x   => 'C',
  75                         dir => 'C',
  76                 ],
  77                 worms      => [4,
  78                         d => 'C',
  79                         y => 'C',
  80                         x => 'C',
  81                 ],
  82                 width      => 'C',
  83                 height     => 'C',
  84                 flags      => [2,
  85                         y => 'C',
  86                         x => 'C',
  87                 ],
  88                 objects    => ['128C',
  89                         type => 'C',
  90                         x1   => 'C',
  91                         y1   => 'C',
  92                         x2   => 'C',
  93                         y2   => 'C',
  94                 ],
  95         ],
  96 );
  97
  98 sub read {
  99         my ($self, $input) = @_;
 100         my ($id, $subid) = (substr($input, 0, 15), ord substr($input, 15, 1));
 101         my $version = $opt{version} // $MAGICID{$id}
 102                 or die "File does not match any known WormEdit level header\n";
 103         $subid == $version
 104                 or warn "Unsupported version $subid (expecting $version)\n";
 105         given ($version) {
 106                 when (53) {
 107                         # current @FORMAT
 108                 }
 109                 when ($_ <= 95 and $_ > 90) {
 110                         ref $_ and pop @$_ for @{ $FORMAT[11] }; # only 8 moderefs
 111                         $FORMAT[-1]->[-1]->[0] = '32C'; # less objects
 112                         continue;
 113                 }
 114                 when (95) {
 115                         $FORMAT[7] = 'Ca64'; # no reserved space after description
 116                         #ref $_ and $_->[-1] = 'C' for @{ $FORMAT[11] }; # only 9 moderefs
 117                         $FORMAT[19] = 'Ca255'; # enddata
 118                         splice @FORMAT, 6, 2 if $subid < 95;  # early (sub)version without description
 119                 }
 120                 when ($_ <= 94 and $_ > 90) {
 121                         splice @FORMAT, 6, 2;  # no description
 122                         splice @{ $FORMAT[7] }, 4, 2;  # no race
 123                         splice @FORMAT, 16, 2; # no enddata
 124                         splice @{ $FORMAT[-1] }, 1, 2; # no name
 125                         continue if $_ < 94;
 126                 }
 127                 when (93) {
 128                         splice @FORMAT, 16, 2; # no hiname
 129                         $FORMAT[-1]->[0] = 64; # constant amount of levels
 130                 }
 131                 default {
 132                         die "Cannot parse data for Wormedit $version\n";
 133                 }
 134         }
 135
 136         # convert to an easily accessible hash
 137         my @values = unpack Shiar_Parse::Nested->template(\@FORMAT).'a*', $input;
 138         my $data = Shiar_Parse::Nested->convert(\@FORMAT, \@values);
 139         warn "Trailing data left unparsed\n" if grep {length} @values;
 140         $data->{format} = 'WormEdit';
 141         return $data;
 142 }
 143
 144
 145 package Shiar_Parse::WormyLevel;
 146
 147 sub read {
 148         my ($self, $input) = @_;
 149         my ($psize, $ptype, $size, $type, $vsize, $dsize, $id, $subid) = unpack q{
 150                 x11 x42    # file signature and comment
 151                 S a2 S a2  # file size, type; data size, type
 152                 x8         # var name
 153                 S S        # var size; content size
 154                 CC         # wormy header
 155         }, $input;
 156         $ptype eq "\014\000"
 157                 or die "Not a calculator string, thus cannot be a Wormy level file\n";
 158         $size == $psize - 16
 159                 or warn "File size ($size) does not correspond with data size ($psize)\n";
 160         $type eq "\014\010"
 161                 or die "Not a calculator string, thus cannot be a Wormy level file\n";
 162         $size == $vsize and $vsize == $dsize+2
 163                 or warn "Mismatch in string data size declarations\n";
 164 #       substr($input, -2) eq $CHECKSUM
 165
 166         $input = substr $input, 73, -2;
 167         $id eq ord 'w'
 168                 or die "Wormy level identifier not found\n";
 169         my @FORMAT = (
 170                 magic       => 'a1',
 171                 version     => 'C',
 172                 name        => 'Z*',
 173                 description => 'Z*',
 174                 levelcount  => [1,
 175                         total  => 'S',
 176                 ],
 177                 moderef     => [1,
 178                         map { (
 179                                 start => [1, map {$_ => 'S'} @$_],
 180                                 end   => [1, map {$_ => 'C'} @$_],
 181                         ) }
 182                         [qw/single peaworm tron deathmatch foodmatch multifood timematch race ctf/]
 183                 ],
 184                 theanswer => 'C', # 42
 185                 sprite     => ['C',
 186                         line => 'B8',
 187                 ],
 188                 leveldata => 'a*',
 189         );
 190         my @LEVELFORM = (
 191                 peas       => 'C',
 192                 delay      => 'C',
 193                 growth     => 'C',
 194                 bsize      => 'C',
 195                 sprite     => ['C',
 196                         line => 'B8',
 197                 ],
 198                 balls      => ['C',
 199                         y   => 'C',
 200                         x   => 'C',
 201                         dir => 'C',
 202                 ],
 203                 worms      => [1,
 204                         d => 'C',
 205                         y => 'C',
 206                         x => 'C',
 207                 ],
 208                 width      => 'C',
 209                 height     => 'C',
 210                 #levels
 211                 #enddata
 212                 #levels-multi
 213                 #hinames
 214         );
 215         my @OBJECTFORM = (
 216                         type => 'C',
 217                         x1   => 'C',
 218                         y1   => 'C',
 219                         x2   => 'C',
 220                         y2   => 'C',
 221         );
 222
 223         given ($subid) {
 224                 when (97) {
 225                 }
 226                 default {
 227                         die "Unsupported level version $subid\n";
 228                 }
 229         }
 230
 231         my $data = Shiar_Parse::Nested->unpack(\@FORMAT, $input);
 232         while (length $data->{leveldata}) {
 233                 my $level = Shiar_Parse::Nested->unpack([@LEVELFORM], $data->{leveldata});
 234                 my $offset = 13
 235                         + 3 * (ref $level->{worms} eq 'ARRAY' ? scalar @{$level->{worms}} : 1)
 236                         + ($level->{sprite} ? scalar @{$level->{sprite}} : 0)
 237                         + ($level->{balls} ? 3 * scalar @{$level->{balls}} : 0);
 238                 $level->{objects} = [];
 239                 while (my $object = ord substr($data->{leveldata}, $offset, 1)) {
 240                         push @{ $level->{objects} }, Shiar_Parse::Nested->unpack(
 241                                 [@OBJECTFORM], substr($data->{leveldata}, $offset, 5)
 242                         );
 243                         $offset += 5;
 244                 }
 245                 $level->{size} = $offset;
 246                 $offset++;
 247                 push @{ $data->{levels} }, $level;
 248                 substr($data->{leveldata}, 0, $offset) = '';
 249                 last if substr($data->{leveldata}, 0, 1) eq chr(255);
 250         }
 251         my $slots = 1; #TODO
 252         $data->{hinames} = [ unpack '(a3)*', substr($data->{leveldata}, -3 * $slots) ];
 253         $data->{enddata} = substr delete($data->{leveldata}), 0, -3 * $slots;
 254         $data->{format} = '86s';
 255         $data->{levelcount}->{single} = scalar @{ $data->{levels} };
 256         return $data;
 257 }
 258
 259
 260 package Shiar_Parse::Nested;
 261
 262 sub template {
 263         my ($self, $format) = @_;
 264         # total (flattened) unpack template from nested format definitions
 265         return join '', map {
 266                 my $value = $format->[-($_ << 1) - 1];
 267                 if (ref $value eq 'ARRAY') {
 268                         my $count = $value->[0];
 269                         $value = $self->template($value);
 270                         $value = $count =~ s/^([*\d]+)// ? "$count($value)$1"
 271                                 : $count."X[$count]$count/($value)";
 272                 }
 273                 else {
 274                         $value =~ s/^C(a)(\d+)/$1 . ($2 + 1)/e;  # length prefix
 275                 }
 276                 $value;
 277         } reverse 0 .. ($#$format - 1) >> 1;
 278 }
 279
 280 sub convert {
 281         my ($self, $format, $data) = @_;
 282         # map flat results into a named and nested hash
 283         my %res;
 284         while (my ($field, $template) = splice @$format, 0, 2) {
 285                 if (ref $template eq 'ARRAY') {
 286                         my ($count, @subformat) = @$template;
 287                         my $max = $count =~ s/^(\d+)// ? $1 : 0;
 288                         $count = !$count ? $max
 289                                 : $count eq '*' ? $res{levelcount}->{total} : shift @$data;
 290                         $res{$field}->[$_] = $self->convert([@subformat], $data) for 0 .. ($max || $count)-1;
 291                         splice @{ $res{$field} }, $count if $max > $count;
 292                         $res{$field} = $res{$field}->[0] if $max == 1;
 293                         next;
 294                 }
 295                 elsif ($template =~ /^Ca/) {
 296                         $data->[0] = CORE::unpack 'C/a', $data->[0];
 297                 }
 298                 $res{$field} = shift @$data;
 299         }
 300         return \%res;
 301 }
 302
 303 sub unpack {
 304         my ($self, $format, $input) = @_;
 305         my @data = CORE::unpack $self->template($format), $input;
 306         return $self->convert($format, \@data);
 307 }
 308
 309
 310 package main;
 311
 312 my @OBJTYPE = ('none', 'line', 'fat line', 'bar', 'circle');
 313 my @ENDTYPE = ('none', 'message', 'small message');
 314
 315 sub objsummary {
 316         my ($objects) = @_;
 317         my @objtypes = map { $_->{type} } @$objects;
 318         my %count;
 319         $count{$_}++ for @objtypes;
 320         return (@objtypes > 1 && keys %count == 1 && 'all ') . join(', ',
 321                 map { $OBJTYPE[$_] ? $OBJTYPE[$_] . ($count{$_} > 1 && 's') : $_ }
 322                 sort keys %count
 323         );
 324 }
 325
 326 # read and parse all input data
 327 my $data;
 328 local $/;
 329 my $rawdata = readline;
 330 if (substr($rawdata, 0, 11) eq "**TI86**\032\012\000") {
 331         # compiled calculator file
 332         $data = Shiar_Parse::WormyLevel->read($rawdata);
 333 }
 334 elsif (substr($rawdata, 0, 8) eq 'WormEdit') {
 335         # original wormedit source
 336         $data = Shiar_Parse::WormEdit->read($rawdata);
 337 }
 338 else {
 339         die "Unrecognised file type\n";
 340 }
 341
 342 # output with user-preferred formatting
 343 if ($opt{raw}) {
 344         require JSON::XS;
 345         my $output = JSON::XS->new->ascii->canonical->pretty->allow_nonref;
 346         print $output->encode($data), "\n";
 347 }
 348 else {
 349         print $data->{name};
 350         print " ($data->{description})" if defined $data->{description};
 351         print "\n";
 352         printf "File version: %s\n", "$data->{format} v$data->{version}";
 353         printf "Defaults: %s\n", join('; ',
 354                 'sprite ' . scalar @{ $data->{sprite} },
 355                 defined $data->{hiname} ? 'hiscore by ' . $data->{hiname} : (),
 356         );
 357
 358         my $startnr = 0;
 359         for my $variant (qw/single multi race ctf/) {
 360                 my $count = $data->{levelcount}->{$variant};
 361                 print "\n";
 362                 printf '%s (%s)', ucfirst $variant, $count // 'invalid';
 363                 $count or next;
 364                 print ":";
 365                 for (0 .. $count - 1) {
 366                         my $level = $data->{levels}->[$_ + $startnr];
 367                         printf("\n- %-22s%4s:%3s+%2s%3s %3sx%-3s%s",
 368                                 $level->{id} || $level->{name} || '#'.($_+1),
 369                                 @$level{qw/size bsize growth/},
 370                                 $variant eq 'single' && "x$level->{peas}",
 371                                 @$level{qw/width height/},
 372                                 join(';', map {" $_"} grep {$_}
 373                                         @{$level->{objects}} && sprintf('%2d object%s (%s)',
 374                                                 scalar @{$level->{objects}}, @{$level->{objects}} != 1 && 's',
 375                                                 objsummary($level->{objects}),
 376                                         ),
 377                                         $level->{sprite} && @{$level->{sprite}} && sprintf('sprite %d',
 378                                                 scalar @{$level->{sprite}},
 379                                         ),
 380                                 ),
 381                         );
 382                 }
 383                 $startnr += $count;
 384         }
 385         continue {
 386                 print "\n";
 387                 printf("-- %-21s%4s: %s (%s)\n",
 388                         '(ending)',
 389                         defined $data->{enddata} ? length $data->{enddata} : '?',
 390                         defined $data->{endtype} ? $ENDTYPE[$data->{endtype}] || 'unknown' : 'code',
 391                         $data->{endstr} // '?',
 392                 ) if $variant eq 'single';
 393         }
 394 }
 395
 396 __END__
 397
 398 =head1 NAME
 399
 400 parse-wormedit - WormEdit level data parser
 401
 402 =head1 SYNOPSIS
 403
 404  parse-wormedit [--raw] <input.lvl>
 405
 406 =head1 DESCRIPTION
 407
 408 Reads WormEdit v0.53 levels from STDIN or given file,
 409 and outputs contents, summarised or in full.
 410
 411 =head1 AUTHOR
 412
 413 Mischa POSLAWSKY <wormy@shiar.org>
 414
 415 =head1 LICENSE
 416
 417 GPL version 3.
 418