#!/usr/bin/perl -w

use strict;

my $verbose=1;
my $indent=0;

my @tests = (
   ['3d6', 'Returns a value 3 to 18'],
   ['(1d4)d20','Rolls a 20 sided die 1 to 4 times and sums the results
+'],
   ['6@[3d6]','Returns 6 values of 3 to 18 in a list'],
   ['6>12@[3d6]','Returns the best 6 of 12 3d6\'s in a list'],
   ['6@[&3>4@[(1d5)+1]]','Equivelant to the ol\' "Roll 6 stats -- 4d6,
+ re-roll 1\'s, drop the lowest die."'],
);

foreach my $part (@tests) {
   $indent = 0;
   my ($test,$text) = @$part;
   print "$test : $text\n";
   print 'RESULT: ' . determine($test) . "\n";
   print '-' x 80;
   print "\n\n";
}

sub determine {
   my $term = shift;
   
   print indent(0,+3) . "Determining '$term'.\n" if $verbose;
   
   # Loop until all calcs are done or we're 100 deep.
   my $loop = 0;
   while (($term=~/[\@<>\(d\*\/\+\-&]/) && ($loop < 100)) {

      # Precedence 5: '@'
      #$term=~s/(\d+)@\[([^\[\]]+)\]/rpt($1,$2)/eg;
      $term=~s/(\d+)@\[(.*)\]/rpt($1,$2)/eg;

      # Precedence 6: '<,>'
      $term=~s/(\d+)([<>])\{([^\{\}]+)\}/gtlt($1,$2,$3)/eg;

      # Precedence 7: '&';
      $term=~s/\&\{([^\{\}]+)\}/sum($1)/eg;
   
      # Precedence 1: Parenthesis
      $term=~s/\(([^\(\)]+)\)/determine($1)/eg;

      # Precedence 2: 'd'
      $term=~s/(\d+)d(\d+)/roll($1,$2)/eg;
      
      # Precedence 3: '*,/'
      $term=~s/(\d+)\*(\d+)/($1*$2)/eg;
      $term=~s|(\d+)/(\d+)|($1/$2)|eg;
      
      # Precedence 4: '+,-'
      $term=~s/(\d+)\+(\d+)/($1+$2)/eg;
      $term=~s/(\d+)\-(\d+)/($1-$2)/eg;

   }     

   print indent(-3,0) . "Got $term.\n" if $verbose;

   return $term;
}

sub rpt {
   my ($repeat,$term) = @_;
   print indent(0,+3) . "Running '$term' $repeat times.\n" if $verbose
+ >= 2;
   my $result='{';
   for (1 .. $repeat) {
      my $oneresult = determine($term);
      $result .= $oneresult . ', ';
   }
   $result =~s/,\s*$/}/;
   print indent(-3,0) . "Returning $result.\n" if $verbose >= 2;
   return $result;
}

sub gtlt {
   my ($items,$sign,$list) = @_;
   my $result;
   if ($sign eq '<') {
      print indent(0,+3) . "Finding lowest $items items in {$list}.\n"
+ if $verbose >= 2;
      my @list = split(/,\s*/,$list);
      print indent(0,0) . "Split: @list\n" if $verbose >= 4;
      @list = sort {$a <=> $b} @list;
      print indent(0,0) . "Sort: @list\n" if $verbose >= 4;
      @list = @list[0..($items-1)];
      print indent(0,0) . "Sub: @list\n" if $verbose >= 4;
      $result = '{' . join(', ', @list) . '}';
   }
   elsif ($sign eq '>') {
      print indent(0,+3) . "Finding highest $items items in {$list}.\n
+" if $verbose >= 2;
      my @list = split(/,\s*/,$list);
      print indent(0,0) . "Split: @list\n" if $verbose >= 4;
      @list = reverse sort {$a <=> $b} @list;
      print indent(0,0) . "Sort: @list\n" if $verbose >= 4;
      @list = @list[0..($items-1)];
      print indent(0,0) . "Sub: @list\n" if $verbose >= 4;
      $result = '{' . join(', ', @list) . '}';
   }
   print indent(-3,0) . "Returning $result.\n" if $verbose >= 2;
   return $result;
}

sub sum {
   my $list = shift;
   print indent(0,+3) . "Summing {$list}.\n" if $verbose >= 2;
   my @list = split(/,\s*/,$list);
   my $result;
   foreach my $item (@list) {
      $result += $item;
   }
   print indent(-3,0) . "Returning $result.\n" if $verbose >= 2;
   return $result;
}

sub roll {
   my ($repeat,$sides) = @_;
   print indent(0,+3) . "Rolling a $sides sided dice $repeat times and
+ summing the results.\n" if $verbose;
   my $result;
   for (1 .. $repeat) {
      my $roll = int(rand($sides)+1);
      print indent(0,0) . "Got a $roll.\n" if $verbose >= 2;
      $result += $roll;
   }
   print indent(-3,0) . "Returning $result.\n" if $verbose;
   return $result;
}

sub indent {
   my ($pre,$post) = @_;
   $indent += $pre;  
   my $result = ' ' x $indent;
   $indent += $post; 
   return $result; #" [$indent] ";
}
[download]