Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
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

In reply to Re^2: Operator Precedence Parser by bart
in thread Operator Precedence Parser by bart

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others avoiding work at the Monastery: (19)
    As of 2015-07-02 17:23 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (44 votes), past polls