Math::Expression::Evaluator - parses, compiles and evaluates mathematic expressions

    use Math::Expression::Evaluator;
    my $m = Math::Expression::Evaluator->new;

    print $m->parse("a = 12; a*3")->val(), "\n";
    # prints 36
    print $m->parse("2^(a/3)")->val(), "\n";
    # prints 8 (ie 2**3)
    print $m->parse("a / b")->val({ b => 6 }), "\n";
    # prints 36
    print $m->parse("log2(16)")->val(), "\n";
    # prints 4

    # if you care about speed
    my $func = $m->parse('2 + (4 * b)')->compiled;
    for (0 .. 100){
        print $func->({b => $_}), "\n";
    }

   $m->parse("a = 2; a")->val({a => 1}); 

                   Rate  no_optimize     optimize opt_compiled     compiled
    no_optimize  83.9/s           --         -44%         -82%         -83%
    optimize      150/s          78%           --         -68%         -69%
    opt_compiled  472/s         463%         215%           --          -4%
    compiled      490/s         485%         227%           4%           --

    git clone git://github.com/moritz/math-expression-evaluator.git

package Math::Expression::Evaluator;
use strict;
use warnings;
use Math::Expression::Evaluator::Parser;
use Math::Expression::Evaluator::Util qw(is_lvalue);
use Data::Dumper;
use POSIX qw(ceil floor);
use Carp;

use Math::Trig qw(atan asin acos tan);

our $VERSION = '0.3.2';

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->{tokens}       = [];
    $self->{variables}    = {};
    $self->{var_callback} = sub { confess "Variable '$_[0]' not defined" };

    my $first = shift;

    if (defined $first){
        if (ref $first){
            $self->{config} = $first;
            $self->parse(shift) if @_;
        } else {
            $self->parse($first);
        }
    }

    return $self;
}


# parse a text into an AST, stores the AST in $self->{ast}
sub parse {
    my ($self, $text) = @_;
    $self->{ast} =
        Math::Expression::Evaluator::Parser::parse($text, $self->{config});
    return $self;
}



sub optimize {
    my ($self) = @_;
    require Math::Expression::Evaluator::Optimizer;
    $self->{ast} = Math::Expression::Evaluator::Optimizer::_optimize($self, $self->{ast});
    return $self;
}

# evaluates an arbitrary AST, and returns its value
sub _execute {
    my ($self, $ast) = @_;
    my %dispatch = (
            '/' => sub {1 / $_[0]->_execute($_[1])},
            '-' => sub {-$_[0]->_execute($_[1])},
            '+' => \&_exec_sum,
            '*' => \&_exec_mul,
            '%' => sub {$_[0]->_execute($_[1]) % $_[0]->_execute($_[2]) },
            '^' => sub {$_[0]->_execute($_[1]) **  $self->_execute($_[2])},
            '**' => sub {$_[0]->_execute($_[1]) **  $self->_execute($_[2])},
            '=' => \&_exec_assignment,
            '&' => \&_exec_function_call,
            '{' => \&_exec_block,
            '$' => sub { my $self = shift; $self->_variable_lookup(@_) },
    );
#   print STDERR "Executing " . Dumper($self->{ast});
    if (ref $ast ){
        my @a = @$ast;
        my $op = shift @a;
        if (my $fun = $dispatch{$op}){
            return &$fun($self, @a);
        } else {
            confess ("Operator '$op' not yet implemented\n");
        }
    } else {
        $ast;
    }
}

sub set_var_callback {
    $_[0]->{var_callback} = $_[1];
}

# executes a sum
sub _exec_sum {
    my $self = shift;
    # avoid addition for unary plus, for overloaded objects
    my $sum = $self->_execute(shift);
    foreach (@_){
        $sum = $sum + $self->_execute($_);
    }
    return $sum;
}

# executes a value
sub val {
    my $self = shift;
    $self->{temp_vars} = shift || {};
    my $res =  $self->_execute($self->{ast});
    $self->{temp_vars} = {};
    return +$res;
}

# executes a block, eg a list of statements
sub _exec_block {
    my $self = shift;
#   warn "Executing block: ". Dumper(\@_);
    my $res;
    foreach (@_){
        $res = $self->_execute($_);
    }
    $res;
}

# executes a multiplication 
sub _exec_mul {
    my $self = shift;
    my $prod = 1;
    foreach (@_){
        $prod *= $self->_execute($_);
    }
    $prod;
}

# executes an _assignment
sub _exec_assignment {
    my ($self, $lvalue, $rvalue) = @_;
    if (!is_lvalue($lvalue)){
        confess('Internal error: $lvalue is not a "variable" AST');
    }
    return $self->{variables}{$lvalue->[1]} = $self->_execute($rvalue);
}


my %builtin_dispatch_table = (
    'sqrt'  => sub { sqrt $_[0] },
    'ceil'  => sub { ceil $_[0] },
    'floor' => sub { floor $_[0]},
    'sin'   => sub { sin  $_[0] },
    'asin'  => sub { asin $_[0] },
    'cos'   => sub { cos  $_[0] },
    'acos'  => sub { acos $_[0] },
    'tan'   => sub { tan  $_[0] },
    'atan'  => sub { atan $_[0] },
    'exp'   => sub { exp  $_[0] },
    'log'   => sub { log  $_[0] },
    'sinh'  => sub { (exp($_[0]) - exp(-$_[0]))/2},
    'cosh'  => sub { (exp($_[0]) + exp(-$_[0]))/2},
    'log10' => sub { log($_[0]) / log(10) },
    'log2'  => sub { log($_[0]) / log(2) },
    'theta' => sub { $_[0] > 0 ? 1 : 0 },
    'pi'    => sub { 3.141592653589793 },
);


