Hello folks!
I recently asked for your wisdom in First steps with Marpa::R2 and BNF and I got nice answers. I'm playing with dice in these days as you can see in the post is rand random enough to simulate dice rolls?. The module I finally crafted as toy project is Games::Dice::Roller (with its gitlab repository).
But I had a sudden desire to reimplement the whole in Marpa::R2 and evolvig duelafn's example and following precious GrandFather's suggestions I ended with the following working code.
I left in it a lot of debug messages in case someone comes here to look for Marpa::R2 examples.
It actually mimicry the beahaviour of my Games::Dice::Roller for input received (it still does not accept multistring arguments like 3d6 4d4+1 12 kh as the module does) and it outputs in the same way 3 elements: the result, a descriptive string and the internal datastructure.
The following code is different from Games::Dice::Roller because it has less constraints in received inputs: for example it accepts something like 6d4r1kh3+3 and computes also a correct result, but messing the description. My mudule would reject an input like this.
Possible inputs given as argument of the program:
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 f
+inal 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
Alea iacta est!
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;
}
L*
There are no rules, there are no thumbs..
Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
