X-Git-Url: http://git.shiar.nl/wormy.git/blobdiff_plain/c1c7a10ad684086c18f7db5456143212a40146e7..7c64957ec9a87cf71ccf5fa7c28bb8c37b27efc6:/parse-wormedit

diff --git a/parse-wormedit b/parse-wormedit
index 2eb9e27..84e4e31 100755
--- a/parse-wormedit
+++ b/parse-wormedit
@@ -1,17 +1,30 @@
 #!/usr/bin/env perl
 use strict;
 use warnings;
+use 5.010;
 
 use Data::Dumper;
 use Getopt::Long 2.33 qw(HelpMessage :config bundling);
 
-our $VERSION = '1.01';
+our $VERSION = '1.03';
 
 GetOptions(\my %opt,
-	'raw|r',
+	'raw|r',  # full output
+	'version=i',  # force version
 ) or HelpMessage(-exitval => 2);
 
-my $MAGICID = "WormEdit053\000LVL";
+
+package Shiar_Parse::WormEdit;
+
+use strict;
+use warnings;
+
+our %MAGICID = (
+	"WormEdit053\000LVL" => 53,
+	"WormEdit\34195\000LVL" => 95,
+	"WormEdit\34194\000LVL" => 94,
+	"WormEdit\34193\000LVL" => 93,
+);
 
 my @FORMAT = (
 	magic       => 'a15',
@@ -41,9 +54,11 @@ my @FORMAT = (
 	sprite     => ['8C',
 		line => 'B8',
 	],
-	endtype     => 's',
-	endstr      => 'Ca255',
-	enddata     => 'Ca255x256',
+	finish      => [1,
+		type    => 's',
+		message => 'Ca255',
+		code    => 'Ca255x256',
+	],
 	hiname      => 'a3',
 	levels      => ['*', # levelcount->total actually
 		id         => 'Ca22',
@@ -82,81 +97,320 @@ my @FORMAT = (
 	],
 );
 
-my @OBJTYPE = ('none', 'line', 'fat line', 'bar', 'circle');
-my @ENDTYPE = ('none', 'message', 'small message');
+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";
 
-sub objsummary {
-	my ($objects) = @_;
-	my @objtypes = map { $_->{type} } @$objects;
-	my %count;
-	$count{$_}++ for @objtypes;
-	return (@objtypes > 1 && keys %count == 1 && 'all ') . join(', ',
-		map { $OBJTYPE[$_] ? $OBJTYPE[$_] . ($count{$_} > 1 && 's') : $_ }
-		sort keys %count
-	);
+	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] = 'Ca64'; # no reserved space after description
+			$FORMAT[15]->[-1] = 'Ca255'; # enddata
+			$FORMAT[-1]->[-1]->[0] = '32C'; # less objects
+		when ($version == 96) {
+			ref $_ and $_->[-1] = 'C' for @{ $FORMAT[11] }; # 9 moderefs
+		}
+			ref $_ and pop @$_ for @{ $FORMAT[11] }; # only 8 moderefs
+			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
+	my @values = unpack Shiar_Parse::Nested->template(\@FORMAT).'a*', $input;
+	my $data = Shiar_Parse::Nested->convert(\@FORMAT, \@values);
+	warn "Trailing data left unparsed\n" if grep {length} @values;
+	$data->{format} = 'WormEdit';
+	return $data;
 }
 
-# read and parse all input data
-local $/;
-my @rawdata = unpack Shiar_Parse::Nested->template(\@FORMAT).'a*', readline;
-$rawdata[0] eq $MAGICID
-	or die "File does not match WormEdit level header\n";
-$rawdata[1] == 53
-	or warn "Unsupported version $rawdata[1] (expecting 53)\n";
 
-# convert to an easily accessible hash
-my $data = Shiar_Parse::Nested->convert(\@FORMAT, \@rawdata);
-warn "Trailing data left unparsed\n" if grep {length} @rawdata;
+package Shiar_Parse::WormyLevel;
 
-# 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";
-}
-else {
-	print "$data->{name} ($data->{description})\n";
-	printf "File version: %s\n", "WormEdit v$data->{version}";
-	printf "Defaults: %s\n", join('; ',
-		'sprite ' . scalar @{ $data->{sprite} },
-		'hiscore by ' . $data->{hiname},
+use strict;
+use warnings;
+
+use List::Util qw(sum min max);
+use Data::Dumper;
+
+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 => 'C', # 42
+		sprite     => ['C',
+			line => 'B8',
+		],
+		leveldata => 'a*',
+	);
+	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',
+		],
+		#levels
+		#finish code
+		#levels-multi
+		#hinames
+	);
+	my @OBJECTFORM = (
+			type => 'C',
+			x1   => 'C',
+			y1   => 'C',
+			x2   => 'C',
+			y2   => 'C',
 	);
+	my $offsetbase = 0xF080;
 
