view release on metacpan or  search on metacpan

lib/Acme/Dice.pm  view on Meta::CPAN

package Acme::Dice;

use 5.008008;
use strict;
use warnings;

use Carp;
use Data::Dumper;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT_OK);
    @ISA = qw(Exporter);

    @EXPORT_OK = qw( roll_dice roll_craps );
}

$Acme::Dice::VERSION = '1.01';

my $defaults = {
    dice  => 1,
    sides => 6,
    favor => 0,
    bias  => 20,
};

sub roll_dice {
    my $raw_args = @_ == 1 ? shift : {@_};

    # no need to check params if coming from roll_craps
    my $args =
      delete( $raw_args->{skip_validate} )
      ? $raw_args
      : _validate_params($raw_args);

    my @rolls;
    my $roll_total = 0;
    for ( 1 .. $args->{dice} ) {
        my $roll = ( int( rand( $args->{sides} ) ) + 1 );
        _apply_bias( \$roll, $args ) if $args->{favor} && $args->{bias};
        push( @rolls, $roll );
        $roll_total += $roll;
    }

    return wantarray ? @rolls : $roll_total;
}

sub roll_craps {
    my $raw_args = @_ == 1 ? shift : {@_};

    croak "param present but undefined: bias"
      if exists( $raw_args->{bias} ) && !defined( $raw_args->{bias} );

    my $bias = delete( $raw_args->{bias} ) || 0;

    croak "Illegal value for 'bias': $bias" if $bias < 0 || $bias > 100;
    croak 'RTFM! Unknown params: ' . join( ', ', keys( %{$raw_args} ) )
      if keys( %{$raw_args} );

    # hey, this is Acme, remember? you were TOLD not to look inside!
    return ( wantarray ? ( 3, 4 ) : 7 ) if rand(100) < 5;

    my @rolls;
    push(
        @rolls,
        roll_dice(
            skip_validate => 1,
            dice          => 1,
            sides         => 6,
            favor         => 3,
            bias          => $bias
        )
    );
    push(
        @rolls,
        roll_dice(
            skip_validate => 1,
            dice          => 1,
            sides         => 6,
            favor         => 4,
            bias          => $bias
        )
    );

    return wantarray ? @rolls : $rolls[0] + $rolls[1];
}

sub _validate_params {
    my $raw_args = @_ == 1 ? shift : {@_};

    my $args = {};
    my @errors;

    # put put defaults in place for missing params
    # and detect incoming undefined params
    for ( keys( %{$defaults} ) ) {
        $raw_args->{$_} = $defaults->{$_} if !exists( $raw_args->{$_} );
        push( @errors, "param present but undefined: $_" )
          unless defined $raw_args->{$_};
        $args->{$_} = delete( $raw_args->{$_} );
        push( @errors, "$_ must be a non-negative integer: $args->{$_}" )
          if defined( $args->{$_} ) && $args->{$_} !~ m/^\d+$/;
    }
    push( @errors,
        'RTFM! Unknown params: ' . join( ', ', keys( %{$raw_args} ) ) )
      if keys( %{$raw_args} );

    croak join( "\n", @errors ) if @errors;

    # validate individual params now
    push( @errors, "Illegal value for 'dice': $args->{dice}" )
      if $args->{dice} < 1;
    push( @errors, "Really? Roll $args->{dice} dice?" ) if $args->{dice} > 100;

    push( @errors, "Illegal value for 'sides': $args->{sides}" )
      if $args->{sides} < 1;

    push( @errors, "Illegal value for 'favor': $args->{favor}" )
      if $args->{favor} < 0 || $args->{favor} > $args->{sides};
    push( @errors, "Illegal value for 'bias': $args->{bias}" )
      if $args->{bias} < 0 || $args->{bias} > 100;

    croak join( "\n", @errors ) if @errors;

    return $args;
}

sub _apply_bias {
    my $roll_src = shift;
    my $args     = shift;

    ${$roll_src} = $args->{favor}
      if ${$roll_src} != $args->{favor} && rand(100) < $args->{bias};

    return;
}

1;
__END__

=head1 NAME

Acme::Dice - The finest in croo ..., uhhh, precision dice!

=head1 SYNOPSIS

 use Acme::Dice qw(roll_dice roll_craps);
   
 my $total = roll_dice( dice => 3, sides => 6, favor => 6, bias => 30 );
 my @dice = roll_dice( dice => 3, sides => 6, favor => 6, bias => 30 );
   
 my $craps_roll = roll_craps( bias => 30 );
 my @craps_dice = roll_craps( bias => 30 );

=head1 DESCRIPTION

Acme knows that sometimes one needs more flexibility in one's rolls than
using normal dice normally allows. Here at last is a package that gives one