# fancydice.pm

=pod

=head1 NAME

fancydice - scriptable dice

=head1 SYNOPSIS

roll dice defined by a specialty scripting language.  Extended syntax version.

=head1 USAGE

	use fancydice;
	my $macros = {'d' => '@[1_>]' };
	@roll = &fancydice::roll("3d6", $macros);
	# @roll contains 3 random #s in 1..6
	$total = &fancydice::sum @roll;

=cut

=head1 INSTALATION

	perl Makefile.PL
	make
	make install

Or simply copy the MPI.pm file to Language/ under the perl
modules directory.  README and the man file for this package
exist as pod data in MPI.pm.

=head1 Etc

This code developed using perl 5.8.8.  Might work with perl
5.6.0 or older with proper libraries.  Uses strict and warning.

Copyright (c)2008, 2015 Peter Hanely. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 LANGUAGE

dice spec examples
    3d6            Roll 3 6-sided dice
    1f20+12        Roll 1 20-sided die with houserules -10/+10, and add 12
    ["a","b","c"]  select one of the listed strings
The dice spec cannot have spaces in it.  You can roll multiple specs
at once by separating them with spaces.
The spec consists of the following tokens:
   {number}     A literal number
                Example: 13
   {string}	Text enclosed in quotes
		A string retains independent identity across adds, not
		supported for -, *, and /
		Example: "**"
   {alpha}      A word containing only letters
                is a macro, which can be a full or partial
                dice spec.  Use #define to create macros.
                Example: fire
                Resolves to: 1d4+1
   (spec)       A spec inside parenthesis will be evaluated to a single
                number before other tokens are evaluated.
                Example: (1,2)
                Resolves to: 3
   _            This will evaluate to a list of numbers, from the
                preceding to the following, inclusive.
                Example: 1_5
                Resolves to: 1,2,3,4,5
   [spec]       A token will be chosen at random from within this spec.
                Example: [1,2,3]
                Resolves to: one of: 1, 2, 3
   @            Repeats the following token a number of times equal to
		the previous token.  following token should be {number}
		(spec) or [spec].
                Example: 1@5
                Resolves to: 5,5,5
   + -          These only effect the sign of the following number.
                Examples1:   +3   Example2: -5
                Resolves to:  3             -5
   * /          These perform multiplication and division.
                Example1:    6*2  Example2: 9/3
                Resolves to:  12             3
   >            This may only be used in macros, and lets the
                macro pull in the following token.
                Example: The macro 'd' is defined as '@[1_>]'
			so 3d8 resolves to 3@[1_8], which resolves to
			[1_8][1_8][1_8] which might resolve to 3,7,4.
   Other	Any other symbol is discarded,  but serves to
		separate tokens
		Example: 3,2      The comma is discarded,
		Resolves as: 3,2  but prevents it from resolving as 32.
=cut

use strict;
use warnings;
# warning good for debug, but produce noise from good code
no warnings qw(uninitialized);
#use Carp;

package fancydice;

our ($VERSION, @ISA, @EXPORT_OK, $perl_list);
#use vars qw($VERSION, @ISA, @EXPORT_OK, $perl_list);

BEGIN
{
  require Exporter;
  our ($VERSION, @ISA, @EXPORT_OK);

  @ISA = qw(Exporter);
  @EXPORT_OK = qw(roll sum selection);
  
  $VERSION = "2008.0401";
}

  our ($debug);
  $debug = 0;

sub sum
{
  my ($sum, $val, @strings);
  #$sum = 0;
#  print join(',',@_),"\n";
  while (scalar(@_))
  {
    $val = shift;
    #print "$val\n";
    if ($val =~ /[^\d]/)
    { push @strings, $val;    }
    else
    { $sum += $val; }
  }
  if (@strings)
  {  return $sum.' '.join(' ', @strings);	}
  1*$sum;
}

sub selection
{
  my @list = @_;
  print join(',', @list),"\n" if $fancydice::debug;

  $list[rand(scalar(@list))];
}

