Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

Discipulus:

I was bored, and you mentioned Marpa::R2, so I decided to whack something together for my own amusement. I thought I'd share it in case someone wanted another example of using Marpa.

#!env perl # # ex_marpa_bool_expr_truth_table.pl <FName> # # Parse a boolean expression and generate its truth table # use strict; use warnings; use Marpa::R2; ### # Fetch the expression to parse ### my $FName = shift; open my $FH, '<', $FName or die "$!"; my $input = trim(slurp($FH)); print "Expression to parse:\n$input\n\n"; ### # Parse the expression into a syntax tree, and display it as an AoA ### my $grammar_spec = slurp(\*DATA); my $grammar = Marpa::R2::Scanless::G->new( { source=>\$grammar_spec } +); my $value_ref = $grammar->parse( \$input, 'parseTree'); print "Parse tree:\n\n", ast_to_string($value_ref), "\n\n"; my %vars; walk_ast_tree(\%vars, $value_ref, sub { my ($context, $node, $phase) = @_; return if $phase ne 'BEFORE'; if ("ARRAY" eq ref $node and $node->[0] eq "variable") { ++$context->{$node->[1]}; } } ); my @varnames = sort keys %vars; print "Variables: ", join(", ", @varnames), "\n"; ### # Build the evaluator function for the expression. # # Essentially, we construct a function tree that mirrors the AST. ### my $tmp = []; walk_ast_tree($tmp, $value_ref, sub { my ($context, $node, $phase) = @_; # We process on 'AFTER' phase because we want to generate # the leaf functions before building their callers. return if $phase ne 'AFTER' or "ARRAY" ne ref $node; my $type= $node->[0]; if ("variable" eq $type) { push @$context, sub { # Fetch the specified variable return $vars{$node->[1]} } } elsif ("NOT" eq $type) { my $fn = pop @$context; push @$context, sub { # Invert the result. # NOTE: We use "0 +" to ensure that we get a # numeric value (o/w we sometimes get "") my $val = $fn->(); return 0 + !$fn->(); } } else { my $rhfn = pop @$context; my $lhfn = pop @$context; push @$context, sub { # Handle binary operator my $rhs = $rhfn->(); my $lhs = $lhfn->(); return $rhs & $lhs if $type eq "AND"; return $rhs | $lhs if $type eq "OR"; return $rhs ^ $lhs if $type eq "XOR"; die "Unexpected type $type!"; } } } ); my $fn_eval = $tmp->[-1]; ### # Draw truth table ### # We'll use the width of the largest variable name to generate # the format my $max_width = @{[sort map { length $_ } @varnames]}[-1]; my $fmtHdr = "%${max_width}s"; my $fmtVal = "%${max_width}u"; print "\nTRUTH TABLE\n\n"; print join(" ", map { sprintf $fmtHdr, $_ } @varnames), " : OUT\n"; for my $i ( 0 .. 2**(keys %vars)-1 ) { # Set the input variable values (map the bits in $i to variables) my $bit = 1; for my $var (reverse @varnames) { $vars{$var} = $bit & $i ? 1 : 0; $bit *= 2; } # Show the input values print join(" ", map { sprintf $fmtVal, $_ } @vars{@varnames}), " : + "; # Evaluate the function, and display the result print $fn_eval->(),"\n"; } #---------------------------------------------------------- # Utility functions #---------------------------------------------------------- # Walk the AST and invoke the users callback for each node. # $context - An arbitrary value you can provide as a scratchpad # value for your function. # $tree - The current node in the AST # $fn - Your callback function. The function will be # called like: # # foo($context, $tree, $phase) # # Your callback is invoked on each node BEFORE # processing the children as well as AFTER processing # the children. $phase will be set to 'BEFORE' or # 'AFTER' accordingly. # sub walk_ast_tree { my ($context, $tree, $fn) = @_; # Process the current node $fn->($context, $tree, 'BEFORE'); # Process children, as required if ("REF" eq ref $tree) { walk_ast_tree($context, $$tree, $fn); } elsif ("ARRAY" eq ref $tree) { walk_ast_tree($context, $_, $fn) for @$tree; } $fn->($context, $tree, 'AFTER'); } # Trim whitespace from both ends of the string sub trim { my $t = shift; $t =~ s/\s+$//; $t =~ s/^\s+//; return $t; } sub slurp { local $/; my $FH = shift; return <$FH>; } sub ast_to_string { my $r = shift; if ("REF" eq ref $r) { return ast_to_string($$r); } elsif ("ARRAY" eq ref $r) { return "(" . join(" ", map { ast_to_string($_) } @$r) . ")"; } elsif ("" eq ref $r) { return $r; } die "? " . ref($r) . " ?"; } __DATA__ # Default action returns the value of the first thing in the productio +n. :default ::= action => ::first expr ::= OR | XOR | term ; term ::= AND | factor ; factor ::= variable | ('(') expr (')') | NOT ; # For our binary operators, we want the name as well for code generati +on # such as "( OR <arg1> <arg2> )" OR ::= expr ('+') term action => [name, values] ; XOR ::= expr ('^') term action => [name, values] ; AND ::= term ('*') factor action => [name, values] ; # We provde both prefix NOT (!) and suffix NOT (') because I saw it in # the thread. Again, we want the name for code generation. In both # cases, we generate "( NOT <arg> )" NOT ::= ('!') factor action => [name, values] | factor (postfix_NOT) action => [name, values] ; variable ::= ID action => [name, values] ; ID ~ [A-Za-z]+ # I did this as a character class because I couldn't quote it in the B +NF postfix_NOT ~ ['] :discard ~ whitespace whitespace ~ [\s]+

