#!env perl # # ex_marpa_bool_expr_truth_table.pl # # 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 production. :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 generation # such as "( OR )" 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 )" 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 BNF postfix_NOT ~ ['] :discard ~ whitespace whitespace ~ [\s]+