package dice;
#
# Copyright 2003 Steven Swenson  
# License is granted to use or create derivitive works
# without royalty for personal, academic, or 
# other non-profit use.
#
# Government use is restricted to the Federal, State, and 
# Territory Governments of the United States of America.
#
# Contact the author for commercial use.

use strict;
use warnings;

BEGIN {
    use Exporter   ();
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
    
    # set the version for version checking
    $VERSION     = 1.00;

    @ISA         = qw(Exporter);
    @EXPORT      = qw(&rolldice);
    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
    # your exported package globals go here,
    # as well as any optionally exported functions
    @EXPORT_OK   = qw();
}
    
    
=head1 Routines

=cut

=head2 rolldice() 

This routine rolls dice.  It takes a $scalar parameter that specifies 
+how many dice, what type of dice,
how many dice should be totalled, and whether any should be re-rolled.


example  print "\nRolling 4d6r2->".I<rolldice("4d6r2")>."\n";

=over 4

=item *

n1_d_n2  n1 = Dice, n2 = Sides of Die  --  3d6 (roll 3 6 sided dice)

=cut

=item *

k_n      n = # Dice kept (highest rolling dice); --  4d6k3 ( roll 4 6s
+ided dice keep total of 3 highest)

=cut 

=item *

l n     n = # lowest rolling dice kept  -- 4d6l3 ( roll 4 6sided dice 
+keep total of 3 lowest)

=cut

=item *

r_n      n = If a result is less than or equal to n it is rerolled, re
+placing the low roll. 4d6k3r2 -- Keep 3 highest 6 sided dice, reroll 
+any 1's or 2's

=cut

=item *

x_n      n = If a result is greater than or equal to n it is rerolled,
+ an added to the total. 4d6k3x5 -- Keep 3 highest 6 sided dice, rerol
+l any 5's or 6's

=cut

=item *

+ add a constant to the result    3d6+4  Total 3 6 sided dice, add 4 t
+o result

=item *

- subtract a constant from the result  3d6-4  Total 3 6 sided dice, ad
+d 4 to result

=back

=cut

=cut

=cut

#Sort Routines

sub highest { $b <=> $a }
sub lowest  { $a <=> $b }

#--------
    
sub rolldice ($) {

    my $I                           = 0;
    my ( $total,$highest,$lowest )  = 0;
    my $parameter                   = shift;
    my $n_dice                      = 0;
    my $n_sides                     = 0;
    my $n_rolls                     = 0;
    my $rerolls                     = 0;
    my @rolls                       = ();
    my $constant                    = 0;
    my $rolladd                     = 0;

    # Read the Command String with regex 
    die "No roll command passed to rolldice \n" unless ( $parameter );
    #print "Recieved '$parameter' to roll\n";
    $_ = $parameter;
    $parameter =~ /^([0-9]+)d([0-9]+)/;

    $n_dice     = $1;
    $n_sides    = $2;

    if ($parameter =~ /k([0-9]+)/) { 
        $highest = $1;
    }

    if ($parameter =~ /l([0-9]+)/) { 
        $lowest = $1;
    }

    if ($parameter =~ /r([0-9]+)/) { 
        $rerolls = $1;
    }

    if ($parameter =~ /x([0-9]+)/) { 
        $rolladd = $1;
    }

    if ($parameter =~ /\+([0-9]+)/) { 
        $constant = $1;
    }

    if ($parameter =~ /\-([0-9]+)/) { 
        $constant -= $1;
    }

    # End Commands

    # Roll the dice Put into a list
    for (my $I=1; $I <= $n_dice; $I++){ 

        $rolls [$I-1] = int(rand($n_sides))+1;

        while ( ($rolls [$I-1] ) <= $rerolls){
            #print "rolled a $rolls[$I-1] -- re-rolling\n";
            $rolls [$I-1] = int(rand($n_sides))+1;
        }

        while ((  ( $rolls [$I-1] )>= $rolladd ) && ($rolladd) ){
            print "rolled a $rolls[$I-1] -- re-rolling and adding to t
+otal\n";
            $total += $rolls[$I-1];
            $rolls [$I-1] = int(rand($n_sides))+1;
        }

    }

    # Keep Highest only
    if ( $highest ){
        @rolls = sort highest @rolls;
        $n_dice = $highest;
    } 

    # Keep Lowest only
    if ( $lowest ){
        @rolls = sort lowest @rolls;
        $n_dice = $lowest;
    } 

    # Total the dice rolled 
    for ($I=0;$I <= ($n_dice-1); $I++){
        $total += $rolls [$I];
    }
    $total += $constant;
}

    
  
    
    
END { }       # module clean-up code here (global destructor)


1;
[download]