Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

Re^9: Generate a truth table from string with Marpa

by roboticus (Chancellor)
on Oct 28, 2017 at 23:01 UTC ( #1202243=note: print w/replies, xml ) Need Help??


in reply to Re^8: Generate a truth table from input string
in thread Generate a truth table from input string

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.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://1202243]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others about the Monastery: (9)
As of 2020-08-14 09:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Which rocket would you take to Mars?










    Results (75 votes). Check out past polls.

    Notices?