I wrote my own constructing a Tree::Simple tree as output.
For completeness sake, I've rewritten the parser so it produces a parse tree. I took a quick look at Tree::Simple, and I found it too hard to my taste for the little benefit it would give me, so I'm using a handrolled function object instead — yes I'm converting the infix operators into prefix function calls. As an extra benefit, I can use overload to return a symbolic representation of the parse tree when used as a string, or actually evaluate it, when used as a number.
I think it clearly demontrates its viability as a parser for real work.
update Now with symbolic (postponed) variables, meaning: if you change the value of the variable in the %var hash, the value used in an evaluation by using a parsed expression in a numerical context, will change accordingly.
#!perl -w
use strict;
my %var;
my %op = (
'+' => { prec => 10, assoc => 'L', exec => sub { $_[0] + $_[1] }, f
+unction => 'sum'},
'-' => { prec => 10, assoc => 'L', exec => sub { $_[0] - $_[1] }, f
+unction => 'dif'},
'*' => { prec => 20, assoc => 'L', exec => sub { $_[0] * $_[1] }, f
+unction => 'mul'},
'/' => { prec => 20, assoc => 'L', exec => sub { $_[0] / $_[1] }, f
+unction => 'div'},
'%' => { prec => 20, assoc => 'L', exec => sub { $_[0] % $_[1] }, f
+unction => '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 provid
+ed 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 '$func
+tion' called at: \"%s\"", where();
my @arg;
unless(/\G\s*(?=\))/gc) {
while(1){
my($value) = parse_expr() or die sprintf "Expression e
+xpected 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";
Output:
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 a
+rguments
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 ar
+gument
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
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.
|
|