File Coverage

blib/lib/Games/Dice/Probability.pm

Criterion	Covered	Total	%
statement	92	127	72.4
branch	42	70	60.0
condition	5	13	38.4
subroutine	14	17	82.3
pod	0	10	0.0
total	153	237	64.5

package Games::Dice::Probability;

use 5.006;

# Be a Good Module
use strict;
use warnings;
#use diagnostics;

# Our version number.
our $VERSION = '0.02';

# Required Modules
#     Math::Sumbolic::AuxFunctions is for the calcs of binomial coefficients.
#
#     Parse::RecDescent parses the dice expressions.
use Math::Symbolic::AuxFunctions;
use Parse::RecDescent;

# Optional Modules
#     Debug::ShowStuff is used by $self->debug() to descend and display hashes
#     in the object.
#
#     Memoize is used by $self->new() to speed up calculations on individual
#     nodes in the expression tree.  If there are duplicate nodes, the second
#     and all subsequent calc_distribution calls with the same parameters will
#     just return the cached values.
#
#     Thanks to Mark Mills for the optional-module code snippet, and general
#     ideas, tips, and tricks for the whole module.  He's my local Perl
#     Monk...you can email him thanks and offers of cookies at:
#     extremely{plus}pm{at}hostile{dot}org
BEGIN {
    # Is Debug::ShowStuff available?
    if ( eval q/ require Debug::ShowStuff / ) {
	# If so, import the routines.
	Debug::ShowStuff->import("showref");
    } else {
	# Not available.  Place stub in its place.
	eval q/ sub showref { print @_; print "\n"; } /;
    }

    # Is Memoize available?
    if ( eval q/ require Memoize / ) {
	# If so, import the routines.
	Memoize->import();
    } else {
	# Not available.  Place stub in its place.
	eval q/ sub memoize { return; } /;
    }
}

# Binomial Coefficient Shortcut
#     Non-polluted namespaces are cool and all, but sometimes it's too much to
#     type a 44 character long subroutine name multiple times in a simple
#     equation.  Sheesh.
my $binco = \&Math::Symbolic::AuxFunctions::binomial_coeff;

# Recursive Parsing Grammar
#     Parsing grammar and tree code outright stolen from Sam Holden's
#     DiceDistribution.pm at http://sam.holden.id.au/junk/DICEDISTRIBUTION/.
#     Added a divide expression for division calculations.  Changed the way
#     Fudge Dice are expressed to be #d[fF] which is more inline with how
#     they are represented elsewhere.  Added mid# dice expression as part
#     of dicenode.
my $DiceGrammar = <<'END_GRAMMAR';
expression:	add_sub end  { $item[1] }
add_sub:	mult_div '+' add_sub { { left => $item[1], op => '+', right => $item[3] } }
add_sub:	mult_div '-' add_sub { { left => $item[1], op => '-', right => $item[3] } }
add_sub:	mult_div
mult_div:	bracket '/' mult_div { { left => $item[1], op => '/', right => $item[3] } }
mult_div:	bracket '*' mult_div { { left => $item[1], op => '*', right => $item[3] } }
mult_div:	bracket
bracket:	'(' add_sub ')' { $item[2] }
bracket:	dicenode
dicenode:	/(\d+|mi)d(\d+|f)/i
dicenode:	/\d+/
end:		/\s*$/
END_GRAMMAR

# Dice Parsing Object
my $DiceParser = Parse::RecDescent->new($DiceGrammar) || die("bad grammar");

# import()
#     Faux import function that either memoizes the calc portions of the
#     module (default) or doesn't.
sub import {
    # Default is to memoize.  Saving cycles is a Good Thing.  However, if
    # someone passes an unmemoize argument, then we will respect their wishes.
    if ( ! grep(/(un|no)memo(ize)*/i,@_) ) {
	# Attempt to memoize the calculation subroutines.  This will either
	# truly memoize, or the stub memoize function will simply return having
	# done nothing.
	memoize('calc_distribution');
	# Not certain if calc_combination will benefit from Memoize.  Need to
	# test further.
	memoize('calc_combination');
    }

    # All is well.  Return.
    return;
}

# debug()
#    Print debugging information about object.
sub debug {
    # The object of our attention.
    my $self = shift;

    # For every piece of the object...
    foreach my $key ( sort(keys(%$self)) ) {
	# Output the name...
	print "self->{$key}=";
	# And if it is a reference...
	if ( ref($self->{$key}) ) {
	    # Print the contents of the reference...
	    print "\n";
	    showref($self->{$key});
	} else {
	    # Or, print the value.
	    print $self->{$key} . "\n";
	}
    }

    # All is well.
    return(0);
}

