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.03';
  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 use strict;
 148 use warnings;
 149
 150 use List::Util qw(sum min max);
 151
 152 sub read {
 153         my ($self, $input) = @_;
 154         my ($psize, $ptype, $size, $type, $vsize, $dsize, $id, $subid) = unpack q{
 155                 x11 x42    # file signature and comment
 156                 S a2 S a2  # file size, type; data size, type
 157                 x8         # var name
 158                 S S        # var size; content size
 159                 CC         # wormy header
 160         }, $input;
 161         $ptype eq "\014\000"
 162                 or die "Not a calculator string, thus cannot be a Wormy level file\n";
 163         $size == $psize - 16
 164                 or warn "File size ($size) does not correspond with data size ($psize)\n";
 165         $type eq "\014\010"
 166                 or die "Not a calculator string, thus cannot be a Wormy level file\n";
 167         $size == $vsize and $vsize == $dsize+2
 168                 or warn "Mismatch in string data size declarations\n";
 169 #       substr($input, -2) eq $CHECKSUM
 170
 171         $input = substr $input, 73, -2;
 172         $id eq ord 'w'
 173                 or die "Wormy level identifier not found\n";
 174         my @FORMAT = (
 175                 magic       => 'a1',
 176                 version     => 'C',
 177                 name        => 'Z*',
 178                 description => 'Z*',
 179                 levelcount  => [1,
 180                         total  => 'S',
 181                 ],
 182                 moderef     => [1,
 183                         map { (
 184                                 offset => [1, map {$_ => 'S'} @$_], # byte location of start
 185                                 end    => [1, map {$_ => 'C'} @$_],
 186                         ) }
 187                         [qw/single peaworm tron deathmatch foodmatch multifood timematch race ctf/]
 188                 ],
 189                 theanswer => 'C', # 42
 190                 sprite     => ['C',
 191                         line => 'B8',
 192                 ],
 193                 leveldata => 'a*',
 194         );
 195         my @LEVELFORM = (
 196                 peas       => 'C',
 197                 delay      => 'C',
 198                 growth     => 'C',
 199                 bsize      => 'C',
 200                 sprite     => ['C',
 201                         line => 'B8',
 202                 ],
 203                 balls      => ['C',
 204                         y   => 'C',
 205                         x   => 'C',
 206                         dir => 'C',
 207                 ],
 208                 worms      => [1,
 209                         d => 'C',
 210                         y => 'C',
 211                         x => 'C',
 212                 ],
 213                 width      => 'C',
 214                 height     => 'C',
 215                 flags      => [0,
 216                         y => 'C',
 217                         x => 'C',
 218                 ],
 219                 #levels
 220                 #enddata
 221                 #levels-multi
 222                 #hinames
 223         );
 224         my @OBJECTFORM = (
 225                         type => 'C',
 226                         x1   => 'C',
 227                         y1   => 'C',
 228                         x2   => 'C',
 229                         y2   => 'C',
 230         );
 231
 232         given ($subid) {
 233                 when (97) {
 234                         # current @FORMAT
 235                 }
 236                 when (95) {
 237                         ref $_ and splice @$_, -2 for @{ $FORMAT[11] }; # only 8 moderefs
 238                         splice @FORMAT, 12, 2;  # no reserved byte
 239                 }
 240                 default {
 241                         die "Unsupported level version $subid\n";
 242                 }
 243         }
 244
 245         my $data = Shiar_Parse::Nested->unpack(\@FORMAT, $input);
 246         my $offset = 0;
 247         my $offsetbase = 0xF080 + @{ $data->{sprite} } + 1;
 248         $data->{moderef}->{offset}->{single} == $offsetbase
 249                 or warn "First singleplayer level is not in front\n";
 250
 251         my @VARMODES = (
 252                 [qw'single  single'],
 253                 [qw'multi   peaworm tron deathmatch foodmatch multifood timematch'],
 254                 [qw'race    race'],
 255                 [qw'ctf     ctf'],
 256         );
 257
 258         $data->{levels} = [];
 259         for my $modes (@VARMODES) {
 260                 my $variant = shift @$modes;
 261                 $offset = min(map { $data->{moderef}->{offset}->{$_} } @$modes) - $offsetbase;
 262                 my $amount = $variant eq 'single' ? 100 : max(map { $data->{moderef}->{end}->{$_} } @$modes);
 263
 264                 my @varform = @LEVELFORM;
 265                 $varform[13]->[0] = $variant eq 'single' ? 1 : 4;
 266                 unshift @varform, name => 'Z*' unless $variant eq 'single';
 267                 $varform[-1]->[0] = 1 if $variant eq 'race';
 268                 $varform[-1]->[0] = 2 if $variant eq 'ctf';
 269
 270                 while ($offset < length $data->{leveldata}) {
 271                         last if substr($data->{leveldata}, $offset, 1) eq chr(255);
 272
 273                         # find references to this level offset, and set start number to matching modes
 274                         while (my ($mode, $location) = each %{ $data->{moderef}->{offset} }) {
 275                                 $location == $offset + $offsetbase or next;
 276                                 $data->{moderef}->{start}->{$mode} = 1 + scalar @{ $data->{levels} };
 277                         }
 278
 279                         my $level = Shiar_Parse::Nested->unpack(
 280                                 [@varform], substr $data->{leveldata}, $offset
 281                         );
 282                         my $size = 8  # unpack length (ugh, ugly recalculation)
 283                                 + (defined $level->{name} ? 1 + length $level->{name} : 0)
 284                                 + 3 * (ref $level->{worms} eq 'ARRAY' ? scalar @{$level->{worms}} : 1)
 285                                 + 2 * ($level->{flags} ? ref $level->{flags} eq 'ARRAY' ? scalar @{$level->{flags}} : 1 : 0)
 286                                 + ($level->{sprite} ? scalar @{$level->{sprite}} : 0)
 287                                 + ($level->{balls} ? 3 * scalar @{$level->{balls}} : 0);
 288                         $level->{size} = $size;
 289                         $level->{offset} = $offset + $offsetbase;
 290
 291                         # add objects until terminator
 292                         $level->{objects} = [];
 293                         while (my $object = ord substr($data->{leveldata}, $offset+$size, 1)) {
 294                                 push @{ $level->{objects} }, Shiar_Parse::Nested->unpack(
 295                                         [@OBJECTFORM], substr($data->{leveldata}, $offset+$size, 5)
 296                                 );
 297                                 $size += 5;
 298                         }
 299
 300                         # add parsed level and advance
 301                         push @{ $data->{levels} }, $level;
 302                         $offset += ++$size;
 303                         last if ++$data->{levelcount}->{$variant} >= $amount;
 304                 }
 305         }
 306
 307         my $slots = sum(
 308                 $data->{moderef}->{end}->{single} > 0,  # singleplayer slot if any levels
 309                 $data->{moderef}->{end}->{peaworm},     # one for each peaworm arena
 310                 $data->{moderef}->{end}->{tron},        # idem for tron
 311         );
 312         $data->{hinames} = [ unpack '(x2a3)*', substr($data->{leveldata}, -5 * $slots) ];
 313         $data->{enddata} = substr delete($data->{leveldata}), $offset, -5 * $slots; #XXX
 314         $data->{format} = '86s';
 315         return $data;
 316 }
 317
 318
 319 package Shiar_Parse::Nested;
 320
 321 sub template {
 322         my ($self, $format) = @_;
 323         # total (flattened) unpack template from nested format definitions
 324         return join '', map {
 325                 my $value = $format->[-($_ << 1) - 1];
 326                 if (ref $value eq 'ARRAY') {
 327                         my $count = $value->[0];
 328                         $value = $self->template($value);
 329                         $value = $count =~ s/^([*\d]+)// ? "$count($value)$1"
 330                                 : $count."X[$count]$count/($value)";
 331                 }
 332                 else {
 333                         $value =~ s/^C(a)(\d+)/$1 . ($2 + 1)/e;  # length prefix
 334                 }
 335                 $value;
 336         } reverse 0 .. ($#$format - 1) >> 1;
 337 }
 338
 339 sub convert {
 340         my ($self, $format, $data) = @_;
 341         # map flat results into a named and nested hash
 342         my %res;
 343         while (my ($field, $template) = splice @$format, 0, 2) {
 344                 if (ref $template eq 'ARRAY') {
 345                         my ($count, @subformat) = @$template;
 346                         my $max = $count =~ s/^(\d+)// ? $1 : 0;
 347                         $count = !$count ? $max
 348                                 : $count eq '*' ? $res{levelcount}->{total} : shift @$data;
 349                         $res{$field}->[$_] = $self->convert([@subformat], $data) for 0 .. ($max || $count)-1;
 350                         splice @{ $res{$field} }, $count if $max > $count;
 351                         $res{$field} = $res{$field}->[0] if $max == 1;
 352                         next;
 353                 }
 354                 elsif ($template =~ /^Ca/) {
 355                         $data->[0] = CORE::unpack 'C/a', $data->[0];
 356                 }
 357                 $res{$field} = shift @$data;
 358         }
 359         return \%res;
 360 }
 361
 362 sub unpack {
 363         my ($self, $format, $input) = @_;
 364         my @data = CORE::unpack $self->template($format), $input;
 365         return $self->convert($format, \@data);
 366 }
 367
 368
 369 package main;
 370
 371 my @OBJTYPE = ('none', 'line', 'fat line', 'bar', 'circle');
 372 my @ENDTYPE = ('none', 'message', 'small message');
 373
 374 sub objsummary {
 375         my ($objects) = @_;
 376         my @objtypes = map { $_->{type} } @$objects;
 377         my %count;
 378         $count{$_}++ for @objtypes;
 379         return (@objtypes > 1 && keys %count == 1 && 'all ') . join(', ',
 380                 map { $OBJTYPE[$_] ? $OBJTYPE[$_] . ($count{$_} > 1 && 's') : $_ }
 381                 sort keys %count
 382         );
 383 }
 384
 385 # read and parse all input data
 386 my $data;
 387 local $/;
 388 my $rawdata = readline;
 389 if (substr($rawdata, 0, 11) eq "**TI86**\032\012\000") {
 390         # compiled calculator file
 391         $data = Shiar_Parse::WormyLevel->read($rawdata);
 392 }
 393 elsif (substr($rawdata, 0, 8) eq 'WormEdit') {
 394         # original wormedit source
 395         $data = Shiar_Parse::WormEdit->read($rawdata);
 396 }
 397 else {
 398         die "Unrecognised file type\n";
 399 }
 400
 401 # output with user-preferred formatting
 402 if ($opt{raw}) {
 403         require JSON::XS;
 404         my $output = JSON::XS->new->ascii->canonical->pretty->allow_nonref;
 405         print $output->encode($data), "\n";
 406 }
 407 else {
 408         print $data->{name};
 409         print " ($data->{description})" if defined $data->{description};
 410         print "\n";
 411         printf "File version: %s\n", "$data->{format} v$data->{version}";
 412         printf "Defaults: %s\n", join('; ',
 413                 'sprite ' . scalar @{ $data->{sprite} },
 414                 defined $data->{hiname} ? 'hiscore by ' . $data->{hiname} : (),
 415         );
 416
 417         my $startnr = 0;
 418         for my $variant (qw/single multi race ctf/) {
 419                 my $count = $data->{levelcount}->{$variant};
 420                 print "\n";
 421                 printf '%s (%s)', ucfirst $variant, $count // 'invalid';
 422                 $count or next;
 423                 print ":";
 424                 for (0 .. $count - 1) {
 425                         my $level = $data->{levels}->[$_ + $startnr];
 426                         printf("\n- %-22s%4s:%3s+%2s%3s %3sx%-3s%s",
 427                                 $level->{id} || $level->{name} || '#'.($_+1),
 428                                 @$level{qw/size bsize growth/},
 429                                 $variant eq 'single' && "x$level->{peas}",
 430                                 @$level{qw/width height/},
 431                                 join(';', map {" $_"} grep {$_}
 432                                         @{$level->{objects}} && sprintf('%2d object%s (%s)',
 433                                                 scalar @{$level->{objects}}, @{$level->{objects}} != 1 && 's',
 434                                                 objsummary($level->{objects}),
 435                                         ),
 436                                         $level->{sprite} && @{$level->{sprite}} && sprintf('sprite %d',
 437                                                 scalar @{$level->{sprite}},
 438                                         ),
 439                                         $level->{balls} && @{$level->{balls}} && sprintf('%d bounc%s',
 440                                                 scalar @{$level->{balls}}, @{$level->{balls}} == 1 ? 'y' : 'ies',
 441                                         ),
 442                                 ),
 443                         );
 444                 }
 445                 $startnr += $count;
 446         }
 447         continue {
 448                 print "\n";
 449                 printf("-- %-21s%4s: %s (%s)\n",
 450                         '(ending)',
 451                         defined $data->{enddata} ? length $data->{enddata} : '?',
 452                         defined $data->{endtype} ? $ENDTYPE[$data->{endtype}] || 'unknown' : 'code',
 453                         $data->{endstr} // '?',
 454                 ) if $variant eq 'single';
 455         }
 456 }
 457
 458 __END__
 459
 460 =head1 NAME
 461
 462 parse-wormedit - Wormy level data parser
 463
 464 =head1 SYNOPSIS
 465
 466  parse-wormedit [--raw] <input.lvl>
 467
 468 =head1 DESCRIPTION
 469
 470 Reads Wormy levels (either original WormEdit source or compiled TI-86 string)
 471 from STDIN or given file, and outputs contents, summarised or in full.
 472
 473 =head1 AUTHOR
 474
 475 Mischa POSLAWSKY <wormy@shiar.org>
 476
 477 =head1 LICENSE
 478
 479 GPL version 3.
 480