aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

March 2014 update

Browse source
This commit is contained in:
Ingy döt Net 2014-04-02 16:56:35 +00:00
parent 09687c4926
commit a25938f123
1846 changed files with 21876 additions and 5203 deletions
Download patch file Download diff file Expand all files Collapse all files

51
Task/Parsing-Shunting-yard-algorithm/Perl/parsing-shunting-yard-algorithm.pl Normal file
View file

@ -0,0 +1,51 @@
use 5.010;
use strict;
use warnings;
my %prec = (
'^' => 4,
'*' => 3,
'/' => 3,
'+' => 2,
'-' => 2,
'(' => 1);
my %assoc = (
'^' => 'right',
'*' => 'left',
'/' => 'left',
'+' => 'left',
'-' => 'left');
sub shunting_yard {
my @inp = split ' ', $_[0];
my @ops;
my @res;
my $report = sub { printf "%25s %-7s %10s %s\n", "@res", "@ops", $_[0], "@inp" };
my $shift = sub { $report->( "shift @_"); push @ops, @_ };
my $reduce = sub { $report->("reduce @_"); push @res, @_ };
while( @inp ) {
given( shift @inp ) {
when ( /\d/ ) { $reduce->($_) }
when ( '(' ) { $shift->($_) }
when ( ')' ) { while( @ops and "(" ne (my $x = pop @ops) ) { $reduce->( $x ) } }
default {
my $newprec = $prec{$_};
while( @ops ) {
my $oldprec = $prec{$ops[-1]};
last if $newprec > $oldprec;
last if $newprec == $oldprec and $assoc{$_} eq 'right';
$reduce->( pop @ops );
}
$shift->( $_ );
}
}
}
$reduce->( pop @ops ) while @ops;
@res;
}
local $, = " ";
say shunting_yard '3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3' ;