package DiceDistribution;
use Parse::RecDescent;
use strict;
use vars qw($parser @ISA @EXPORT_OK);

@ISA = qw(Exporter);
@EXPORT_OK = qw(get_distribution);

$parser = Parse::RecDescent->new(<<'GRAMMAR');
expression: add_expr end  { $item[1] }
add_expr:   mult_expr '+' add_expr
		{ { left=>$item[1], op => '+', right => $item[3] } }
add_expr:   mult_expr '-' add_expr
	        { { left=>$item[1], op => '-', right => $item[3] } }
add_expr:  mult_expr
mult_expr:  brack_expr 'x' mult_expr
		{ { left=>$item[1], op => 'x', right => $item[3] } }
mult_expr:  brack_expr '*' mult_expr
		{ { left=>$item[1], op => 'x', right => $item[3] } }
mult_expr:  brack_expr
brack_expr: '(' add_expr ')'
		{ $item[2] }
brack_expr: dieroll
dieroll:    /\d+(?:[dfDF]\d+)?/
end:        /\s*$/
GRAMMAR

sub get_distribution
{
	my $die_expression = shift;
	
	my $result = $parser->expression($die_expression);

	die "Invalid expression: $die_expression\n" 
		unless defined $result;

	return walk_tree($result);
}

sub walk_tree
{
	my $node = shift;
	
	if (ref $node)
	{
		for  ($node->{op})
		{
			/\+/ && return combine_distributions(
				sub { return $_[0] + $_[1] },
				[walk_tree($node->{left})],
				[walk_tree($node->{right})]
				);

			/-/ && return combine_distributions(
				sub { return $_[0] - $_[1] },
				[walk_tree($node->{left})],
				[walk_tree($node->{right})]
				);

			/x/ && return combine_distributions(
				sub { return $_[0] * $_[1] },
				[walk_tree($node->{left})],
				[walk_tree($node->{right})]
				);
		}
	}

	# must be a terminal so calculate distribution.

	if ($node=~/^(\d+)([dfDF])(\d+)/)
	{
		if ($2 eq 'f' || $2 eq 'F')
		{
			my @table = fudge_roll_distribution($1,$3);
			return @table;
		}
		else
		{
			my @table = basic_roll_distribution($1,$3);
			return @table;
		}
	}
	elsif ($node=~/^\d+$/)
	{
		return ($node,$node,1);
	}
	
	die "Invalid token: $node\n";
}
		


sub combine_distributions
{
	my ($func, $dist1, $dist2) = @_;
	my %table;

	for my $d1 ($dist1->[0] ... $dist1->[1])
	{
		for my $d2 ($dist2->[0] ... $dist2->[1])
		{
			$table{$func->($d1,$d2)} += 
				$dist1->[$d1-$dist1->[0]+2] * $dist2->[$d2-$dist2->[0]+2];
		}
	}

	my @keys = sort { $a <=> $b} keys %table;
	return ($keys[0],$keys[-1], map {$table{$_}||0} ($keys[0] ... $keys[-1]));
}

sub fudge_roll_distribution
{
	my ($number, $die) = @_;
	my @table;

	@table = basic_roll_distribution($number,$die);
	$table[0] -= (int ($die/2) + 1)*$number;
	$table[1] -= (int ($die/2) + 1)*$number;
	
	return @table;
}
sub basic_roll_distribution
{
	my ($number, $die) = @_;
	my @table;

	$table[1] = [ (1) x ($die+1) ];
	my $current = 1;
	my ($one,$two,$next,$increment);
	while ($current < $number)
	{
		if (($current+$current)<=$number)
		{
			$one = $current;
			$two = $current;
			$current = $current+$current;
		}
		else
		{
			$increment = $current unless $increment;
			$increment/=2 while ($current+$increment)>$number;
			$one = $increment;
			$two = $current;
			$current += $increment;;
		}
		for my $f ($one ... $one*$die)
		{
			for my $s ( $two ... $two*$die)
			{
				$table[$current][$f+$s]
					+= $table[$one][$f]*$table[$two][$s];
			}
		}
	}
	return ($number, $number*$die, @{$table[$number]}[$number ... $number*$die]);
}