package Games::Wormy::TICalcLevels;

use 5.010;
use strict;
use warnings;
use experimental 'switch';

use List::Util qw(sum min max);
use Data::Dumper;
use Parse::Binary::Nested qw(unpackf);

our $VERSION = '1.00';

sub read {
	my ($self, $input, $override) = @_;
	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 ($override) {
		warn "Override version $version to $override\n";
		$version = $override;
	}
	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;
}

1;

__END__

=head1 NAME

Games::Wormy::TICalcLevels - Read Wormy levelset from a compiled TI-86 file

=head1 SYNOPSIS

	my $levelset = Games::Wormy::TICalcLevels->read($filecontents);
	print $levelset->{name};

=head1 AUTHOR

Mischa POSLAWSKY <perl@shiar.org>

=head1 LICENSE

LGPL version 3.

