#!perl -w
use strict;
my %var;

my %op = (
  '+'  => { prec => 10, assoc => 'L', exec => sub { $_[0] + $_[1] }, function => 'sum'},
  '-'  => { prec => 10, assoc => 'L', exec => sub { $_[0] - $_[1] }, function => 'dif'},
  '*'  => { prec => 20, assoc => 'L', exec => sub { $_[0] * $_[1] }, function => 'mul'},
  '/'  => { prec => 20, assoc => 'L', exec => sub { $_[0] / $_[1] }, function => 'div'},
  '%'  => { prec => 20, assoc => 'L', exec => sub { $_[0] % $_[1] }, function => 'mod'},
  '**' => { prec => 30, assoc => 'R', exec => sub { $_[0] ** $_[1] }, function => 'pow'},
);

my %function = (
  sumsq => sub  { my $sum = 0; foreach(@_) { $sum += $_*$_; } return $sum; },
  sqrt => sub { return sqrt shift; },
  negate => sub { return -shift },
);

# turn the operators into a function
foreach my $op (values %op) {
    $function{$op->{function}} = $op->{exec};
}

{
    # Function class
    package Function;
    sub new {
        # Function->new($funcname => @arguments)
        my $class = shift;
        my %self;
        $self{function} = shift;
        $self{arguments} = [ @_ ];
        return bless \%self, $class;
    }

    sub stringify {
        my $self = shift;
        local $" = ", ";
        return "$self->{function}(@{$self->{arguments}})";
    }
    use overload '""' => \&stringify;

    sub evaluate {
        my $self = shift;
        my $code = $function{$self->{function}} or die "No code provided for '$self->{function}'";
        return $code->(map 0+$_, @{$self->{arguments}});
    }
    use overload '0+' => \&evaluate, fallback => 1;
}

{
    # class Var
    package Var;
    sub new {
        # Var->new($name);
        my $class = shift;
        my $name = shift;
        return bless \$name, $class;
    }

    sub stringify {
        my $self = shift;
        return "$$self";
    }
    use overload '""' => \&stringify;

    sub fetch {
        my $self = shift;
        exists $var{$$self} or warn "Use of uninitialised variable '$$self'";
        return $var{$$self} || 0;
    }
    use overload '0+' => \&fetch, fallback => 1;
}


# fields:
use constant VALUE => 0;
use constant OP => 1;
use constant PREC => 2;

use constant TRACE => 1;

sub parse_expr {
    my @stack;
    push @stack, [ undef, undef, 0 ];  # sentinel
    while (1) {
        trace() if TRACE;
        my($value) = parse_value() or die "Parse error at " . where();
        trace("value=$value") if TRACE;
        my($op, $prec);
        if(/\G\s*(\*\*|[+\-*\/%\\])/gc) {  # operator
            $op = $1;
            $prec = $op{$op}{prec};
            trace("op=$op") if TRACE;
        } else {  # no more
            $prec = 0;
        }
        # process
        while($stack[-1][PREC] > $prec) {
            my($lhs, $op) = @{pop @stack};
            trace("popping $lhs $op") if TRACE;
            $value = Function->new($op{$op}{function}, $lhs, $value);
            trace("result = $value") if TRACE;
        }
        if($prec) {
            if($op{$op}{assoc} eq 'L') {
                $prec++;
            }
            push @stack, [ $value, $op, $prec ];
        } else {
            pop @stack;  # sentinel
            return $value;
        }
    }
}

sub parse_value {
    /\G\s+/gc;
    if(/\G\+/gc) {  #  '+' value
        trace("Unary plus") if TRACE;
        return parse_value();
    }
    if(/\G-/gc) {  #  '-' value
        trace("Unary minus") if TRACE;
        return Function->new(negate => parse_value());
    }
    if(/\G((?:\d+\.?\d*|\.\d+)(?i:E[+-]?\d+)?)/gc) {  # number
        return $1;
    }
    if(/\G((?i:[a-z]\w*))\s*\(/gc) {  # function '('
        my $function = $1;
        $function{$function} or die sprintf "Undefined function '$function' called at: \"%s\"", where();
        my @arg;
        unless(/\G\s*(?=\))/gc) {
            while(1){
                my($value) = parse_expr() or die sprintf "Expression expected at: \"%s\"", where();
                push @arg, $value;
                /\G\s*,/gc or last;
            }
        }
        /\G\s+/gc;
        /\G\)/gc or die sprintf "Parse error: ')' expected at: \"%s\"", where();
        trace(sprintf "function '$function' called with %d argument%s", scalar @arg, @arg==1 ? "" : "s")
          if TRACE;
        return Function->new($function, @arg);
    }
    if(/\G((?i:[a-z]\w*))/gc) {  # variable
        return Var->new($1);
    }
    if(/\G\(/gc) {  #  '(' expr ')'
        my $value = parse_expr();
        /\G\s+/gc;
        /\G\)/gc or die sprintf "Parse error: ')' expected at: \"%s\"", where();
        return $value;
    }
    return;
}