-	my $startnr = 0;
-	for my $variant (qw/single multi race ctf/) {
-		print "\n";
-		my $count = $data->{levelcount}->{$variant};
-		printf "\u$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}),
+	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
+			push @LEVELFORM, "object$_" => ['C',
+				map {$_ => 'C'} qw(x1 y1 x2 y2)
+			] for qw(lines boxes);
+		}
+		default {
+			die "Unsupported level version $version\n";
+		}
+	}
+
+	my $data = Shiar_Parse::Nested->unpack(\@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(
+		$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';
+
+	my @VARMODES = (
+		[qw'single  single'],
+		[qw'multi   peaworm tron deathmatch foodmatch multifood timematch'],
+		[qw'race    race'],
+		[qw'ctf     ctf'],
+	);
+
+	$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 eq 'single' ? 1 : 4;
+		unshift @varform, name => 'Z*' unless $variant eq 'single' or $version <= 91;
+		$varform[-1]->[0] = 1 if $variant eq 'race' and $version > 91;
+		$varform[-1]->[0] = 2 if $variant eq 'ctf';
+
+		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 = Shiar_Parse::Nested->unpack(
+				[@varform], substr $data->{leveldata}, $offset
+			);
+			my $size = 8  # unpack length (ugh, ugly recalculation)
+				+ (defined $level->{name} ? 1 + length $level->{name} : 0)
+				+ 3 * (ref $level->{worms} eq 'ARRAY' ? scalar @{$level->{worms}} : 1)
+				+ 2 * ($level->{flags} ? ref $level->{flags} eq 'ARRAY' ? scalar @{$level->{flags}} : 1 : 0)
+				+ ($level->{sprite} ? scalar @{$level->{sprite}} : 0)
+				+ ($level->{balls} ? 3 * scalar @{$level->{balls}} : 0);
+			$level->{size} = $size;
+			$level->{offset} = $offset + $offsetbase;
+
+			# add objects until terminator
+			$level->{objects} = [];
+		if ($version <= 91) {
+			push @{ $level->{objects} }, { %$_, type => 2 } for map { $level->{$_} ? @{ $level->{$_} } : () } qw(objectlines);
+			push @{ $level->{objects} }, { %$_, type => 3 } for map { $level->{$_} ? @{ $level->{$_} } : () } qw(objectboxes);
+			$size += 1 + 4 * scalar @{ $level->{objects} };
+		}
+		else {
+			while (my $object = ord substr($data->{leveldata}, $offset+$size, 1)) {
+				push @{ $level->{objects} }, Shiar_Parse::Nested->unpack(
+					[@OBJECTFORM], substr($data->{leveldata}, $offset+$size, 5)
+				);
+				$size += 5;
+			}
+		}
+
+			# add parsed level and advance
+			push @{ $data->{levels} }, $level;
+			$offset += ++$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
+					),
 				),
-				@{$_->{sprite}} && sprintf('sprite %d',
-					scalar @{$_->{sprite}},
+				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
+					),
 				),
-			),
-		) for map { $data->{levels}->[$_ + $startnr] }
-			0 .. $count - 1;
-		$startnr += $count;
-	}
-	continue {
-		print "\n";
-		printf("-- %-21s%4d: %s (%s)\n",
-			'(ending)',
-			length $data->{enddata},
-			$ENDTYPE[$data->{endtype}] || 'unknown', $data->{endstr},
-		) if $variant eq 'single';
+			);
+			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 Shiar_Parse::Nested;
 
 sub template {
@@ -187,25 +441,139 @@ sub convert {
 			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;
+			$res{$field}->[$_] = $self->convert([@subformat], $data) for 0 .. ($max || $count)-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];
+			$data->[0] = CORE::unpack 'C/a', $data->[0];
 		}
 		$res{$field} = shift @$data;
 	}
 	return \%res;
 }
 
+sub unpack {
+	my ($self, $format, $input) = @_;
+	my @data = CORE::unpack $self->template($format), $input;
+	return $self->convert($format, \@data);
+}
+
+
+package main;
+
+my @OBJTYPE = ('none', 'line', 'fat line', 'bar', 'circle');
+my @ENDTYPE = ('none', 'message', 'small message');
+
+sub objsummary {
+	my ($objects) = @_;
+	my @objtypes = map { $_->{type} } @$objects;
+	my %count;
+	$count{$_}++ for @objtypes;
+	return (@objtypes > 1 && keys %count == 1 && 'all ') . join(', ',
+		map { $OBJTYPE[$_] ? $OBJTYPE[$_] . ($count{$_} > 1 && 's') : $_ }
+		sort keys %count
+	);
+}
+
+# read and parse all input data
+my $data;
+local $/;
+my $rawdata = readline;
+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";
+}
+
+# output with user-preferred formatting
+if ($opt{raw}) {
+	# 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", "$data->{format} v$data->{version}";
+	printf "Defaults: %s\n", join('; ',
+		$data->{sprite} ? 'sprite ' . scalar @{ $data->{sprite} } : (),
+		defined $data->{hiname} ? 'hiscore by ' . $data->{hiname} : (),
+	);
+
+	my $startnr = 0;
+	for my $variant (qw/single multi race ctf/) {
+		my $count = $data->{levelcount}->{$variant};
+		print "\n";
+		printf '%s (%s)', ucfirst $variant, $count // 'invalid';
+		$count or next;
+		print ":";
+		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',
+					),
+				),
+			);
+		}
+		$startnr += $count;
+	}
+	continue {
+		print "\n";
+		printf("-- %-21s%4s: %s (%s)\n",
+			'(ending)',
+			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';
+	}
+}
+
 __END__
 
 =head1 NAME
 
-parse-wormedit - WormEdit level data parser
+parse-wormedit - Wormy level data parser
 
 =head1 SYNOPSIS
 
@@ -213,8 +581,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