Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Re^8: Generate a truth table from input string

by Discipulus (Abbot)
on Oct 28, 2017 at 15:47 UTC ( #1202235=note: print w/replies, xml ) Need Help??


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

Hello,

it's not at all a noob level code: it's something like a grammar execution using eval

Nowadays grammars are better implemented using Marpa::R2 but is not my field.

Anyway using print YAPE::Regex::Explain and Data::Dumper all will become much clearer (I hope..):

use Data::Dumper; use YAPE::Regex::Explain; print "regex explanation:\n"; print "\t",YAPE::Regex::Explain->new(qr{s/\*/ && /})->explain; print "\t",YAPE::Regex::Explain->new(qr{s/\+/ || /})->explain; print "\t",YAPE::Regex::Explain->new(qr{s/(\w+)\s*'/!$1/g})->explain; print "\t",YAPE::Regex::Explain->new(qr{\((?:(?>[^()]+)|(??{$re}))*\)} +)->explain; print "processing DATA:\n"; while(<DATA>){ chomp; # added by me print "\n\t-->received [$_]\n"; my ($re, $term, @vars, %vars, $loops); s/\*/ && /g; print "\t-->after first regex [$_]\n"; s/\+/ || /g; print "\t-->after second regex [$_]\n"; s/(\w+)\s*'/!$1/g; print "\t-->after third regex [$_]\n"; $re = qr{\((?:(?>[^()]+)|(??{$re}))*\)}; # :-) s/($re)\s*'/!$1/g; print "\t-->after fourth regex [$_]\n"; $term = $_; print "\t-->\$term is [$term]\n"; @vars = $_ =~ m/(\w+)/g; print "\t\@vars is [@vars]\n"; $vars{$_}++ for @vars; print "\t-->\%vars is :\n"; print "\t\t", Dumper \%vars; @vars = sort keys %vars; print "\t-->\@vars is [@vars]\n"; s/(\w+)/\$$1/g; print "\t-->\$_ is [$_]\n"; printf "\n@vars = $term"; @vars = map {"\$$_"}@vars; print "\n\t-->\@vars is [@vars]\n"; $loops .= "for $_ (0..1) {\n" for @vars; print "\t-->\$loops is [$loops]\n"; $loops .= qq{printf "@vars = %d\n", eval;\n}; print "\t-->\$loops is [$loops]\n"; $loops .= "}" for @vars; print "\t-->\$loops is [$loops]\n\n\n"; do{ no strict 'vars'; eval $loops }; die "Can't process $term$_\n$@\n" if $@; } __DATA__ a*b*!(c) a'+b'+c' !(a*b) b^a (a^b)' (a+(a+b))'*c

which output:

regex explanation: The regular expression: (?-imsx:s/\*/ && /) matches as follows: NODE EXPLANATION ---------------------------------------------------------------------- (?-imsx: group, but do not capture (case-sensitive) (with ^ and $ matching normally) (with . not matching \n) (matching whitespace and # normally): ---------------------------------------------------------------------- s/ 's/' ---------------------------------------------------------------------- \* '*' ---------------------------------------------------------------------- / && / '/ && /' ---------------------------------------------------------------------- ) end of grouping ---------------------------------------------------------------------- The regular expression: (?-imsx:s/\+/ || /) matches as follows: NODE EXPLANATION ---------------------------------------------------------------------- (?-imsx: group, but do not capture (case-sensitive) (with ^ and $ matching normally) (with . not matching \n) (matching whitespace and # normally): ---------------------------------------------------------------------- s/ 's/' ---------------------------------------------------------------------- \+ '+' ---------------------------------------------------------------------- / '/ ' ---------------------------------------------------------------------- | OR ---------------------------------------------------------------------- | OR ---------------------------------------------------------------------- / ' /' ---------------------------------------------------------------------- ) end of grouping ---------------------------------------------------------------------- The regular expression: (?-imsx:s/(\w+)\s*'/!/g) matches as follows: NODE EXPLANATION ---------------------------------------------------------------------- (?-imsx: group, but do not capture (case-sensitive) (with ^ and $ matching normally) (with . not matching \n) (matching whitespace and # normally): ---------------------------------------------------------------------- s/ 's/' ---------------------------------------------------------------------- ( group and capture to \1: ---------------------------------------------------------------------- \w+ word characters (a-z, A-Z, 0-9, _) (1 or more times (matching the most amount possible)) ---------------------------------------------------------------------- ) end of \1 ---------------------------------------------------------------------- \s* whitespace (\n, \r, \t, \f, and " ") (0 or more times (matching the most amount possible)) ---------------------------------------------------------------------- '/!/g '\'/!/g' ---------------------------------------------------------------------- ) end of grouping ---------------------------------------------------------------------- The regular expression: (?-imsx:\((?:(?>[^()]+)|(??{$re}))*\)) matches as follows: NODE EXPLANATION ---------------------------------------------------------------------- (?-imsx: group, but do not capture (case-sensitive) (with ^ and $ matching normally) (with . not matching \n) (matching whitespace and # normally): ---------------------------------------------------------------------- \( '(' ---------------------------------------------------------------------- (?: group, but do not capture (0 or more times (matching the most amount possible)): ---------------------------------------------------------------------- (?> match (and do not backtrack afterwards): ---------------------------------------------------------------------- [^()]+ any character except: '(', ')' (1 or more times (matching the most amount possible)) ---------------------------------------------------------------------- ) end of look-ahead ---------------------------------------------------------------------- | OR ---------------------------------------------------------------------- (??{$re}) run this block of Perl code (that isn't interpolated until RIGHT NOW) ---------------------------------------------------------------------- )* end of grouping ---------------------------------------------------------------------- \) ')' ---------------------------------------------------------------------- ) end of grouping ---------------------------------------------------------------------- processing DATA: -->received [a*b*!(c)] -->after first regex [a && b && !(c)] -->after second regex [a && b && !(c)] -->after third regex [a && b && !(c)] -->after fourth regex [a && b && !(c)] -->$term is [a && b && !(c)] @vars is [a b c] -->%vars is : $VAR1 = { 'c' => 1, 'a' => 1, 'b' => 1 }; -->@vars is [a b c] -->$_ is [$a && $b && !($c)] a b c = a && b && !(c) -->@vars is [$a $b $c] -->$loops is [for $a (0..1) { for $b (0..1) { for $c (0..1) { ] -->$loops is [for $a (0..1) { for $b (0..1) { for $c (0..1) { printf "$a $b $c = %d ", eval; ] -->$loops is [for $a (0..1) { for $b (0..1) { for $c (0..1) { printf "$a $b $c = %d ", eval; }}}] 0 0 0 = 0 0 0 1 = 0 0 1 0 = 0 0 1 1 = 0 1 0 0 = 0 1 0 1 = 0 1 1 0 = 1 1 1 1 = 0 -->received [a'+b'+c'] -->after first regex [a'+b'+c'] -->after second regex [a' || b' || c'] -->after third regex [!a || !b || !c] -->after fourth regex [!a || !b || !c] -->$term is [!a || !b || !c] @vars is [a b c] -->%vars is : $VAR1 = { 'c' => 1, 'a' => 1, 'b' => 1 }; -->@vars is [a b c] -->$_ is [!$a || !$b || !$c] a b c = !a || !b || !c -->@vars is [$a $b $c] -->$loops is [for $a (0..1) { for $b (0..1) { for $c (0..1) { ] -->$loops is [for $a (0..1) { for $b (0..1) { for $c (0..1) { printf "$a $b $c = %d ", eval; ] -->$loops is [for $a (0..1) { for $b (0..1) { for $c (0..1) { printf "$a $b $c = %d ", eval; }}}] 0 0 0 = 1 0 0 1 = 1 0 1 0 = 1 0 1 1 = 1 1 0 0 = 1 1 0 1 = 1 1 1 0 = 1 1 1 1 = 0 -->received [!(a*b)] -->after first regex [!(a && b)] -->after second regex [!(a && b)] -->after third regex [!(a && b)] -->after fourth regex [!(a && b)] -->$term is [!(a && b)] @vars is [a b] -->%vars is : $VAR1 = { 'a' => 1, 'b' => 1 }; -->@vars is [a b] -->$_ is [!($a && $b)] a b = !(a && b) -->@vars is [$a $b] -->$loops is [for $a (0..1) { for $b (0..1) { ] -->$loops is [for $a (0..1) { for $b (0..1) { printf "$a $b = %d ", eval; ] -->$loops is [for $a (0..1) { for $b (0..1) { printf "$a $b = %d ", eval; }}] 0 0 = 1 0 1 = 1 1 0 = 1 1 1 = 0 -->received [b^a] -->after first regex [b^a] -->after second regex [b^a] -->after third regex [b^a] -->after fourth regex [b^a] -->$term is [b^a] @vars is [b a] -->%vars is : $VAR1 = { 'a' => 1, 'b' => 1 }; -->@vars is [a b] -->$_ is [$b^$a] a b = b^a -->@vars is [$a $b] -->$loops is [for $a (0..1) { for $b (0..1) { ] -->$loops is [for $a (0..1) { for $b (0..1) { printf "$a $b = %d ", eval; ] -->$loops is [for $a (0..1) { for $b (0..1) { printf "$a $b = %d ", eval; }}] 0 0 = 0 0 1 = 1 1 0 = 1 1 1 = 0 -->received [(a^b)'] -->after first regex [(a^b)'] -->after second regex [(a^b)'] -->after third regex [(a^b)'] -->after fourth regex [!(a^b)] -->$term is [!(a^b)] @vars is [a b] -->%vars is : $VAR1 = { 'a' => 1, 'b' => 1 }; -->@vars is [a b] -->$_ is [!($a^$b)] a b = !(a^b) -->@vars is [$a $b] -->$loops is [for $a (0..1) { for $b (0..1) { ] -->$loops is [for $a (0..1) { for $b (0..1) { printf "$a $b = %d ", eval; ] -->$loops is [for $a (0..1) { for $b (0..1) { printf "$a $b = %d ", eval; }}] 0 0 = 1 0 1 = 0 1 0 = 0 1 1 = 1 -->received [(a+(a+b))'*c] -->after first regex [(a+(a+b))' && c] -->after second regex [(a || (a || b))' && c] -->after third regex [(a || (a || b))' && c] -->after fourth regex [!(a || (a || b)) && c] -->$term is [!(a || (a || b)) && c] @vars is [a a b c] -->%vars is : $VAR1 = { 'c' => 1, 'a' => 2, 'b' => 1 }; -->@vars is [a b c] -->$_ is [!($a || ($a || $b)) && $c] a b c = !(a || (a || b)) && c -->@vars is [$a $b $c] -->$loops is [for $a (0..1) { for $b (0..1) { for $c (0..1) { ] -->$loops is [for $a (0..1) { for $b (0..1) { for $c (0..1) { printf "$a $b $c = %d ", eval; ] -->$loops is [for $a (0..1) { for $b (0..1) { for $c (0..1) { printf "$a $b $c = %d ", eval; }}}] 0 0 0 = 0 0 0 1 = 1 0 1 0 = 0 0 1 1 = 0 1 0 0 = 0 1 0 1 = 0 1 1 0 = 0 1 1 1 = 0

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^9: Generate a truth table from string with Marpa
by roboticus (Chancellor) on Oct 28, 2017 at 23:01 UTC

    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://1202235]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (3)
As of 2020-09-24 06:04 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    If at first I donít succeed, I Ö










    Results (132 votes). Check out past polls.

    Notices?