sub evaluate {
    local $_ = shift;
    my $value = parse_expr();
    /\G\s+/gc;
    /\G$/gc or die sprintf "Junk characters at end: \"%s\"", where();
    return $value;
}

sub where {  # debugging info
    my $s = $_;
    substr($s, pos || 0, 0) = "\267";
    return $s;
}

sub trace {
    my($pkg, $file, $line) = caller;
    printf STDERR "Line %d \"%s\" %s\n", $line, where(), @_ ? shift : "";
}

%var = ( a => 101, b => 7 );
$_ = "a+sumsq(3,2+2)*sqrt(36)/2";

my $result = evaluate($_);
print "\nsource: $_\n";
use Data::Dumper;
$Data::Dumper::Indent = 1;
print "Dumped:\n", Dumper $result;
print "Stringified: $result\n";
print "Numerified with a=$var{a}: " . (0+$result) . "\n";
$var{a} = 25;
print "Numerified with a=$var{a}: " . (0+$result) . "\n";

##</code><code>##

Line 86 "·a+sumsq(3,2+2)*sqrt(36)/2"
Line 88 "a·+sumsq(3,2+2)*sqrt(36)/2" value=a
Line 93 "a+·sumsq(3,2+2)*sqrt(36)/2" op=+
Line 86 "a+·sumsq(3,2+2)*sqrt(36)/2"
Line 86 "a+sumsq(·3,2+2)*sqrt(36)/2"
Line 88 "a+sumsq(3·,2+2)*sqrt(36)/2" value=3
Line 86 "a+sumsq(3,·2+2)*sqrt(36)/2"
Line 88 "a+sumsq(3,2·+2)*sqrt(36)/2" value=2
Line 93 "a+sumsq(3,2+·2)*sqrt(36)/2" op=+
Line 86 "a+sumsq(3,2+·2)*sqrt(36)/2"
Line 88 "a+sumsq(3,2+2·)*sqrt(36)/2" value=2
Line 100 "a+sumsq(3,2+2·)*sqrt(36)/2" popping 2 +
Line 102 "a+sumsq(3,2+2·)*sqrt(36)/2" result = sum(2, 2)
Line 142 "a+sumsq(3,2+2)·*sqrt(36)/2" function 'sumsq' called with 2 arguments
Line 88 "a+sumsq(3,2+2)·*sqrt(36)/2" value=sumsq(3, sum(2, 2))
Line 93 "a+sumsq(3,2+2)*·sqrt(36)/2" op=*
Line 86 "a+sumsq(3,2+2)*·sqrt(36)/2"
Line 86 "a+sumsq(3,2+2)*sqrt(·36)/2"
Line 88 "a+sumsq(3,2+2)*sqrt(36·)/2" value=36
Line 142 "a+sumsq(3,2+2)*sqrt(36)·/2" function 'sqrt' called with 1 argument
Line 88 "a+sumsq(3,2+2)*sqrt(36)·/2" value=sqrt(36)
Line 93 "a+sumsq(3,2+2)*sqrt(36)/·2" op=/
Line 100 "a+sumsq(3,2+2)*sqrt(36)/·2" popping sumsq(3, sum(2, 2)) *
Line 102 "a+sumsq(3,2+2)*sqrt(36)/·2" result = mul(sumsq(3, sum(2, 2)), sqrt(36))
Line 86 "a+sumsq(3,2+2)*sqrt(36)/·2"
Line 88 "a+sumsq(3,2+2)*sqrt(36)/2·" value=2
Line 100 "a+sumsq(3,2+2)*sqrt(36)/2·" popping mul(sumsq(3, sum(2, 2)), sqrt(36)) /
Line 102 "a+sumsq(3,2+2)*sqrt(36)/2·" result = div(mul(sumsq(3, sum(2, 2)), sqrt(36)), 2)
Line 100 "a+sumsq(3,2+2)*sqrt(36)/2·" popping a +
Line 102 "a+sumsq(3,2+2)*sqrt(36)/2·" result = sum(a, div(mul(sumsq(3, sum(2, 2)), sqrt(36)), 2))

source: a+sumsq(3,2+2)*sqrt(36)/2
Dumped:
$VAR1 = bless( {
  'function' => 'sum',
  'arguments' => [
    bless( do{\(my $o = 'a')}, 'Var' ),
    bless( {
      'function' => 'div',
      'arguments' => [
        bless( {
          'function' => 'mul',
          'arguments' => [
            bless( {
              'function' => 'sumsq',
              'arguments' => [
                '3',
                bless( {
                  'function' => 'sum',
                  'arguments' => [
                    '2',
                    '2'
                  ]
                }, 'Function' )
              ]
            }, 'Function' ),
            bless( {
              'function' => 'sqrt',
              'arguments' => [
                '36'
              ]
            }, 'Function' )
          ]
        }, 'Function' ),
        '2'
      ]
    }, 'Function' )
  ]
}, 'Function' );
Stringified: sum(a, div(mul(sumsq(3, sum(2, 2)), sqrt(36)), 2))
Numerified with a=101: 176
Numerified with a=25: 100