#!/usr/bin/perl
# make_grammar.pl: Creates Grammar.pm
use strict;
use warnings;
use Parse::RecDescent ();
my $grammar = <<'__END_OF_GRAMMAR__';
{
use strict;
use warnings;
use List::Util qw( sum );
sub cross_prod {
my ($l, $r) = @_;
my $lt = $l->[0];
my $rt = $r->[0];
die("Type error\n") if $lt ne 'matrix';
die("Type error\n") if $rt ne 'matrix';
my $lm = $l->[1];
my $rm = $r->[1];
die("Size error\n") if @$lm != @$rm;
return [ number => sum map { $lm->[$_] * $rm->[$_] } 0..$#$lm
+ ];
}
sub dot_prod {
my ($l, $r) = @_;
my $l_is_num = $l->[0] eq 'number';
my $r_is_num = $r->[0] eq 'number';
if ($l_is_num && $r_is_num) {
my $ln = $l->[1];
my $rn = $r->[1];
return [ number => $ln * $rn ];
}
if (!$l_is_num && !$r_is_num) {
my $lm = $l->[1];
my $rm = $r->[1];
die("Size error\n") if @$lm != @$rm;
return [ matrix => [ map { $lm->[$_] * $rm->[$_] } 0..$#$l
+m ] ];
}
my ($n, $m) = ($l_is_num
? ($l->[1], $r->[1])
: ($r->[1], $l->[1])
);
return [ matrix => [ map { $n * $_ } @$m ] ];
}
}
parse : expr EOF { $item[1] }
#
# expr and expr_ are used instead of the
# following left-recursive rule (because
# P::RD can't handle left-recursion):
#
# expr : expr 'x' term { cross_prod($item[1], $item[3]) }
# | expr '*' term { dot_prod ($item[1], $item[3]) }
# | expr term { dot_prod ($item[1], $item[2]) }
# | term
#
expr : term expr_[ $item[1] ]
expr_ : 'x' <commit> term expr_[ cross_prod($arg[0], $item[3]) ]
| '*' <commit> term expr_[ dot_prod ($arg[0], $item[3]) ]
| term <commit> expr_[ dot_prod ($arg[0], $item[1]) ]
| { $arg[0] }
term : '(' <commit> expr ')' { $item[3] }
| '{' <commit> mbody '}' { [ matrix => $item[3] ] }
| NUMBER { [ number => $item[1] ] }
mbody : <leftop: NUMBER ',' NUMBER>
# Tokens
NUMBER : /\d+/ { 0+$item[1] }
EOF : /\Z/
__END_OF_GRAMMAR__
Parse::RecDescent->Precompile($grammar, 'Grammar')
or die("Bad grammar\n");
#!/usr/bin/perl
# test.pl
use strict;
use warnings;
use Data::Dumper qw( Dumper );
use Grammar qw( );
my $parser = Grammar->new();
foreach (
'4',
'4 5',
'4 5 6',
'4*5*6',
'{1}',
'{1,2}',
'4{1,2}',
'4{1,2}5',
'{1,2}{3,4}',
'{1,2}*{3,4}',
'{1,2}{3,4}5',
'{1,2}{3,4}{5,6}',
'{1,2}x{3,4}',
'3{1,2}x{3,4}',
'3x5',
'3x{1,2}',
'{1,2}x3',
'{1,2}x{3,4,5}',
'{1,2}{3,4,5}',
'{1,2}x3{4,5}',
'{1,2}x(3{4,5})',
) {
my $rv = eval { $parser->parse($_) };
my $e = $@;
if ($e) {
$rv = "$_ = $e";
$rv =~ s/\n\z//;
} elsif (!defined($rv)) {
$rv = "$_ = Bad Expression";
} else {
local $Data::Dumper::Indent = 0;
$rv = Dumper($rv->[1]);
substr($rv, -1, 1, '');
substr($rv, 0, 5, $_);
}
print("$rv\n");
}
Output
4 = 4
4 5 = 20
4 5 6 = 120
4*5*6 = 120
{1} = [1]
{1,2} = [1,2]
4{1,2} = [4,8]
4{1,2}5 = [20,40]
{1,2}{3,4} = [3,8]
{1,2}*{3,4} = [3,8]
{1,2}{3,4}5 = [15,40]
{1,2}{3,4}{5,6} = [15,48]
{1,2}x{3,4} = '11'
3{1,2}x{3,4} = '33'
3x5 = Type error
3x{1,2} = Type error
{1,2}x3 = Type error
{1,2}x{3,4,5} = Size error
{1,2}{3,4,5} = Size error
{1,2}x3{4,5} = Type error
{1,2}x(3{4,5}) = '42'
Update: Since I calculate as I go along instead of build a parse tree, Grammar and parse should be renamed (possibly to Evaluator and evalutate).
Update: Added a test where parens make a difference.
|