3d6 # simplest one 3d6+3 # with a result modifier 3d8r1 # reroll and discard any 1 3d8rlt3 # reroll and discard any lesser than 3 3d8rgt6 # reroll and discard any greater than 6 3d8rgt6+2 # reroll and discard any greater than 6 and add +2 to the final result 4d6x1 # explode (a new roll is done) each 1 rolled 4d6xlt3 # explode lesser than 3 4d6xgt4 # explode greater than 4 4d12kh3 # keep highest 3 rolls 4d12kl3 # keep lowest 3 rolls 4d12dh3 # drop highest 3 rolls 4d12dl3 # drop lowest 3 rolls 4d20kh3+7 # keep hishets 3 rolls then add 7 ##
##

use strict;
use warnings;

use Marpa::R2;
use Data::Dump;

my $dsl = <<'END_OF_DSL';

:default ::= action => ::first
lexeme default = latm => 1

Expression ::= Dice_Expression
             | Dice_Expression result_add_modifier
			 | Dice_Expression result_keep_drop
			 | Dice_Expression result_keep_drop result_add_modifier
			 
			 
Dice_Expression ::= Simple_Dice
                  | Simple_Dice x_modifier
                  | Simple_Dice r_modifier
				  
				 

Simple_Dice  ::= Rolls 'd' Sides                         action => simple_roll

result_add_modifier ::= '+' Die_Modifier_Val             action => modifier_add
                      | '-' Die_Modifier_Val             action => modifier_add
					  
result_keep_drop ::= keep_type keep_val 			     action => result_keep_drop

                   
keep_type ::= 'kh' | 'kl' | 'dh' | 'dl'
keep_val ~ digits
				   

x_modifier   ::= 'x' Die_Modifier_Val                    action => modifier_x
			   | 'x' Die_Modifier_Comp Die_Modifier_Val  action => modifier_x_comp

r_modifier   ::= 'r' Die_Modifier_Val                    action => modifier_r
               | 'r' Die_Modifier_Comp Die_Modifier_Val  action => modifier_r_comp


Die_Modifier_Val ~ digits
Die_Modifier_Comp ~ 'gt' | 'lt'

Rolls ~ digits
Sides ~ digits

digits ~ [\d]+

:discard ~ whitespace
whitespace ~ [\s]+
END_OF_DSL

my $grammar = Marpa::R2::Scanless::G->new( { source => \$dsl } );
my $input = $ARGV[0] // '6d4x1';
my $parsed = $grammar->parse( \$input, 'My_Actions' );
print "\nMarpa Parsed result: ";dd $parsed;

print "FINAL STEP: "; 

my ( $res, $descr, $self ) = compute_result($$parsed);

print "\n\nRESULT       : $res\nDESCRIPTION  : $descr\nINTERNAL FORM:\n"; dd $self;

