Download code

Jump to: navigation, search

Back to Shunting_yard_algorithm_(Perl)

Download for Windows: single file, zip

Download for UNIX: single file, zip, tar.gz, tar.bz2

build.log

1 /tmp/litprog439026/shunting-yard.perl syntax OK


shunting-yard.perl

 1 #!/usr/bin/env perl
 2 # The authors of this work have released all rights to it and placed it
 3 # in the public domain under the Creative Commons CC0 1.0 waiver
 4 # (http://creativecommons.org/publicdomain/zero/1.0/).
 5 # 
 6 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
 7 # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 8 # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
 9 # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
10 # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
11 # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
12 # SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
13 # 
14 # Retrieved from: http://en.literateprograms.org/Shunting_yard_algorithm_(Perl)?oldid=12069
15 
16 
17 use strict;
18 use warnings;
19 
20 my ($expr)=@ARGV;
21 
22 if(!$expr) {
23 	print "Usage $0 expression\n";
24 	exit 1;
25 }
26 
27 my @tokens=split(/\ *([\+\-\*\/\(\)]|\d+\.\d+|\d+) */, $expr);
28 
29 
30 my %prec=('-u'=>5, '*'=>4, '/'=>3, '+'=>2, '-'=>1, '('=>0, ''=>9);
31 my %right=('-u'=>1);
32 sub getprec {
33 	my ($op)=@_;
34 	return exists $prec{$op}?$prec{$op}:-1;
35 }
36 
37 # Parsing
38 
39 my @op_stack;
40 my @rpn;
41 
42 my $last="";
43 foreach my $token (@tokens) {
44 	!$token and next;
45 
46 	if($token eq '-' and getprec($last)>=0) {$token='-u';}
47 
48 	if($token=~/^\d+$|^\d+\.\d+$/) {
49 		if($last=~/^\d+$|^\d+\.\d+$/ || $last eq ")") {
50 			die "Value tokens must be separated by an operator";
51 		}
52 		push(@rpn, $token);
53 	} elsif($token eq '(') {
54 		push(@op_stack, $token);
55 	} elsif($token eq ')') {
56 		while($op_stack[-1] ne '(') {
57 			my $t=pop(@op_stack);
58 			push(@rpn, $t);
59 		}
60 		pop(@op_stack) eq '(' or die "No matching (";
61 	} elsif((my $pr=getprec($token))>0) {
62 		if(exists $right{$token}) {
63 			while(scalar @op_stack>0 && $pr<getprec($op_stack[-1])) {
64 				push(@rpn, pop(@op_stack));
65 			}
66 		} else {
67 			while(scalar @op_stack>0 && $pr<=getprec($op_stack[-1])) {
68 				push(@rpn, pop(@op_stack));
69 			}
70 		}
71 		push(@op_stack, $token);
72 	} else {
73 		die "Unknown token: \"$token\"";
74 	}
75 	$last=$token;
76 }
77 
78 while(scalar @op_stack>0) {
79 	push(@rpn, pop(@op_stack));
80 }
81 
82 
83 
84 
85 foreach my $token (@rpn) {
86 	if($token eq '-u') {print '_1* ';}
87 	else {print "$token ";}
88 }
89 print "p\n";
90 
91 


hijacker
hijacker
hijacker
hijacker