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

46
Task/Parsing-Shunting-yard-algorithm/Perl-6/parsing-shunting-yard-algorithm.pl6 Normal file
View file

@ -0,0 +1,46 @@
my %prec =
'^' => 4,
'*' => 3,
'/' => 3,
'+' => 2,
'-' => 2,
'(' => 1;
my %assoc =
'^' => 'right',
'*' => 'left',
'/' => 'left',
'+' => 'left',
'-' => 'left';
sub shunting-yard ($prog) {
my @inp = $prog.words;
my @ops;
my @res;
sub report($op) { printf "%25s %-7s %10s %s\n", ~@res, ~@ops, $op, ~@inp }
sub shift($t) { report( "shift $t"); @ops.push: $t }
sub reduce($t) { report("reduce $t"); @res.push: $t }
while @inp {
given @inp.shift {
when /\d/ { reduce $_ };
when '(' { shift $_ }
when ')' { while @ops and (my $x = @ops.pop and $x ne '(') { 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 @ops.pop;
}
shift $_;
}
}
}
reduce @ops.pop while @ops;
@res;
}
say shunting-yard '3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3';

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' ;