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. | 