# new(expression)
#     Creates a new object based on the provided dice expression.
sub new {
    my $invocant = shift;
    my $class = ref($invocant) || $invocant;
    my $self = {};

    die("must provide dice expression") unless (@_);

    if (@_ != 1) {
	die("new() called with too many arguments");
    } else {
	$self->{EXPRESSION} = $DiceParser->expression(@_) || die "could not parse expression";
	$self->{DISTRIBUTION} = travel($self->{EXPRESSION}) || die "could not travel parsed expression";
    }

    return(bless($self, $class));
}

# travel(expression)
#     Travel the parsed expression, returning hash of value => permutations.
sub travel {
    my $node = shift || die "invalid or missing expression node";

    if ( ref($node) ) {
	for ($node->{op}) {
	    /(\+)/ && return( calc_combination($1, travel($node->{left}), travel($node->{right})) );
	    /(\-)/ && return( calc_combination($1, travel($node->{left}), travel($node->{right})) );
	    /(\*)/ && return( calc_combination($1, travel($node->{left}), travel($node->{right})) );
	    /(\/)/ && return( calc_combination($1, travel($node->{left}), travel($node->{right})) );
	}
    }

    for ($node) {
	/^(\d+)(d)(\d+|f)/i && return( calc_distribution($2,$1,$3) );
	/^(mi)(d)(\d+|f)/i && return( calc_distribution("m",3,$3) );
	/^\d+$/ && return( {$node => 1} );
    }

    die("invalid token in expression.");
}

# calc_distribution(method,numdice,numsides)
#     Calculate distribution of values/permutations given: method, number of
#     dice, and number of sides per die.
sub calc_distribution {
    # The dice method requested.
    my $method = shift;
    # The number of dice.
    my $n = shift; $n += 0;
    # The number of sides/faces on each die.
    #     f/F = Fudge dice = d3.
    my $s = shift; $s += 0 unless $s =~ /f/i;
    # Loop value based on total/face.
    my $t1;
    # Hash to return containing the distribution.
    my %dist;

    # If dice node method is simple-sum nDs or nDf...
    if ( $method =~ /d/i ) {
	if ( $s =~ /f/i ) {
	    # If dice node method is fudge nDf...

	    # First, get the distribution for nDs...
	    my $tempdist = calc_distribution("d",$n,3);
	    # Then loop to build the new distribution from (-n..0)...
	    my $origkey = $n;
	    for ($t1=-1 * $n; $t1 <= 0; $t1++) {
		# Changing the original values in (n..ns) to (-n..n),
		# copy the original distribution to the new one with
		# the correct values...
		$dist{$t1} = $$tempdist{$origkey};
		$dist{$t1*-1} = $$tempdist{$origkey};
		$origkey++;
	    }
	} elsif ( $n eq 1 ) {
	    # Save compute cycles if only one die...

	    # Each face has a single chance...
	    for ($t1=1; $t1 <= $s; $t1++) {
		$dist{$t1} = 1;
	    }
	} else {
	    # Else compute number of combinations for a total on the face of n
	    # dice.

	    # Minimum and maximum sums.
	    my $tmin = $n;
	    my $tmax = $n*$s;
	    # Peak sum is the sum around which the bell-curve mirrors, saving
	    # compute time.
	    my $tpeak = ($tmin+$tmax)/2;

	    # For each total (t1) in $tmin..$tmax, calculate the number of
	    # combinations giving that total.
	    for ($t1=$tmin; $t1 <= $tpeak; $t1++) {
		# Total (t2) that is the mirror point in the bell curve.
		my $t2 = $tmin + $tmax - $t1;
		# Ceiling for the sum function.
		my $ceil = int( ($t1-$n) / $s );
		# Result.
		my $res = 0;
		# Loop control for the sum funtion.
		my $k;

		# Sum Function: For each k in 0 to $ceil...
		for ($k=0; $k <= $ceil; $k++) {
		    # Calculate and add to previous results.
		    $res += ((-1)**$k) * &$binco($n,$k) * &$binco(($t1-($s*$k)-1),($n-1));
		}

		# Set the mirrored points of the distribution.
		#     Note: $t1 and $t2 can be equal once at
		#     $t1=$tpeak when s is even.
		$dist{$t1} = $res;
		$dist{$t2} = $res;
	    }
	}
    } elsif ( $method =~ /m/i ) {
	# If dice method is take-the-middle-value nMs...

	# Minimum and maximum values.
	my $tmin = 1;
	my $tmax = $s;

	# For each value (t1) in $tmin..$tmax, calculate the number of
	# combinations giving t1 as the middle face value.
	for ($t1=$tmin; $t1 <= $tmax; $t1++) {
	    $dist{$t1} = 1 + ( 3 * ($s - 1) ) + ( 6 * ($t1 - 1) * ($s - $t1) );
	}
    }

    # Return the value=>combinations distribution hash for this node.
    return({%dist});
}

