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 => sim
+ple_roll
result_add_modifier ::= '+' Die_Modifier_Val action => mod
+ifier_add
| '-' Die_Modifier_Val action => mod
+ifier_add
result_keep_drop ::= keep_type keep_val action => res
+ult_keep_drop
keep_type ::= 'kh' | 'kl' | 'dh' | 'dl'
keep_val ~ digits
x_modifier ::= 'x' Die_Modifier_Val action => mod
+ifier_x
| 'x' Die_Modifier_Comp Die_Modifier_Val action => mod
+ifier_x_comp
r_modifier ::= 'r' Die_Modifier_Val action => mod
+ifier_r
| 'r' Die_Modifier_Comp Die_Modifier_Val action => mod
+ifier_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_typ
+e} 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 > $$s
+elf{ die_modifier_val } ) or
( $$self{die_modifier_comp} eq 'lt' and $val < $$s
+elf{ 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_typ
+e} 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 > $$s
+elf{ die_modifier_val } ) or
( $$self{die_modifier_comp} eq 'lt' and $val < $$s
+elf{ 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_va
+l};
@drop = @{$$self{partial}};
}
# drop
else{
push @drop, shift @{$$self{partial}} for 1..$$self{keep_va
+l};
@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{ad
+d};
}
# 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;
}