sub parsetoken
{
  my ($roll, $macros) = @_;
  my ($token, @roll, $list);

  print "parse $roll\n" if $fancydice::debug;

  if ($roll =~ /^(\d+)(.*)/) # number
  { 
    #print "number\n" if $fancydice::debug;
    return ($1, $2, '#');
  }

  if ($roll =~ /^"([^"]*)"(.*)/) # string
  { return ($1, $2, '"'); }
  if ($roll =~ /^([a-zA-Z]+)(.*)/ ) # macro
  { return ($1, $2, 'm'); }

  if ($roll =~ /^([\_\@\-\*\/])(.*)/ ) # _, @, -, *, /
  { return ($1, $2, $1); }

  if ($roll =~ /^(\()(.*)/ ) # sum of...
  {
    ($list, $roll) = &parse($2, $macros, []);
    $token = &sum(@$list);
    return ($token, $roll, '#');
  }

  if ($roll =~ /^(\[)(.*)/ ) # selection of...
  {
    ($list, $roll) = &parse($2, $macros, []);
    $token = &selection(@$list);
    print "selected $token\n" if $fancydice::debug;
    if ($token =~ /[^\d]/)
    {	return ($token, $roll, '"');	}
    else
    {	return ($token, $roll, '#');	}
  }

  #print "named op? $roll\n";
  if (($roll =~ /^\#(\w+)(.*)/ )) # named operation
  {
    return ($1, $2, 'named');
  }
  
  if (($roll =~ /^([\]\)])(.*)/ ) || ($roll eq ''))# end tags
  { return ($1, $2, ']'); }

# else
  $roll =~ /(.)(.*)/;
  return ($1, $2, $1);
}

sub parse
{
  my ($roll, $macros, $rolll, $ops) = @_;
  my ($token, $sign, $macro, $next, $endtoken, $i);
  my ($type, $ntype, $last, $list);
  #$roll = lc $roll;
  $sign = 1;

  while ((defined $roll) && (!$endtoken))
  {
    ($token, $roll, $type) = &parsetoken($roll, $macros);
print (join (',', @$rolll), ": $token, $roll, $type\n") if $fancydice::debug;

    if ($type eq '#')
    {
      push @$rolll, $sign*$token;
      $sign = 1;
    }
    if ($type eq '"')
    {
      push @$rolll, $token;
      $sign = 1;
    }

    if ($type eq 'm')
    {
      #$token = lc $token;
      $macro = $$macros{lc $token};
      #print "macro $token $macro\n";     
      if ($macro =~ />/)
      {
        ($token, $roll) = &parsetoken($roll, $macros);
	$macro =~ s/>/$token/g;
      }
      ($list) = &parse($macro, $macros, $rolll);
      #push @$rolll, @$list;
    }

    if ($type eq 'named')
    {
      my $named = $ops->{lc $token};
      #print "$named\n";
      if ($named)
      {
        #print "named op $token\n";
        &$named($rolll);
      }
    }

    if ($type eq '_')
    {
      ($token, $roll) = &parsetoken($roll, $macros);
      $last = pop @$rolll;
      #if ($last <= 0) { $last = 1; }
      if ($token !~ /\d/) { $token = 0; }
      if ($last > $token)
      { $i = $last; $last = $token; $token = $i; }
      for ($i = $last; $i <= $token; $i++)
      { push @$rolll, $i; }
    }

    if ($type eq '@')
    {
      $last = (pop @$rolll) || 1;
      print "$roll\n" if $fancydice::debug;
      for ($i = 0; $i < $last; $i++)
      {
        ($token, $next, $ntype) = &parsetoken($roll, $macros);
	#&addtoken(\@roll, $token, $ntype, $sign);
	print "token $token $ntype\n" if $fancydice::debug;
	if ($ntype eq '#')
	{	push @$rolll, $token*$sign;	}
	else
	{	push @$rolll, $token;	}
print (join (',', @$rolll), ": @\n") if $fancydice::debug;
      }
      $sign = 1;
      $roll = $next;
    }

    if ($type eq '-')
    { $sign = -1; }

    if ($type eq '*')
    {
      $last = pop @$rolll;
      ($token, $roll, $ntype) = &parsetoken($roll, $macros);
      push @$rolll, $last*$token;
    }

    if ($type eq '/')
    { $last = pop @$rolll;
      ($token, $roll, $ntype) = &parsetoken($roll, $macros);
      push @$rolll, int($last/$token);
    }
    
    if ($type eq ']')
    { $endtoken = 1; }

  }
  ($rolll, $roll);
}

sub roll
{
  my ($roll, $macros, $ops) = @_;
  my ($list) = &parse($roll, $macros, [], $ops);
  @$list;
}

1;
