Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
 
PerlMonks  

A dice roller system with Marpa::R2

by Discipulus (Abbot)
on Jan 16, 2021 at 14:49 UTC ( #11126997=CUFP: print w/replies, xml ) Need Help??

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.

Replies are listed 'Best First'.
Re: A dice roller system with Marpa::R2
by kcott (Bishop) on Jan 16, 2021 at 16:01 UTC

    G'day Discipulus,

    As you'd be aware, I was following this since the "Is rand() enough?" question; and talked about my own dice rolling code. This has progressed to a very feature-rich module: well done.

    I noticed in Games::Dice::Roller that you have made reference to rt.cpan.org in both the BUGS and SUPPORT sections. You may want to change that: see "rt.cpan to close, 01/03/2021" for the reason why.

    I also installed this without any problems at all. You should get the first green bar in the "cygwin" column of "CPAN Testers Matrix: Games-Dice-Roller 0.03" when that next gets updated.

    — Ken

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://11126997]
Approved by Corion
Front-paged by marto
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (6)
As of 2021-02-25 08:33 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?