A couple example runs:

$ perl ex_marpa_bool_expr_truth_table.pl ex_c Expression to parse: A+!B Parse tree: (OR (variable A) (NOT (variable B))) Variables: A, B TRUTH TABLE A B : OUT 0 0 : 1 0 1 : 0 1 0 : 1 1 1 : 1 Roboticus@Waubli ~/parse_example $ perl ex_marpa_bool_expr_truth_table.pl ex_e Expression to parse: A*B*C + A*!B*!C + !A*!B Parse tree: (OR (OR (AND (AND (variable A) (variable B)) (variable C)) (AND (AND ( +variable A) (NOT (variable B))) (NOT (variable C)))) (AND (NOT (varia +ble A)) (NOT (variable B)))) Variables: A, B, C TRUTH TABLE A B C : OUT 0 0 0 : 1 0 0 1 : 1 0 1 0 : 0 0 1 1 : 0 1 0 0 : 1 1 0 1 : 0 1 1 0 : 0 1 1 1 : 1 Roboticus@Waubli ~/parse_example $ perl ex_marpa_bool_expr_truth_table.pl ex_f Expression to parse: A*B*C+!B+C*A Parse tree: (OR (OR (AND (AND (variable A) (variable B)) (variable C)) (NOT (varia +ble B))) (AND (variable C) (variable A))) Variables: A, B, C TRUTH TABLE A B C : OUT 0 0 0 : 1 0 0 1 : 1 0 1 0 : 0 0 1 1 : 0 1 0 0 : 1 1 0 1 : 1 1 1 0 : 0 1 1 1 : 1

Update: Added $fn_eval so I could ignore $tmp after building the evaluator function.

Please message me if anything is unclear, and I'll try to tweak it and/or improve the comments. Enjoy!

...roboticus

When your only tool is a hammer, all problems look like your thumb.


In reply to Re^9: Generate a truth table from string with Marpa by roboticus
in thread Generate a truth table from input string by Anonymous Monk

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others perusing the Monastery: (6)
    As of 2020-09-21 10:34 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      If at first I donít succeed, I Ö










      Results (125 votes). Check out past polls.

      Notices?