package Math::Expression::Evaluator;
@ISA = qw(Exporter);
@EXPORT = qw(evaluate);
$VERSION = '0.01';
use strict;
use warnings;
use Carp;
my %op_eval = (
'^' => sub {$_[0] ** $_[1]},
'+' => sub {$_[0] + $_[1]},
'-' => sub {$_[0] - $_[1]},
'*' => sub {$_[0] * $_[1]},
'/' => sub {$_[0] / $_[1]},
);
my %func_eval = (
abs => sub { abs $_[0] },
int => sub { int $_[0] },
sqrt => sub { sqrt $_[0] },
);
my ($func_re) = map qr{$_}, join '|', keys %func_eval;
my $oper_re = qr{[()/*^+-]};
my $numb_re = qr{[+-]?(?:\d+(?:\.\d*)?|\.\d+)};
my $parser = qr{($func_re|$numb_re|$oper_re)};
sub evaluate {
my @stack = @_ == 1 ? parse(@_) : @_;
return $_[0] if @stack == 1;
0 while fix_op(\@stack);
0 while reduce_func(\@stack);
0 while reduce_paren(\@stack);
for my $op (qw[^ * / + -]) {
0 while reduce_op($op, \@stack);
}
croak "Unable to reduce to a number: '@stack'" if @stack != 1;
return evaluate($stack[0]);
}
sub parse {
my $expr = shift @_;
my @part = $expr =~ /$parser/g;
parse_error_check($expr, \@part);
return @part;
}
sub parse_error_check {
my ($expr, $part) = @_;
$expr =~ s/$parser//g;
croak "Unparseable parts: '$expr'" if $expr !~ /^\s*$/;
croak "Not a number: '$part->[0]'" if @$part == 1 && ! is_num($part->[0]);
}
sub is_num { return $_[0] =~ /$numb_re/; }
sub fix_op {
my $stack = shift @_;
for (1 .. $#$stack) {
my $atom = $stack->[$_];
next if ! is_num($atom);
if ($atom =~ s/^([+-])//) {
my $op = $1;
next if $stack->[$_ - 1] =~ m{[(*/+^-]};
splice(@$stack, $_, 1, $op, $atom);
return 1;
}
}
return;
}
sub reduce_func {
my $stack = shift @_;
for (0 .. $#$stack) {
my $atom = $stack->[$_];
next if ! is_func($atom);
croak "Function $atom require parens" if $stack->[$_ + 1] ne '(';
reduce_paren($stack, $_ + 1);
splice(@$stack, $_, 2, calculate($atom, $stack->[$_ + 1]));
return 1;
}
}
sub is_func { return exists $func_eval{$_[0]}; }
sub calculate {
my ($key, $x, $y, $val) = @_;
eval { $val = is_func($key)
? $func_eval{$key}->($x)
: $op_eval{$key}->($x, $y)
};
croak "Error: $@" if $@;
return $val;
}
sub reduce_paren {
my ($stack, $start) = @_;
$start ||= 0;
my ($beg, $open);
for ($start .. $#$stack) {
my $atom = $stack->[$_];
next if $atom ne '(' && $atom ne ')';
$open += $atom eq ')' ? -1 : 1;
$beg = $_ if ! defined $beg && $atom eq '(';
next if $open;
my $len = $_ - $beg + 1;
splice(@$stack, $beg, $len, evaluate(@{$stack}[$beg + 1 .. $_ - 1]));
return 1;
}
croak "Unbalanced Parens" if $open;
}
sub reduce_op {
my ($op, $stack) = @_;
return if @$stack < 3;
for (0 .. $#$stack - 2) {
my ($prev, $curr, $next) = @{$stack}[$_ .. $_ + 2];
next if $curr ne $op;
croak "Error: '$prev $op $next'" if ! is_num($prev) || ! is_num($next);
splice(@$stack, $_, 3, calculate($op, $prev, $next));
return 1;
}
return;
}
'This statement is false';
####
#!/usr/bin/perl
use strict;
use warnings;
use Parse::RecDescent;
use Data::Dumper;
my $grammar = q{
evaluate : ADD_SUB
ADD_SUB : MULT_DIV_MOD ADD_SUB_OP ADD_SUB
{ [@item[1,2,3]] }
| MULT_DIV_MOD
ADD_SUB_OP : '+' | '-'
MULT_DIV_MOD : GROUP MULT_DIV_MOD_OP MULT_DIV_MOD { [@item[1,2,3]] }
| GROUP
MULT_DIV_MOD_OP : '*' | '/' | '%'
GROUP : '(' ADD_SUB ')'
{ $item[2] }
| NUMBER
NUMBER : INTEGER | FLOAT | NAN
INTEGER : /[+-]?\d+/
FLOAT : /([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/
NAN : /(Inf(inity)?|NaN)/i
};
my $parser = new Parse::RecDescent $grammar;
print Dumper $parser->evaluate('42 - 5 + 1');
# Sees the result as 42 - (5 + 1)
####
#!/usr/bin/perl
use strict;
use warnings;
use Parse::RecDescent;
use Data::Dumper;
my $grammar = q{
evaluate : ADD_SUB
#ADD_SUB : MULT_DIV_MOD ADD_SUB_OP ADD_SUB
# { [@item[1,2,3]] }
# | MULT_DIV_MOD
# Reverse to ADD_SUB : ADD_SUB ADD_SUB_OP MULT_DIV_MOD | MULT_DIV_MOD
# Use following formula to eliminate left recursion
# A : A x | y -> A : y R, R : x R | e
# Let A = ADD_SUB
# Let x = ADD_SUB_OP MULT_DIV_MOD
# let y = MULT_DIV_MOD
ADD_SUB : MULT_DIV_MOD ADD_SUB_TAIL
{ [@item[1,2]] }
ADD_SUB_TAIL : ADD_SUB_OP MULT_DIV_MOD ADD_SUB_TAIL
{ [@item[1..3]] }
|
ADD_SUB_OP : '+' | '-'
# Same as above
MULT_DIV_MOD : GROUP MULT_DIV_MOD_TAIL
{ [@item[1,2]] }
MULT_DIV_MOD_TAIL : MULT_DIV_MOD_OP GROUP MULT_DIV_MOD_TAIL
{ [@item[1..3]] }
|
MULT_DIV_MOD_OP : '*' | '/' | '%'
GROUP : '(' ADD_SUB ')'
{ $item[2] }
| NUMBER
NUMBER : INTEGER | FLOAT | NAN
INTEGER : /[+-]?\d+/
FLOAT : /([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/
NAN : /(Inf(inity)?|NaN)/i
};
my $parser = new Parse::RecDescent $grammar;
print Dumper $parser->evaluate('42 - 5 + 1');
####
#!/usr/bin/perl
use strict;
use warnings;
use Parse::RecDescent;
my %dispatch = (
'+' => sub { $_[0] + $_[1] },
'-' => sub { $_[0] - $_[1] },
'*' => sub { $_[0] * $_[1] },
'/' => sub { $_[0] / $_[1] },
'^' => sub { $_[0] ** $_[1] },
'abs' => sub { abs $_[0] },
'sqrt' => sub { sqrt $_[0] },
);
sub calculate {
my $rule = shift @_;
if ($rule eq 'FUNCTION') {
my ($func, $x) = @_;
my $val = eval { $dispatch{$func}->($x); };
die $@ if $@;
return $val;
}
my @atom = @{ shift @_ };
my $val = shift @atom;
while (@atom) {
my ($op, $num) = splice(@atom, 0, 2);
eval { $val = $dispatch{$op}->($val, $num); };
die $@ if $@;
}
return $val;
}
my $grammar = <<'__GRAMMAR__';
evaluate : EXPR /\Z/ { $item[1] }
EXPR : ADD_SUB { $item[1] }
ADD_SUB : { main::calculate( @item ) }
ADD_SUB_OP : '+' | '-'
MUL_DIV_MOD : { main::calculate( @item ) }
MUL_DIV_MOD_OP : '*' | '/' | '%'
POW : { main::calculate( @item ) }
POW_OP : '^'
FUNCTION : FUNC_NAME GROUP { main::calculate( @item ) }
| GROUP
FUNC_NAME : 'abs' | 'sqrt'
GROUP : '(' EXPR ')' { $item[2] }
| NUMBER
NUMBER : FLOAT | INTEGER | NAN
INTEGER : /[+-]?\d+/
FLOAT : /([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/
NAN : /(Inf(inity)?|NaN)/i
__GRAMMAR__
my $parser = Parse::RecDescent->new($grammar) or die("Bad grammar\n");
my $answer = $parser->evaluate('11 - (4 + 4)^3 * sqrt(5 * (6 - 1)) + abs(-3)');
print defined $answer ? $answer : 'Invalid expression';
####
#!/usr/bin/perl
use strict;
use warnings;
use Parse::RecDescent;
my %eval = (
disp => \&eval_dispatch,
term => sub { $_[0] -> [1] },
'+' => sub { $_[0] + $_[1] },
'-' => sub { $_[0] - $_[1] },
'*' => sub { $_[0] * $_[1] },
'/' => sub { $_[0] / $_[1] },
'%' => sub { $_[0] % $_[1] },
);
sub eval_node {
local *_ = \$_[0];
return $eval{disp}->($_->[0], $_);
}
sub eval_dispatch {
my ($op, $node) = @_;
return $eval{$op}->($node) if $op eq 'term';
my $x = eval_node($node->[1]);
my $y = eval_node($node->[2]);
return $eval{$op}->($x, $y);
}
sub treeify {
my $t = shift @_;
$t = [ shift @_, $t, shift @_ ] while @_;
return $t;
}
my $grammar = <<'__END_OF_GRAMMAR__';
build : expr /\Z/ { $item[1] }
# Just an alias
expr : sum
# vvv lowest precedence
sum : { main::treeify(@{$item[1]}) }
prod : { main::treeify(@{$item[1]}) }
# ^^^ highest precedence
term : '(' expr ')' { $item[3] }
| UNSIGN_INT { [ @item ] }
# Tokens
UNSIGN_INT : /\d+/
SUM : '+' | '-'
PROD : '*' | '/' | '%'
__END_OF_GRAMMAR__
my $parser = Parse::RecDescent->new($grammar) or die("Bad grammar\n");
my $tree = $parser->build('11 - 6 + 4');
my $eval = eval_node($tree);
print "$eval\n";
####
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
use Parse::Yapp;
my $grammar = join '', ;
my $parser = Parse::Yapp->new(input => $grammar);
my $yapptxt = $parser->Output(classname => 'Calc');
eval $yapptxt; # normally written to a file
my $calc = Calc->new();
$calc->Ingest("11 - (4 + 4)^3 * sqrt(5 * (6 - 1)) + abs(-3)\n");
my $output = $calc->YYParse(yylex => \&Calc::Lexer);
print $output;
__DATA__
%left '-' '+'
%left '*' '/' '%'
%right '^'
%nonassoc 'sqrt' 'abs'
%%
stack : | stack expr '\n' { push @{$_[1]}, $_[2]; $_[1][0] };
expr : add | del | mul | div | mod | pow | grp | sqrt | abs | NUM;
add : expr '+' expr { $_[1] + $_[3] };
del : expr '-' expr { $_[1] - $_[3] };
mul : expr '*' expr { $_[1] * $_[3] };
div : expr '/' expr { $_[1] / $_[3] };
mod : expr '%' expr { $_[1] % $_[3] };
pow : expr '^' expr { $_[1] ** $_[3] };
grp : '(' expr ')' { $_[2] };
abs : 'abs' grp { abs($_[2]) };
sqrt : 'sqrt' grp { sqrt($_[2]) };
%%
sub Lexer {
my $parser = shift @_;
local *_ = \$parser->YYData->{INPUT};
s/^[ \t]+//; # leading non-newline whitespace
if (s/^(([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)//) {
return ('NUM', $1); # borrowed from Scalar::Util
}
return ($1, $1) if s/^(sqrt|abs)//;
return ($1, $1) if s/^(.)//s;
}
sub Ingest {
my $self = shift @_;
$self->YYData->{INPUT} = $_[0];
}
####
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
use Parse::Earley;
my $parser = Parse::Earley->new();
my $grammar = <<'__GRAMMAR__';
input: expr
expr: expr '+' mul_term
| expr '-' mul_term
| mul_term
mul_term: mul_term '*' exp
| mul_term '/' exp
| exp
exp: term '^' exp
| term
term: '(' expr ')'
| /\d+/ { $_ < 256 }
__GRAMMAR__
my $str = '1 + 2 - 3';
$parser->grammar($grammar);
$parser->start('input');
$parser->advance($str) for 1..6;
my ($tree) = $parser->matches_all($str, 'input');
print Dumper($tree);