#################################
# SUBS UNRELETED TO MARPA GRAMMAR
#################################
sub  compute_result {
	print "compute_result received: "; dd @_;
	my $self = shift;
	my @descr;
	### DIE MODIFIERS
	# REROLL
	if ( defined $$self{die_modifier_type} and $$self{die_modifier_type} eq 'reroll'){
		my @good;
		foreach my $val ( @{$$self{partial}} ){
			print "\tVAL: $val\n";
			if (
					( $$self{die_modifier_comp} eq 'eq' and $val == $$self{ die_modifier_val } ) or
					( $$self{die_modifier_comp} eq 'gt' and $val > $$self{ die_modifier_val } )  or
					( $$self{die_modifier_comp} eq 'lt' and $val < $$self{ die_modifier_val } ) 
			){
				print "\t  REROLL..\n";
				push @descr, "($val"."r)";
				push @{$$self{partial}}, single_die( $$self{sides} );
			}
			else{
				push @good, $val;
				push @descr, $val;
			}		
		}
		print "TEMP REROLL DESCR: "; dd @descr;
		print "TEMP REROLL RES  : "; dd @good;
		@{$$self{partial}} = @good;
		@{$$self{descr}} = @descr;
	}
	# EXPLODE
	if ( defined $$self{die_modifier_type} and $$self{die_modifier_type} eq 'explode'){
		
		foreach my $val ( @{$$self{partial}} ){
			print "\tVAL: $val\n";
			if (
					( $$self{die_modifier_comp} eq 'eq' and $val == $$self{ die_modifier_val } ) or
					( $$self{die_modifier_comp} eq 'gt' and $val > $$self{ die_modifier_val } )  or
					( $$self{die_modifier_comp} eq 'lt' and $val < $$self{ die_modifier_val } ) 
			){
				print "\t  EXPLODE..\n";
				push @descr, $val."x";
				push @{$$self{partial}}, single_die( $$self{sides} );
			}
			else{
				push @descr, $val;
			}
		
		}
		print "TEMP EXPLODE DESCR: "; dd @descr;
		print "TEMP EXPLODE RES  : "; dd @{$$self{partial}};
		@{$$self{descr}} = @descr;
	}
	### RESULT MODIFIERS
	# KEEP AND DROP
    if ( $$self{keep_type} ){
		# 1 2 3 4
		@{$$self{partial}} = sort { $a <=> $b } @{$$self{partial}};
		# 4 3 2 1
		@{$$self{partial}} = reverse @{$$self{partial}} if $$self{keep_type} =~ /^[kd]h$/;
		my @keep;
		my @drop;
		# keep 
		if ( $$self{keep_type} =~ /^(?:kh|kl)$/ ){
			push @keep, shift @{$$self{partial}} for 1..$$self{keep_val};
			@drop = @{$$self{partial}};
		}
		# drop
		else{
			push @drop, shift @{$$self{partial}} for 1..$$self{keep_val};
			@keep = @{$$self{partial}};
			 
		}
		
		print "\tkeep: "; dd @keep; 
		print "\tdrop: "; dd @drop;
				
		$$self{result} += $_ for @keep;
		@{$$self{descr}} = ( @keep, map{"($_)"}@drop );		
	}
    # NORMAL RESULT (no keep nor drop)
	else{
		$$self{result} += $_ for @{$$self{partial}};
		
		# if descr still not set use partial
		unless ( $$self{descr} ){
			@{$$self{descr}} = @{$$self{partial}};
		}
	}
	# SUM TO THE GLOBAL RESULT
	if ( defined $$self{add} ){
		$$self{result} += $$self{add};
		push @{$$self{descr}},( $$self{add} > 0 ? '+' : '' ).$$self{add};	
	}
	# CLEAN 
	delete $$self{partial};
		
	# RETURN
	# only here stringify description
	$$self{descr} = join ' ',@{$$self{descr}};
	return $$self{result}, $$self{descr}, $self;
}

sub single_die {
    my $sides = shift;
    return 1+int(rand($sides));
}

#################################
# SUBS OF THE MARPA GRAMMAR
#################################

# keep and drop 
sub My_Actions::result_keep_drop {
	print "result_keep_drop received: "; dd @_;
    my ( $self, $type, $val ) = @_;
    $$self{keep_type} = $type;
	$$self{keep_val} = $val;
	
    return $self;
}
# add
sub My_Actions::modifier_add {
	print "modifier_add received: "; dd @_;
    my ( $self, $sign, $val ) = @_;
    $$self{add} = 0 + "$sign$val";
    $self;
}
# reroll
sub My_Actions::modifier_r {
	print "modifier_r received: "; dd @_;
    my ( $self, undef, $reroll ) = @_;
    $$self{die_modifier_type} = 'reroll';
    $$self{die_modifier_comp} = 'eq';
	$$self{die_modifier_val} = $reroll;
    return $self;
}
# reroll comp
sub My_Actions::modifier_r_comp {
	print "modifier_r_comp received: "; dd @_;
    my ( $self, undef, $comp, $reroll ) = @_;
    $$self{die_modifier_type} = 'reroll';
    $$self{die_modifier_comp} = $comp;
	$$self{die_modifier_val} = $reroll;
    return $self;
}
# explode
sub My_Actions::modifier_x {
	print "modifier_x received: "; dd @_;
    my ( $self, undef, $explode ) = @_;
    $$self{die_modifier_type} = 'explode';
    $$self{die_modifier_comp} = 'eq';
	$$self{die_modifier_val} = $explode;
    return $self;
}
# explode comp
sub My_Actions::modifier_x_comp {
	print "modifier_x_comp received: "; dd @_;
    my ( $self, undef, $comp, $explode ) = @_;
    $$self{die_modifier_type} = 'explode';
    $$self{die_modifier_comp} = $comp;
	$$self{die_modifier_val} = $explode;
    return $self;
}
# simple roll
sub My_Actions::simple_roll {
	print "simple_roll received: "; dd @_;
    my ( $self, $rolls, undef, $sides ) = @_;
    $$self{rolls} = $rolls;
    $$self{sides} = $sides;
	
	push @{$$self{partial}}, single_die($sides) for 1..$rolls;
    
    return $self;
}