sub set_function {
    my ($self, $name, $func) = @_;

    $self->{_user_dispatch_table}->{$name} = $func;
}

# executes a function call
sub _exec_function_call {
    my $self = shift;
    my $name = shift;

    my %dispatch_table = %builtin_dispatch_table;

    my %user_fun = %{$self->{_user_dispatch_table} || {} };
    while (my ($k, $v) = each %user_fun) {
        $dispatch_table{$k} = $v;
    }

    if (my $fun = $dispatch_table{$name}){
        return $fun->(map {$self->_execute($_)} @_);
    } else {
        confess("Unknown function: $name");
    }
}

# checks if a variable is defined, and returns its value
sub _variable_lookup {
    my ($self, $var) = @_;
#    warn "Looking up <$var>\n";
    if (exists $self->{temp_vars}->{$var}){
        return $self->{temp_vars}->{$var};
    } elsif (exists $self->{variables}->{$var}){
        return $self->{variables}->{$var};
    } else {
        $self->{var_callback}->($var);
    }
}

# used for testing purposes only:
# returns the (recursive) number of operands in the AST
sub ast_size {
    my ($self, $ast) = @_;
    $ast = defined $ast ? $ast : $self->{ast};
    return 1 unless ref $ast;
    my $size = -1; # the initial op/type should be ignored
    for (@$ast){
        $size += $self->ast_size($_);
    }
    return $size;
}

sub variables {
    my ($self) = shift;
    my %vars;
    my $v;
    my @todo = ($self->{ast});
    while (@todo){
        my $ast = shift @todo;
        next unless ref $ast;
        if ($ast->[0] eq '$'){
            $vars{$ast->[1]}++;
        } else {
            # XXX do we need push the first element of @$ast?
            push @todo, @$ast;
        }
    }
    return sort keys %vars;
}

# emit perl code for an AST.
# needed for compiling an expression into a anonymous sub
sub _ast_to_perl {
    my ($self, $ast) = @_;;
    return $ast unless ref $ast;

    my $joined_operator = sub {
        my $op = shift;
        return sub {
            join $op, map { '(' . $self->_ast_to_perl($_).  ')' } @_
        };
    };

    my %translations = (
        '$'     => sub { qq/( exists \$vars{$_[0]} ? \$vars{$_[0]} : exists \$default_vars{$_[0]} ? \$default_vars{$_[0]} : \$self->{var_callback}->("$_[0]")) / },
        '{'     => sub { join "\n", map { $self->_ast_to_perl($_) . ";" } @_ },
        '='     => sub { qq/\$vars{$_[0][1]} = / . $self->_ast_to_perl($_[1]) },
        '+'     => &$joined_operator('+'),
        '*'     => &$joined_operator('*'),
        '^'     => &$joined_operator('**'),
        '%'     => &$joined_operator('%'),
        '-'     => sub {  '-(' . $self->_ast_to_perl($_[0]) . ')' },
        '/'     => sub { '1/(' . $self->_ast_to_perl($_[0]) . ')' },
        '&'     => sub { $self->_function_to_perl(@_) },
    );
    my ($action, @rest) = @$ast;
    my $do = $translations{$action};
    if ($do){
        return &$do(@rest);
    } else {
        confess "Internal error: don't know what to do with '$action'";
    }
}

{
    my %builtins = (
        sqrt    => sub {  "sqrt($_[0])" },
        ceil    => sub {  "ceil($_[0])" },
        floor   => sub { "floor($_[0])" },
        sin     => sub {   "sin($_[0])" },
        asin    => sub {  "asin($_[0])" },
        cos     => sub {   "cos($_[0])" },
        acos    => sub {  "acos($_[0])" },
        tan     => sub {   "tan($_[0])" },
        atan    => sub {  "atan($_[0])" },
        exp     => sub {   "exp($_[0])" },
        log     => sub {   "log($_[0])" },
        sinh    => sub { "do { my \$t=$_[0]; (exp(\$t) - exp(-(\$t)))/2}" },
        cosh    => sub { "do { my \$t=$_[0]; (exp(\$t) + exp(-(\$t)))/2}" },
        log10   => sub {   "log($_[0]) / log(10)" },
        log2    => sub {   "log($_[0]) / log(2)" },
        theta   => sub { "$_[0] > 0 ? 1 : 0" },
        pi      => sub { "3.141592653589793" },
    );

    sub _function_to_perl {
        my ($self, $name, @args) = @_;
        if ($self->{_user_dispatch_table}->{$name}) {
            return qq[\$user_functions{'$name'}->(]
                   . join(',', map { $self->_ast_to_perl($_) } @args)
                   . qq[)];
        }
        my $do = $builtins{$name};
        if ($do){
            return $do->(map { $self->_ast_to_perl($_) } @args );
        } else {
            confess "Unknow function '$name'";
        }
    }
}

sub compiled {
    my $self = shift;
    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Terse  = 1;

    # the eval will close over %user_functions
    # if it contains any calls to it. Closures FTW!
    my %user_functions = %{ $self->{_user_dispatch_table} || {} };

    my $text = <<'CODE';
sub {
    my %vars = %{; shift || {} };
    use warnings FATAL => qw(uninitialized);
    no warnings 'void';
    my %default_vars = %{; 
CODE
    chomp $text;
    $text .= Dumper($self->{variables}) . "};\n    ";
    $text .= $self->_ast_to_perl($self->{ast});
    $text .= "\n}\n";
#    print STDERR "\n$text";
    my $res =  eval $text;
    confess "Internal error while compiling: $@" if $@;
    return $res;
}

1;

# vim: sw=4 ts=4 expandtab