lib/Games/Wormy/TICalcLevels.pm

   1 package Games::Wormy::TICalcLevels;
   2
   3 use 5.010;
   4 use strict;
   5 use warnings;
   6 use experimental 'switch';
   7
   8 use List::Util qw(sum min max);
   9 use Data::Dumper;
  10 use Parse::Binary::Nested qw(unpackf);
  11
  12 our $VERSION = '1.00';
  13
  14 sub read {
  15         my ($self, $input, $override) = @_;
  16         my ($psize, $ptype, $size, $type, $vsize, $dsize, $id, $version) = unpack q{
  17                 x11 x42    # file signature and comment
  18                 S a2 S a2  # file size, type; data size, type
  19                 x8         # var name
  20                 S S        # var size; content size
  21                 CC         # wormy header
  22         }, $input;
  23         $ptype eq "\014\000"
  24                 or die "Not a calculator string, thus cannot be a Wormy level file\n";
  25         $size == $psize - 16
  26                 or warn "File size ($size) does not correspond with data size ($psize)\n";
  27         $type eq "\014\010"
  28                 or die "Not a calculator string, thus cannot be a Wormy level file\n";
  29         $size == $vsize and $vsize == $dsize+2
  30                 or warn "Mismatch in string data size declarations\n";
  31 #       substr($input, -2) eq $CHECKSUM
  32
  33         $input = substr $input, 73, -2;
  34         $id eq ord 'w'
  35                 or die "Wormy level identifier not found\n";
  36
  37         if ($override) {
  38                 warn "Override version $version to $override\n";
  39                 $version = $override;
  40         }
  41         elsif ($version == 95) {
  42                 # level offset instead of description byte
  43                 $version-- if (unpack('x2Z*x2xC', $input))[1] == 0xF4;
  44                 warn "Ambiguous file version 95; guessing subversion $version\n";
  45         }
  46
  47         my @FORMAT = (
  48                 magic       => 'a1',
  49                 version     => 'C',
  50                 name        => 'Z*',
  51                 description => 'Z*',
  52                 levelcount  => [1,
  53                         total  => 'S',
  54                 ],
  55                 moderef     => [1,
  56                         map { (
  57                                 offset => [1, map {$_ => 'S'} @$_], # byte location of start
  58                                 end    => [1, map {$_ => 'C'} @$_],
  59                         ) }
  60                         [qw/single peaworm tron deathmatch foodmatch multifood timematch race ctf/]
  61                 ],
  62                 theanswer => 'x', # 42
  63                 sprite     => ['C',
  64                         line => 'B8',
  65                 ],
  66                 leveldata => 'a*',
  67                 #levels
  68                 #finish code
  69                 #levels-multi
  70                 #hinames
  71         );
  72         my @LEVELFORM = (
  73                 peas       => 'C',
  74                 delay      => 'C',
  75                 growth     => 'C',
  76                 bsize      => 'C',
  77                 sprite     => ['C',
  78                         line => 'B8',
  79                 ],
  80                 balls      => ['C',
  81                         y   => 'C',
  82                         x   => 'C',
  83                         dir => 'C',
  84                 ],
  85                 worms      => [1,
  86                         d => 'C',
  87                         y => 'C',
  88                         x => 'C',
  89                 ],
  90                 width      => 'C',
  91                 height     => 'C',
  92                 flags      => [0,
  93                         y => 'C',
  94                         x => 'C',
  95                 ],
  96                 objects    => ['?0',
  97                         type => 'C',
  98                         x1   => 'C',
  99                         y1   => 'C',
 100                         x2   => 'C',
 101                         y2   => 'C',
 102                 ],
 103         );
 104         my $offsetbase = 0xF080;
 105
 106         my @VARMODES = (
 107                 [qw'single  single'],
 108                 [qw'multi   peaworm tron deathmatch foodmatch multifood timematch'],
 109                 [qw'race    race'],
 110                 [qw'ctf     ctf'],
 111         );
 112
 113         given ($version) {
 114                 when (97) {
 115                         # current @FORMAT
 116                 }
 117                         $offsetbase = 0xF400;
 118                 when (96) {}
 119                         ref $_ and splice(@$_, -8, 2) for @{ $FORMAT[11] }; # no multifood
 120                         splice @FORMAT, 12, 2;  # no reserved byte
 121                 when (95) {}
 122                         splice @FORMAT, 6, 2;  # no description
 123                 when (94) {}
 124                 when (90) {
 125                         $FORMAT[5] = 'C/a';  # length-preceding name
 126                         splice @FORMAT, 10, 2;  # no default sprite
 127                         ref $_ and do {
 128                                 $_->[5] = $_->[7];  # no tron; deathmatch instead
 129                                 $_->[7] = $_->[9];  # foodmatch instead
 130                                 $_->[9] = 'linkmatch';  # replaces timematch
 131                                 $_->[11] = $_->[13];  # race
 132                                 $_->[13] = $_->[15];  # ctf
 133                                 $_->[15] = 'domination';
 134                         } for @{ $FORMAT[9] }; # no multifood
 135                         splice @LEVELFORM, -2;
 136                         push @LEVELFORM, "objects$_" => ['C',
 137                                 type => "=$_",
 138                                 map {$_ => 'C'} qw(x1 y1 x2 y2)
 139                         ] for 2, 3;
 140                         # peaworm/tron mode do not take multiplayer levels
 141                         splice @VARMODES, 1, 0, ['peaworm', splice @{ $VARMODES[1] }, 1, 2];
 142                 }
 143                 default {
 144                         die "Unsupported level version $version\n";
 145                 }
 146         }
 147
 148         my $data = unpackf(\@FORMAT, $input);
 149         my $offset = 0;
 150         $offsetbase += 1 + @{ $data->{sprite} } if $data->{sprite};
 151         $data->{moderef}->{offset}->{single} == $offsetbase
 152                 or warn "First singleplayer level is not in front\n";
 153
 154         my $slots = sum(grep {defined}
 155                 $data->{moderef}->{end}->{single} > 0,  # singleplayer slot if any levels
 156                 $data->{moderef}->{end}->{peaworm},     # one for each peaworm arena
 157                 $data->{moderef}->{end}->{tron},        # idem for tron
 158         );
 159         $data->{hinames} = [ unpack '(x2a3)*', substr($data->{leveldata}, -5 * $slots) ];
 160         $data->{format} = '86s';
 161
 162         $data->{levels} = [];
 163         for my $modes (@VARMODES) {
 164                 my $variant = shift @$modes;
 165                 my @modeoffsets = grep {defined} #TODO: comment
 166                         map { $data->{moderef}->{offset}->{$_} } @$modes;
 167                 @modeoffsets or next;
 168                 $data->{levelcount}->{$variant} = 0;
 169                 $offset = min(grep {$_} @modeoffsets) or next;
 170                 $offset -= $offsetbase;
 171                 my $amount = $variant eq 'single' ? 100
 172                         : max(grep {defined} map { $data->{moderef}->{end}->{$_} } @$modes);
 173
 174                 my @varform = @LEVELFORM;
 175                 $varform[13]->[0] = $variant ~~ ['single', 'peaworm'] ? 1 : 4; # worms
 176                 unshift @varform, name => 'Z*' unless $variant eq 'single' or $version <= 91;
 177                 $varform[-3]->[0] = 1 if $variant eq 'race' and $version > 91;
 178                 $varform[-3]->[0] = 2 if $variant eq 'ctf';
 179                 push @varform, size => '=.';
 180                 my $parselevel = Parse::Binary::Nested->new(\@varform);
 181
 182                 while ($offset < length $data->{leveldata}) {
 183                         last if substr($data->{leveldata}, $offset, 1) eq chr(255);
 184
 185                         # find references to this level offset, and set start number to matching modes
 186                         while (my ($mode, $location) = each %{ $data->{moderef}->{offset} }) {
 187                                 $location == $offset + $offsetbase or next;
 188                                 $data->{moderef}->{start}->{$mode} = 1 + scalar @{ $data->{levels} };
 189                         }
 190
 191                         my $level = $parselevel->unpackf(substr $data->{leveldata}, $offset);
 192                         $level->{offset} = $offset + $offsetbase;
 193
 194                         # add objects until terminator
 195                         $level->{objects} = [];
 196                 if ($version <= 91) {
 197                         ref $_ eq 'ARRAY' and push @{ $level->{objects} }, @$_
 198                                 for map { delete $level->{"objects$_"} } 2, 3;
 199                 }
 200
 201                         # add parsed level and advance
 202                         push @{ $data->{levels} }, $level;
 203                         $offset += $level->{size};
 204                         last if ++$data->{levelcount}->{$variant} >= $amount;
 205                 }
 206
 207                 if ($variant eq 'single') {
 208                         $offset++;
 209                         $data->{finish}->{code} =
 210                         my $code = substr $data->{leveldata}, $offset, -5*$slots;
 211
 212                         my %FINISHCODE = (
 213                                 0 => chr 0xC9, # ret
 214                                 1 => join('',
 215                                         chr 0x21,  # ld hl, MESSAGE
 216                                         pack('v', $offsetbase + $offset + 9),
 217                                         (map {chr}
 218                                                 0xCD, 0x37, 0x4A,  # call _puts
 219                                                 0xC3, 0xAA, 0x55,  # jp _getkey
 220                                         ),
 221                                 ),
 222                                 2 => join('',
 223                                         (map {chr}
 224                                                 0x21, 0, 0x1C,  # ld hl, $POS
 225                                                 0x22, 0x7C, 0xC3, # ld (_penCol), hl
 226                                                 0x21,  # ld hl, MESSAGE
 227                                         ),
 228                                         pack('v', $offsetbase + $offset + 15),
 229                                         (map {chr}
 230                                                 0xCD, 0xA5, 0x4A, # call _vputs
 231                                                 0xC3, 0xAA, 0x55, # jp _getkey
 232                                         ),
 233                                 ),
 234                         );
 235                         while (my ($finish, $match) = each %FINISHCODE) {
 236                                 $match eq substr $code, 0, length $match or next;
 237                                 $data->{finish}->{type} = $finish and
 238                                 $data->{finish}->{message} = unpack 'Z*', substr($code, length $match);
 239                                 last;
 240                         }
 241                 }
 242         }
 243
 244         return $data;
 245 }
 246
 247 1;
 248
 249 __END__
 250
 251 =head1 NAME
 252
 253 Games::Wormy::TICalcLevels - Read Wormy levelset from a compiled TI-86 file
 254
 255 =head1 SYNOPSIS
 256
 257         my $levelset = Games::Wormy::TICalcLevels->read($filecontents);
 258         print $levelset->{name};
 259
 260 =head1 AUTHOR
 261
 262 Mischa POSLAWSKY <perl@shiar.org>
 263
 264 =head1 LICENSE
 265
 266 LGPL version 3.
 267