P is for Practical PerlMonks

### comment on

 Need Help??

An updated version of the above with all the bugs I am aware of fixed.

It attempts to verify the results by reversing them. The caveat being that as far as I can see, there is no easy way to put back parenthesis around subexpressions? Hence it will flag expressions that contain parenthesised subexpression as not being correctly.

In every case I have tested, the expression has been reversed correctly except for the replacement of the parens.

It's not a perfect test method, but the best I have come up with. Anyone have a better one?

Results

```P:\test>423305
1+2+3
1, 2, +, 3, +
1+2+3

a+b+c
a, b, +, c, +
a+b+c

abc+def+Efg_hij
abc, def, +, Efg_hij, +
abc+def+Efg_hij

2.0+1e-2/0.01E-21
2.0, 1e-2, +, 0.01E-21, /
2.0+1e-2/0.01E-21

max(a,b,c,d)*atan(pi*4,-1)
a, b, c, d, 4, max(), pi, 4, *, -1, 2, atan(), *
max(a,b,c,d)*atan(pi*4,-1)

sin(cos(x)-tan(y))+f(g(z))
x, 1, cos(), y, 1, tan(), -, 1, sin(), z, 1, g(), 1, f(), +
sin(cos(x)-tan(y))+f(g(z))

2*(somevar+other)+max(this,that)
2, somevar, other, +, *, this, that, 2, max(), +
2*somevar+other+max(this,that)

** Reversal didn't match original **

A+(B*C-D)/E
A, B, C, *, D, -, +, E, /
A+B*C-D/E

** Reversal didn't match original **

(a*(b)-c^(3.4e-2))
a, b, *, c, -, 3.4e-2, ^
a*b-c^3.4e-2

** Reversal didn't match original **

5^((-2e-3+x)*sin(p+4.0)/fred)
5, -2e-3, x, +, p, 4.0, +, 1, sin(), *, fred, /, ^
5^-2e-3+x*sin(p+4.0)/fred

** Reversal didn't match original **

sin(a)+sin(ab)+sin(a,b)
a, 1, sin(), ab, 1, sin(), +, a, b, 2, sin(), +
sin(a)+sin(ab)+sin(a,b)

Func_1(1,Func_2(Func3(1*2*3)*aFunc(3))+FuNc(4,5,6),-2,e,-10,-2e-10)+1
1, 1, 2, *, 3, *, 1, Func3(), 3, 1, aFunc(), *, 1, Func_2(), 4, 5, 6,
+3, FuNc(), +, -2, e, -10, -2e-10, 6, Func_1(), 1, +
Func_1(1,Func_2(Func3(1*2*3)*aFunc(3))+FuNc(4,5,6),-2,e,-10,-2e-10)+1

Code:

```#! perl -slw
use strict;
use List::Util qw[ reduce ]; \$a=\$b;

our \$XLATE ||= 0;

sub nestedOk{
index( \$_[ 0 ], '(' ) <= index( \$_[ 0 ], ')' ) and
0 == reduce{
\$a + ( \$b eq '(' ) - ( \$b eq ')' )
} 0, split'[^()]*', \$_[ 0 ]
}

my \$re_var   = qr[ [a-zA-Z]\w* ]x;
my \$re_subex = qr[ \{\d+\} ]x;
my \$re_func  = qr[ \$re_var \$re_subex ]x;
my \$re_num   = qr[ -? \d+ (?: \. \d+ )? (?: [Ee] [+-]? \d+ )? ]x;
my \$re_term  = qr[ \$re_num | \$re_func | \$re_subex | \$re_var ]x;
my \$re_op    = qr[[,%+*/^-]];
my %ops = ( qw[ % MOD + ADD * MULT / DIV ^ POW - SUBT ] );

my @varargs;
sub exp2rpn {
my( \$exp, \$aStack, \$aBits ) = @_;
die "Unbalanced parens: '\$exp'" unless nestedOk \$exp;
{
my( \$left, \$op, \$right, \$rest ) = \$exp =~ m[
^ (?: ( \$re_term )? ( \$re_op ) )? ( \$re_term ) ( .* ) \$
]x or die "malformed (sub)expression '\$exp'";
#{ no warnings; print "'\$exp' => '\$left'\$op'\$right'\$rest'"; }

\$varargs[ -1 ]++ if \$op and \$op eq ',' and @varargs;

for ( \$left, \$right ) {
next unless \$_;
if( my( \$func, \$subex ) = m[^ ( \$re_var )? \{ ( \d+ ) \} \$
+]x ) {
push @varargs, 1;
exp2rpn( \$aBits->[ \$subex ], \$aStack, \$aBits );
push @\$aStack, pop @varargs if \$func;
push @\$aStack, "\$func()" if \$func
}
else{
push( @\$aStack, \$_  );
}
}

push @\$aStack, \$XLATE ? \$ops{ \$op } : \$op
if \$op and \$op ne ',';
\$exp = \$rest, redo if \$rest;
}
return \$aStack;
}

sub parseExp {
local \$_ = \$_[ 0 ];
s[\s+][]g;
return warn "Unbalanced parens: '\$_'" unless nestedOk \$_;
my( \$bit, @bits ) = 0;
s[\( ( [^()]+ )  \)]{ push @bits, \$1; "{\${ \( \$bit++ ) }}"; }ex
while m[[()]];
return @{ exp2rpn \$_, [], \@bits };
}

sub rpn2exp {
my %tops = map{ \$_ => undef } qw[ % MOD + ADD * MULT / DIV ^ POW -
+ SUBT ];
my @stack;
my \$expr;
while( @_ ) {
my \$item = shift @_;
push( @stack, \$item ), next
unless exists \$tops{ \$item } or \$item =~ m[\(\)\$];
if( exists \$tops{ \$item } ) {
my \$arg2 = pop @stack;
my \$arg1 = pop @stack;
push @stack, join '', \$arg1, \$item, \$arg2;
}
elsif( my( \$func ) = \$item =~ m[^(.*)\(\)\$] ) {
my \$args = pop @stack;
my @args = map{ pop @stack } 1 .. \$args;
push @stack, \$func . '(' . join( ',', reverse @args ) . ')
+';
}
}
return "@stack";
}

while( chomp( my \$exp = <DATA> || '' ) ) {
my @rpn = parseExp \$exp;
\$exp =~ s[\s+][]g;
my \$reversed = rpn2exp @rpn;
printf "%s\n%s\n%s\n\n", \$exp, join(', ', @rpn), \$reversed ;
warn "\t** Reversal didn't match original **\n\n" unless \$exp eq \$
+reversed;
}

__DATA__
1+2+3
a+b+c
abc+def+Efg_hij
2.0+1e-2/0.01E-21
max( a, b, c, d ) * atan( pi*4, -1 )
sin( cos( x ) - tan( y ) ) + f( g( z ) )
2*(somevar+other) + max(this, that)
A+(B*C-D)/E
(a*(b)-c^(3.4e-2))
5^((-2e-3+x)*sin(p+4.0)/fred)
sin(a) + sin(ab) + sin( a, b )
Func_1( 1, Func_2( Func3( 1* 2 * 3) * aFunc( 3 ) )+FuNc(4,5,6), -2,e,
+-10, -2e-10 ) +1

Examine what is said, not who speaks.
Silence betokens consent.
Love the truth but pardon error.

In reply to Re^5: Generic RPN Translator available? by BrowserUk
in thread Generic RPN Translator available? by saintmike

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

• 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.

Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (5)
As of 2024-06-19 09:49 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?

No recent polls found

Notices?
 • erzuuli ‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.