# calc_combination(operand,distribution1,distribution2)
#     Combine two distributions with the method provided.
sub calc_combination {
    # Calculation to perform on values.
    my $op = shift;
    # Distributions to combine.
    my $dist1 = shift;
    my $dist2 = shift;
    # The combined distribution.
    my %cdist;

    # For each value in the first distribution...
    foreach my $val1 ( sort {$a+0 <=> $b+0} keys(%$dist1) ) {
	# Combine it with every value in the second distribution...
	foreach my $val2 ( sort {$a+0 <=> $b+0} keys(%$dist2) ) {
	    # The new value of which is calculated based on combine method...
	    my $newval;
	    for ($op) {
		/\+/ && do { $newval = $val1 + $val2 };
		/\-/ && do { $newval = $val1 - $val2 };
		/\*/ && do { $newval = $val1 * $val2 };
		/\// && do { $newval = int($val1 / $val2) };
	    }
	    # Calculate the new combined combinations and set it to the new
	    # value in the new distribution.
	    $cdist{$newval} += $$dist1{$val1} * $$dist2{$val2};
	}
    }

    # Return the combined distribution.
    return({%cdist});
}

# combinations(targetvalue)
#     Calculate number of combinations for a target value.
sub combinations {
    my $self = shift;
    my $targetvalue = shift;

    $targetvalue = "ALL" unless defined($targetvalue);

    if ( ref($self) ) {
	if (@_ != 0) {
	    die("combinations() called incorrectly");
	} else {
	    if ( $targetvalue eq "ALL" ) {
		if ( $self->{COMBINATIONS} ) {
		    return ( $self->{COMBINATIONS} );
		} else {
		    foreach my $value ( values(%{$self->{DISTRIBUTION}}) ) {
			$self->{COMBINATIONS} += $value;
		    }
		    return($self->{COMBINATIONS});
		}
	    } else {
		return( $self->{DISTRIBUTION}->{$targetvalue} );
	    }
	}
    } else {
	die("combinations() called on non-object");
    }
}

# distribution()
#     Returns a hash containing the distribution in value=>combinations format.
sub distribution {
    my $self = shift;

    if ( ref($self) ) {
	if (@_ != 0) {
	    die("distribution() called with argument on object");
	} else {
	    return( $self->{DISTRIBUTION} );
	}
    } else {
	if (@_ != 0) {
	    my $expression = $DiceParser->expression(@_) || die "could not parse expression";
	    return( travel($expression) );
	} else {
	    die("no expression provided for non-object distribution() call");
	}
    }
}

# probability(targetvalue)
#     Returns the probability for targetvalue, or a hash of probabilities in
#     value=>probability format.
sub probability {
    my $self = shift;
    my $targetvalue = shift;

    $targetvalue = "ALL" unless defined($targetvalue);

    if ( ref($self) ) {
	if (@_ != 0) {
	    die("probability() called incorrectly");
	} else {
	    if ( ! exists($self->{PROBABILITIES}) ) {
		my $combs = $self->combinations();
		my %probs;
		foreach my $value ( keys(%{$self->{DISTRIBUTION}}) ) {
		    $probs{$value} = $self->{DISTRIBUTION}->{$value} / $combs;
		}
		$self->{PROBABILITIES} = {%probs};
	    }
	    if ( $targetvalue eq "ALL" ) {
		return( $self->{PROBABILITIES} );
	    } else {
		return( $self->{PROBABILITIES}->{$targetvalue} || undef );
	    }
	}
    } else {
	die("probability() called on non-object");
    }
}

# bounds()
#     Returns the min and max values of the valueset.
sub bounds {
    my $self = shift;

    if ( ref($self) ) {
	if (@_ != 0) {
	    die("bounds() called with argument on object");
	} else {
	    return( [ $self->min(), $self->max() ] );
	}
    } else {
	die("bounds() called on non-object");
    }
}

# max()
#     Returns the max value of the valueset.
sub max {
    my $self = shift;

    if ( ref($self) ) {
	if (@_ != 0) {
	    die("max() called with argument on object");
	} else {
	    if ( $self->{MAX} ) {
		return( $self->{MAX} );
	    } else {
		my @values = sort {$b+0 <=> $a+0} keys(%{$self->{DISTRIBUTION}});
		$self->{MAX} = shift(@values);
		return( $self->{MAX} );
	    }
	}
    } else {
	die("max() called on non-object");
    }
}

# min()
#     Returns the min value of the valueset.
sub min {
    my $self = shift;

    if ( ref($self) ) {
	if (@_ != 0) {
	    die("min() called with argument on object");
	} else {
	    if ( $self->{MIN} ) {
		return( $self->{MIN} );
	    } else {
		my @values = sort {$a+0 <=> $b+0} keys(%{$self->{DISTRIBUTION}});
		$self->{MIN} = shift(@values);
		return( $self->{MIN} );
	    }
	}
    } else {
	die("min() called on non-object");
    }
}

1;

__END__