#!/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.04';

GetOptions(\my %opt,
	'raw|r',  # full output
	'version=i',  # force version
) or HelpMessage(-exitval => 2);


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,
	"WormEdit\34193\000LVL" => 93,
);

my @FORMAT = (
	magic       => 'a15',
	version     => 'C',
	name        => 'C/a32',
	description => 'C/a64x256',
	levelcount  => [1,
		single => 'C',
		multi  => 'C',
		race   => 'C',
		ctf    => 'C',
		total  => 'C',
	],
	moderef     => [1,
		map { (start => $_, end => $_) } [1,
			single     => 'C',
			peaworm    => 'C',
			tron       => 'C',
			deathmatch => 'C',
			foodmatch  => 'C',
			multifood  => 'C',
			timematch  => 'C',
			race       => 'C',
			ctf        => 'C',
			reserved   => 'x',
		],
	],
	sprite     => ['8C',
		line => 'B8',
	],
	finish      => [1,
		type    => 's',
		message => 'C/a255',
		code    => 'C/a255',
		reserved=> 'x256',
	],
	hiname      => 'a3',
	levels      => ['*', # levelcount->total actually
		id         => 'C/a22',
		name       => 'C/a22',
		size       => 'C',
		peas       => 'C',
		delay      => 'C',
		growth     => 'C',
		bsize      => 'C',
		sprite     => ['8C',
			line => 'B8',
		],
		balls      => ['32C',
			y   => 'C',
			x   => 'C',
			dir => 'C',
		],
		worms      => [4,
			d => 'C',
			y => 'C',
			x => 'C',
		],
		width      => 'C',
		height     => 'C',
		flags      => [2,
			y => 'C',
			x => 'C',
		],
		objects    => ['128C',
			type => 'C',
			x1   => 'C',
			y1   => 'C',
			x2   => 'C',
			y2   => 'C',
		],
	],
);

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;

	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;
		}
		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(
		$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[-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');

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 - Wormy level data parser

=head1 SYNOPSIS

 parse-wormedit [--raw] <input.lvl>

=head1 DESCRIPTION

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

Mischa POSLAWSKY <wormy@shiar.org>

=head1 LICENSE

GPL version 3.