X-Git-Url: http://git.shiar.nl/wormy.git/blobdiff_plain/7e3af99422406dfbf962f92927e77b6907e3f757..580332877fa744e0653d74d92dc29346b9245093:/parse-wormedit

diff --git a/parse-wormedit b/parse-wormedit
index 473f49e..43593a8 100755
--- a/parse-wormedit
+++ b/parse-wormedit
@@ -6,14 +6,22 @@ use 5.010;
 use Data::Dumper;
 use Getopt::Long 2.33 qw(HelpMessage :config bundling);
 
-our $VERSION = '1.02';
+our $VERSION = '1.04';
 
 GetOptions(\my %opt,
 	'raw|r',  # full output
 	'version=i',  # force version
 ) or HelpMessage(-exitval => 2);
 
-my %MAGICID = (
+
+package Shiar_Parse::WormEdit;
+
+use strict;
+use warnings;
+
+use Parse::Binary::Nested qw(unpackf);
+
+our %MAGICID = (
 	"WormEdit053\000LVL" => 53,
 	"WormEdit\34195\000LVL" => 95,
 	"WormEdit\34194\000LVL" => 94,
@@ -23,8 +31,8 @@ my %MAGICID = (
 my @FORMAT = (
 	magic       => 'a15',
 	version     => 'C',
-	name        => 'Ca32',
-	description => 'Ca64x256',
+	name        => 'C/a32',
+	description => 'C/a64x256',
 	levelcount  => [1,
 		single => 'C',
 		multi  => 'C',
@@ -42,19 +50,23 @@ my @FORMAT = (
 			multifood  => 'C',
 			timematch  => 'C',
 			race       => 'C',
-			ctf        => 'Cx',
+			ctf        => 'C',
+			reserved   => 'x',
 		],
 	],
 	sprite     => ['8C',
 		line => 'B8',
 	],
-	endtype     => 's',
-	endstr      => 'Ca255',
-	enddata     => 'Ca255x256',
+	finish      => [1,
+		type    => 's',
+		message => 'C/a255',
+		code    => 'C/a255',
+		reserved=> 'x256',
+	],
 	hiname      => 'a3',
 	levels      => ['*', # levelcount->total actually
-		id         => 'Ca22',
-		name       => 'Ca22',
+		id         => 'C/a22',
+		name       => 'C/a22',
 		size       => 'C',
 		peas       => 'C',
 		delay      => 'C',
@@ -89,6 +101,310 @@ my @FORMAT = (
 	],
 );
 
+sub read {
+	my ($self, $input) = @_;
+	my ($id, $version) = (substr($input, 0, 15), ord substr($input, 15, 1));
+	my $fileversion = $MAGICID{$id}
+		or die "File does not match any known WormEdit level header\n";
+
+	if ($opt{version}) {
+		warn "Override version $version to $opt{version}\n";
+		$version = $opt{version};
+	}
+	elsif ($version != $fileversion) {
+		warn "Unexpected version $version (expecting $fileversion)\n";
+	}
+	elsif ($version == 95) {
+		# auto-detect exact variant
+		if (ord substr($input, 70, 1) ~~ [1 .. 8]) {
+			# valid sprite length instead of description byte
+			# (which is usually a letter or nul)
+			$version = 94;
+		}
+		elsif (ord substr($input, 147, 1) == 0) {
+			# nul of finish type is 2 bytes later (unlike first char of message)
+			$version = 96;
+		}
+		warn "Ambiguous file version 95; guessing subversion $version\n";
+	};
+
+	$fileversion += 100 if $fileversion < 90;  # 93..95 came before 50..53
+	given ($fileversion) {
+		when (153) { } # current @FORMAT
+			$FORMAT[7] = 'C/a64'; # no reserved space after description
+			splice @{ $FORMAT[15] }, -2; # finish reserve
+			$FORMAT[-1]->[-1]->[0] = '32C'; # less objects
+			ref $_ and pop @$_ for @{ $FORMAT[11] }; # 9 moderefs
+		when ($version == 96) { }
+			ref $_ and pop @$_ for @{ $FORMAT[11] }; # only 8 moderefs (no ctf)
+			splice @FORMAT, 6, 2 if $version <= 94;  # earlier version without description
+		when (95) { }
+			splice @{ $FORMAT[7] }, 4, 2;  # no race
+			splice @{ $FORMAT[13] }, 4, 2; # no enddata
+			splice @{ $FORMAT[-1] }, 1, 2; # no name
+		when (94) { }
+			splice @FORMAT, 14, 2; # no hiname
+			$FORMAT[-1]->[0] = 64; # constant amount of levels
+		when (93) { }
+		default {
+			die "Cannot parse data for Wormedit $fileversion/$version\n";
+		}
+	}
+
+	# convert to an easily accessible hash
+	push @FORMAT, -trail => 'a*';
+	my $data = unpackf(\@FORMAT, $input);
+	warn "Trailing data left unparsed\n" if length delete $data->{-trail};
+	$data->{format} = 'WormEdit';
+	return $data;
+}
+
+
+package Shiar_Parse::WormyLevel;
+
+use strict;
+use warnings;
+
+use List::Util qw(sum min max);
+use Data::Dumper;
+use Parse::Binary::Nested qw(unpackf);
+
+sub read {
+	my ($self, $input) = @_;
+	my ($psize, $ptype, $size, $type, $vsize, $dsize, $id, $version) = unpack q{
+		x11 x42    # file signature and comment
+		S a2 S a2  # file size, type; data size, type
+		x8         # var name
+		S S        # var size; content size
+		CC         # wormy header
+	}, $input;
+	$ptype eq "\014\000"
+		or die "Not a calculator string, thus cannot be a Wormy level file\n";
+	$size == $psize - 16
+		or warn "File size ($size) does not correspond with data size ($psize)\n";
+	$type eq "\014\010"
+		or die "Not a calculator string, thus cannot be a Wormy level file\n";
+	$size == $vsize and $vsize == $dsize+2
+		or warn "Mismatch in string data size declarations\n";
+#	substr($input, -2) eq $CHECKSUM
+
+	$input = substr $input, 73, -2;
+	$id eq ord 'w'
+		or die "Wormy level identifier not found\n";
+
+	if ($opt{version}) {
+		warn "Override version $version to $opt{version}\n";
+		$version = $opt{version};
+	}
+	elsif ($version == 95) {
+		# level offset instead of description byte
+		$version-- if (unpack('x2Z*x2xC', $input))[1] == 0xF4;
+		warn "Ambiguous file version 95; guessing subversion $version\n";
+	}
+
+	my @FORMAT = (
+		magic       => 'a1',
+		version     => 'C',
+		name        => 'Z*',
+		description => 'Z*',
+		levelcount  => [1,
+			total  => 'S',
+		],
+		moderef     => [1,
+			map { (
+				offset => [1, map {$_ => 'S'} @$_], # byte location of start
+				end    => [1, map {$_ => 'C'} @$_],
+			) }
+			[qw/single peaworm tron deathmatch foodmatch multifood timematch race ctf/]
+		],
+		theanswer => 'x', # 42
+		sprite     => ['C',
+			line => 'B8',
+		],
+		leveldata => 'a*',
+		#levels
+		#finish code
+		#levels-multi
+		#hinames
+	);
+	my @LEVELFORM = (
+		peas       => 'C',
+		delay      => 'C',
+		growth     => 'C',
+		bsize      => 'C',
+		sprite     => ['C',
+			line => 'B8',
+		],
+		balls      => ['C',
+			y   => 'C',
+			x   => 'C',
+			dir => 'C',
+		],
+		worms      => [1,
+			d => 'C',
+			y => 'C',
+			x => 'C',
+		],
+		width      => 'C',
+		height     => 'C',
+		flags      => [0,
+			y => 'C',
+			x => 'C',
+		],
+		objects    => ['?0',
+			type => 'C',
+			x1   => 'C',
+			y1   => 'C',
+			x2   => 'C',
+			y2   => 'C',
+		],
+	);
+	my $offsetbase = 0xF080;
+
+	my @VARMODES = (
+		[qw'single  single'],
+		[qw'multi   peaworm tron deathmatch foodmatch multifood timematch'],
+		[qw'race    race'],
+		[qw'ctf     ctf'],
+	);
+
+	given ($version) {
+		when (97) {
+			# current @FORMAT
+		}
+			$offsetbase = 0xF400;
+		when (96) {}
+			ref $_ and splice(@$_, -8, 2) for @{ $FORMAT[11] }; # no multifood
+			splice @FORMAT, 12, 2;  # no reserved byte
+		when (95) {}
+			splice @FORMAT, 6, 2;  # no description
+		when (94) {}
+		when (90) {
+			$FORMAT[5] = 'C/a';  # length-preceding name
+			splice @FORMAT, 10, 2;  # no default sprite
+			ref $_ and do {
+				$_->[5] = $_->[7];  # no tron; deathmatch instead
+				$_->[7] = $_->[9];  # foodmatch instead
+				$_->[9] = 'linkmatch';  # replaces timematch
+				$_->[11] = $_->[13];  # race
+				$_->[13] = $_->[15];  # ctf
+				$_->[15] = 'domination';
+			} for @{ $FORMAT[9] }; # no multifood
+			splice @LEVELFORM, -2;
+			push @LEVELFORM, "objects$_" => ['C',
+				type => "=$_",
+				map {$_ => 'C'} qw(x1 y1 x2 y2)
+			] for 2, 3;
+			# peaworm/tron mode do not take multiplayer levels
+			splice @VARMODES, 1, 0, ['peaworm', splice @{ $VARMODES[1] }, 1, 2];
+		}
+		default {
+			die "Unsupported level version $version\n";
+		}
+	}
+
+	my $data = unpackf(\@FORMAT, $input);
+	my $offset = 0;
+	$offsetbase += 1 + @{ $data->{sprite} } if $data->{sprite};
+	$data->{moderef}->{offset}->{single} == $offsetbase
+		or warn "First singleplayer level is not in front\n";
+
+	my $slots = sum(grep {defined}
+		$data->{moderef}->{end}->{single} > 0,  # singleplayer slot if any levels
+		$data->{moderef}->{end}->{peaworm},     # one for each peaworm arena
+		$data->{moderef}->{end}->{tron},        # idem for tron
+	);
+	$data->{hinames} = [ unpack '(x2a3)*', substr($data->{leveldata}, -5 * $slots) ];
+	$data->{format} = '86s';
+
+	$data->{levels} = [];
+	for my $modes (@VARMODES) {
+		my $variant = shift @$modes;
+		my @modeoffsets = grep {defined} #TODO: comment
+			map { $data->{moderef}->{offset}->{$_} } @$modes;
+		@modeoffsets or next;
+		$data->{levelcount}->{$variant} = 0;
+		$offset = min(grep {$_} @modeoffsets) or next;
+		$offset -= $offsetbase;
+		my $amount = $variant eq 'single' ? 100
+			: max(grep {defined} map { $data->{moderef}->{end}->{$_} } @$modes);
+
+		my @varform = @LEVELFORM;
+		$varform[13]->[0] = $variant ~~ ['single', 'peaworm'] ? 1 : 4; # worms
+		unshift @varform, name => 'Z*' unless $variant eq 'single' or $version <= 91;
+		$varform[-3]->[0] = 1 if $variant eq 'race' and $version > 91;
+		$varform[-3]->[0] = 2 if $variant eq 'ctf';
+		push @varform, size => '=.';
+		my $parselevel = Parse::Binary::Nested->new(\@varform);
+
+		while ($offset < length $data->{leveldata}) {
+			last if substr($data->{leveldata}, $offset, 1) eq chr(255);
+
+			# find references to this level offset, and set start number to matching modes
+			while (my ($mode, $location) = each %{ $data->{moderef}->{offset} }) {
+				$location == $offset + $offsetbase or next;
+				$data->{moderef}->{start}->{$mode} = 1 + scalar @{ $data->{levels} };
+			}
+
+			my $level = $parselevel->unpackf(substr $data->{leveldata}, $offset);
+			$level->{offset} = $offset + $offsetbase;
+
+			# add objects until terminator
+			$level->{objects} = [];
+		if ($version <= 91) {
+			ref $_ eq 'ARRAY' and push @{ $level->{objects} }, @$_
+				for map { delete $level->{"objects$_"} } 2, 3;
+		}
+
+			# add parsed level and advance
+			push @{ $data->{levels} }, $level;
+			$offset += $level->{size};
+			last if ++$data->{levelcount}->{$variant} >= $amount;
+		}
+
+		if ($variant eq 'single') {
+			$offset++;
+			$data->{finish}->{code} =
+			my $code = substr $data->{leveldata}, $offset, -5*$slots;
+
+			my %FINISHCODE = (
+				0 => chr 0xC9, # ret
+				1 => join('',
+					chr 0x21,  # ld hl, MESSAGE
+					pack('v', $offsetbase + $offset + 9),
+					(map {chr}
+						0xCD, 0x37, 0x4A,  # call _puts
+						0xC3, 0xAA, 0x55,  # jp _getkey
+					),
+				),
+				2 => join('',
+					(map {chr}
+						0x21, 0, 0x1C,  # ld hl, $POS
+						0x22, 0x7C, 0xC3, # ld (_penCol), hl
+						0x21,  # ld hl, MESSAGE
+					),
+					pack('v', $offsetbase + $offset + 15),
+					(map {chr}
+						0xCD, 0xA5, 0x4A, # call _vputs
+						0xC3, 0xAA, 0x55, # jp _getkey
+					),
+				),
+			);
+			while (my ($finish, $match) = each %FINISHCODE) {
+				$match eq substr $code, 0, length $match or next;
+				$data->{finish}->{type} = $finish and
+				$data->{finish}->{message} = unpack 'Z*', substr($code, length $match);
+				last;
+			}
+		}
+	}
+
+	return $data;
+}
+
+
+package main;
+
 my @OBJTYPE = ('none', 'line', 'fat line', 'bar', 'circle');
 my @ENDTYPE = ('none', 'message', 'small message');
 
@@ -104,149 +420,103 @@ sub objsummary {
 }
 
 # read and parse all input data
+my $data;
 local $/;
 my $rawdata = readline;
-my ($id, $subid) = (substr($rawdata, 0, 15), ord substr($rawdata, 15, 1));
-my $version = $opt{version} // $MAGICID{$id}
-	or die "File does not match any known WormEdit level header\n";
-$subid == $version
-	or warn "Unsupported version $subid (expecting $version)\n";
-given ($version) {
-	when (53) {
-		# current @FORMAT
-	}
-	when ($_ <= 95 and $_ > 90) {
-		ref $_ and pop @$_ for @{ $FORMAT[11] }; # only 8 moderefs
-		$FORMAT[-1]->[-1]->[0] = '32C'; # less objects
-		continue;
-	}
-	when (95) {
-		$FORMAT[7] = 'Ca64'; # no reserved space after description
-		#ref $_ and $_->[-1] = 'C' for @{ $FORMAT[11] }; # only 9 moderefs
-		$FORMAT[19] = 'Ca255'; # enddata
-		splice @FORMAT, 6, 2 if $subid < 95;  # early (sub)version without description
-	}
-	when ($_ <= 94 and $_ > 90) {
-		splice @FORMAT, 6, 2;  # no description
-		splice @{ $FORMAT[7] }, 4, 2;  # no race
-		splice @FORMAT, 16, 2; # no enddata
-		splice @{ $FORMAT[-1] }, 1, 2; # no name
-		continue if $_ < 94;
-	}
-	when (93) {
-		splice @FORMAT, 16, 2; # no hiname
-		$FORMAT[-1]->[0] = 64; # constant amount of levels
-	}
-	default {
-		die "Cannot parse data for Wormedit $version\n";
-	}
+if (substr($rawdata, 0, 11) eq "**TI86**\032\012\000") {
+	# compiled calculator file
+	$data = Shiar_Parse::WormyLevel->read($rawdata);
+}
+elsif (substr($rawdata, 0, 8) eq 'WormEdit') {
+	# original wormedit source
+	$data = Shiar_Parse::WormEdit->read($rawdata);
+}
+else {
+	die "Unrecognised file type\n";
 }
-my @rawdata = unpack Shiar_Parse::Nested->template(\@FORMAT).'a*', $rawdata;
-
-# convert to an easily accessible hash
-my $data = Shiar_Parse::Nested->convert(\@FORMAT, \@rawdata);
-warn "Trailing data left unparsed\n" if grep {length} @rawdata;
 
 # output with user-preferred formatting
 if ($opt{raw}) {
-	require JSON::XS;
-	my $output = JSON::XS->new->ascii->canonical->pretty->allow_nonref;
-	print $output->encode($data), "\n";
+	# full data in yaml (human-readable) formatting
+	require YAML;
+	local $YAML::CompressSeries;
+	      $YAML::CompressSeries = 0;
+	my $yml = "# Wormy levelset\n" . YAML::Dump($data);
+
+	# inline format of short hashes
+	$yml =~ s{
+		^(\ *) - \n                          # array indicator
+		((?:\1\ \ [a-z0-9]{1,5}:\ *\d+\n)+)  # simple hash declaration
+		(?!\1\ )                             # no further children
+	}[
+		my ($indent, $value) = ($1, $2);
+		chop $value;
+		$value =~ s/^ +//gm;
+		$value =~ s/\n/, /g;
+		"$indent- {$value}\n";
+	]egmx;
+
+	print $yml;
 }
 else {
 	print $data->{name};
 	print " ($data->{description})" if defined $data->{description};
 	print "\n";
-	printf "File version: %s\n", "WormEdit v$data->{version}";
+	printf "File version: %s\n", "$data->{format} v$data->{version}";
 	printf "Defaults: %s\n", join('; ',
-		'sprite ' . scalar @{ $data->{sprite} },
+		$data->{sprite} ? 'sprite ' . scalar @{ $data->{sprite} } : (),
 		defined $data->{hiname} ? 'hiscore by ' . $data->{hiname} : (),
 	);
 
 	my $startnr = 0;
-	for my $variant (qw/single multi race ctf/) {
+	for my $variant (qw/single peaworm multi race ctf/) {
 		my $count = $data->{levelcount}->{$variant};
+		defined $count or next;
 		print "\n";
-		printf '%s (%s)', ucfirst $variant, $count // 'invalid';
+		printf '%s (%s)', ucfirst $variant, $count;
 		$count or next;
 		print ":";
-		printf("\n- %-22s%4s:%3s+%2s%3s %3sx%-3s%s",
-			$_->{id} || $_->{name},
-			@$_{qw/size bsize growth/},
-			$variant eq 'single' && "x$_->{peas}",
-			@$_{qw/width height/},
-			join(';', map {" $_"} grep {$_}
-				@{$_->{objects}} && sprintf('%2d object%s (%s)',
-					scalar @{$_->{objects}}, @{$_->{objects}} != 1 && 's',
-					objsummary($_->{objects}),
+		for (0 .. $count - 1) {
+			my $level = $data->{levels}->[$_ + $startnr];
+			printf("\n- %-22s%4s:%3s+%2s%3s %3sx%-3s%s",
+				$level->{id} || $level->{name} || '#'.($_+1),
+				@$level{qw/size bsize growth/},
+				$variant eq 'single' && "x$level->{peas}",
+				@$level{qw/width height/},
+				join(';', map {" $_"} grep {$_}
+					@{$level->{objects}} && sprintf('%2d object%s (%s)',
+						scalar @{$level->{objects}}, @{$level->{objects}} != 1 && 's',
+						objsummary($level->{objects}),
+					),
+					$level->{sprite} && @{$level->{sprite}} && sprintf('sprite %d',
+						scalar @{$level->{sprite}},
+					),
+					$level->{balls} && @{$level->{balls}} && sprintf('%d bounc%s',
+						scalar @{$level->{balls}}, @{$level->{balls}} == 1 ? 'y' : 'ies',
+					),
 				),
-				@{$_->{sprite}} && sprintf('sprite %d',
-					scalar @{$_->{sprite}},
-				),
-			),
-		) for map { $data->{levels}->[$_ + $startnr] }
-			0 .. $count - 1;
+			);
+		}
 		$startnr += $count;
-	}
-	continue {
+
 		print "\n";
 		printf("-- %-21s%4s: %s (%s)\n",
 			'(ending)',
-			defined $data->{enddata} ? length $data->{enddata} : '?',
-			$ENDTYPE[$data->{endtype}] || 'unknown', $data->{endstr},
+			defined $data->{finish}->{code}
+				? length $data->{finish}->{code} : '?',
+			defined $data->{finish}->{type}
+				? $ENDTYPE[$data->{finish}->{type}] || 'unknown' : 'code',
+			$data->{finish}->{message} // '?',
 		) if $variant eq 'single';
 	}
-}
-
-package Shiar_Parse::Nested;
-
-sub template {
-	my ($self, $format) = @_;
-	# total (flattened) unpack template from nested format definitions
-	return join '', map {
-		my $value = $format->[-($_ << 1) - 1];
-		if (ref $value eq 'ARRAY') {
-			my $count = $value->[0];
-			$value = $self->template($value);
-			$value = $count =~ s/^([*\d]+)// ? "$count($value)$1"
-				: $count."X[$count]$count/($value)";
-		}
-		else {
-			$value =~ s/^C(a)(\d+)/$1 . ($2 + 1)/e;  # length prefix
-		}
-		$value;
-	} reverse 0 .. ($#$format - 1) >> 1;
-}
-
-sub convert {
-	my ($self, $format, $data) = @_;
-	# map flat results into a named and nested hash
-	my %res;
-	while (my ($field, $template) = splice @$format, 0, 2) {
-		if (ref $template eq 'ARRAY') {
-			my ($count, @subformat) = @$template;
-			my $max = $count =~ s/^(\d+)// ? $1 : 0;
-			$count = !$count ? $max
-				: $count eq '*' ? $res{levelcount}->{total} : shift @$data;
-			$max ||= $count;
-			$res{$field}->[$_] = $self->convert([@subformat], $data) for 0 .. $max-1;
-			splice @{ $res{$field} }, $count if $max > $count;
-			$res{$field} = $res{$field}->[0] if $max == 1;
-			next;
-		}
-		elsif ($template =~ /^Ca/) {
-			$data->[0] = unpack 'C/a', $data->[0];
-		}
-		$res{$field} = shift @$data;
-	}
-	return \%res;
+	print "\n";
 }
 
 __END__
 
 =head1 NAME
 
-parse-wormedit - WormEdit level data parser
+parse-wormedit - Wormy level data parser
 
 =head1 SYNOPSIS
 
@@ -254,8 +524,8 @@ parse-wormedit - WormEdit level data parser
 
 =head1 DESCRIPTION
 
-Reads WormEdit v0.53 levels from STDIN or given file,
-and outputs contents, summarised or in full.
+Reads Wormy levels (either original WormEdit source or compiled TI-86 string)
+from STDIN or given file, and outputs contents, summarised or in full.
 
 =head1 AUTHOR