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';