Last active
December 11, 2015 20:59
-
-
Save pstuifzand/4659225 to your computer and use it in GitHub Desktop.
Parse -> Rewrite tree -> Serialize
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
package RR; | |
use strict; | |
use Marpa::R2 2.042000; | |
use Data::Dumper; | |
use base 'Exporter'; | |
our @EXPORT_OK = qw/replace/; | |
sub new { | |
my ($class) = @_; | |
my $self = bless {}, $class; | |
$self->{grammar} = Marpa::R2::Scanless::G->new( | |
{ | |
action_object => 'RR::Actions', | |
default_action => 'do_first_arg', | |
source => \(<<'END_OF_SOURCE'), | |
:start ::= script | |
script ::= expression | |
| script ';' expression action => do_arg02 | |
expression ::= number action => do_num | |
| variable action => do_var | |
| tree_var action => do_tree_var | |
| '(' expression ')' assoc => group action => do_arg1 | |
| expression '(' args ')' action => do_func | |
|| expression '*' expression action => do_expr | |
| expression '/' expression action => do_expr | |
|| expression '+' expression action => do_expr | |
| expression '-' expression action => do_expr | |
args ::= expression* action => do_list separator => comma | |
comma ~ ',' | |
number ~ [\d]+ | |
tree_var ~ ':' tree_var_1 | |
variable ~ [a-z]+ | |
tree_var_1 ~ [a-z]+ | |
:discard ~ whitespace | |
whitespace ~ [\s]+ | |
END_OF_SOURCE | |
} | |
); | |
return $self; | |
} | |
sub parse { | |
my ($self, $string) = @_; | |
my $re = Marpa::R2::Scanless::R->new( { grammar => $self->{grammar} } ); | |
$re->read(\$string); | |
my $value_ref = $re->value(); | |
return ${$value_ref}; | |
} | |
sub parse_rr { | |
my ($string) = @_; | |
my $parser = RR->new(); | |
return $parser->parse($string); | |
} | |
sub _expr_match { | |
my ($a, $b, $matches) = @_; | |
if ($a->[0] eq $b->[0]) { | |
if ($a->[0] eq 'num') { | |
return $a->[1] == $b->[1]; | |
} | |
elsif ($a->[0] eq 'var') { | |
return $a->[1] eq $b->[1]; | |
} | |
elsif ($a->[0] eq 'func') { | |
if (!_expr_match($a->[1], $b->[1], $matches)) { | |
return; | |
} | |
for (0 .. (scalar(@{$a->[2]})-1)) { | |
if (!_expr_match($a->[2][$_], $b->[2][$_], $matches)) { | |
return; | |
} | |
} | |
return 1; | |
} | |
elsif ($a->[0] eq 'op') { | |
return $a->[1] eq $b->[1] | |
&& ((_expr_match($a->[2], $b->[2], $matches) && _expr_match($a->[3], $b->[3], $matches)) | |
|| | |
(_expr_match($a->[2], $b->[3], $matches) && _expr_match($a->[3], $b->[2], $matches))) | |
} | |
} | |
elsif ($a->[0] eq 'tree') { | |
$matches->{$a->[1]} = $b; | |
return 1; | |
} | |
elsif ($b->[0] eq 'tree') { | |
$matches->{$b->[1]} = $a; | |
return 1; | |
} | |
return; | |
} | |
sub _replace_matches { | |
my ($matches, $tree) = @_; | |
for (keys %$matches) { | |
$tree = _replace_helper($tree, ['tvar', $_ ], $matches->{$_}, $matches); | |
} | |
return $tree; | |
} | |
sub _replace_helper { | |
my ($tree, $ft, $tt, $matches) = @_; | |
my $type = $tree->[0]; | |
if ($type eq 'num') { | |
if (_expr_match($tree, $ft, $matches)) { | |
return $tt; | |
} | |
return $tree; | |
} | |
elsif ($type eq 'var') { | |
if (_expr_match($tree, $ft, $matches)) { | |
return $tt; | |
} | |
return $tree; | |
} | |
elsif ($type eq 'op') { | |
if (_expr_match($tree, $ft, $matches)) { | |
return _replace_matches($matches, $tt); | |
} | |
return [ $type, $tree->[1], | |
_replace_helper($tree->[2], $ft, $tt, $matches), | |
_replace_helper($tree->[3], $ft, $tt, $matches) | |
]; | |
} | |
elsif ($type eq 'func') { | |
if (_expr_match($tree, $ft, $matches)) { | |
if ($tt->[0] ne 'func') { | |
return _replace_matches($matches, $tt); | |
} | |
my @args; | |
for (0 .. (scalar(@{$tt->[2]})-1)) { | |
$args[$_] = _replace_matches($matches, $tt->[2][$_]); | |
} | |
return [ 'func', _replace_matches($matches, $tt->[1]), \@args ]; | |
} | |
my @args; | |
for (0 .. (scalar(@{$tree->[2]})-1)) { | |
$args[$_] = _replace_helper($tree->[2][$_], $ft, $tt, $matches); | |
} | |
return [ 'func', _replace_helper($tree->[1], $ft, $tt, $matches), \@args ]; | |
} | |
elsif ($type eq 'tree') { | |
if ($tree->[0] eq 'tree' && $ft->[0] eq 'tvar' && $tree->[1] eq $ft->[1]) { | |
return $tt; | |
} | |
return $tree; | |
} | |
elsif ($type eq 'line') { | |
return [ 'line', | |
_replace_helper($tree->[1], $ft, $tt, $matches), | |
_replace_helper($tree->[2], $ft, $tt, $matches), | |
]; | |
} | |
die "Unknown type $type"; | |
} | |
sub replace { | |
my ($source, $from, $to) = @_; | |
my $st = parse_rr($source); | |
my $ft = parse_rr($from); | |
my $tt = parse_rr($to); | |
my %matches; | |
my $tree = _replace_helper($st, $ft, $tt, \%matches); | |
return serialize($tree); | |
} | |
sub serialize { | |
my ($tree) = @_; | |
my @node = @$tree; | |
my $type = shift @node; | |
if ($type eq 'num') { | |
return $node[0]; | |
} | |
elsif ($type eq 'var') { | |
return $node[0]; | |
} | |
elsif ($type eq 'op') { | |
my $l = serialize($node[1]); | |
my $r = serialize($node[2]); | |
return '(' . join (' ', $l.$node[0].$r) . ')'; | |
} | |
elsif ($type eq 'tree') { | |
return $node[0]; | |
} | |
elsif ($type eq 'func') { | |
return serialize($node[0]) . '('.join(", ", map{ serialize($_) } @{$node[1]}).')'; | |
} | |
elsif ($type eq 'line') { | |
return serialize($node[0]) .";\n".serialize($node[1]); | |
} | |
die "Unknown type $type"; | |
} | |
package RR::Actions; | |
use strict; | |
use Data::Dumper; | |
sub new { | |
my ($class) = @_; | |
return bless {}, $class; | |
} | |
sub do_first_arg { | |
shift; | |
return $_[0]; | |
} | |
sub do_num { | |
shift; | |
return [ 'num', $_[0] ]; | |
} | |
sub do_var { | |
shift; | |
return [ 'var', $_[0] ]; | |
} | |
sub do_tree_var { | |
shift; | |
return [ 'tree', $_[0] ]; | |
} | |
sub do_expr { | |
shift; | |
return [ 'op', $_[1], $_[0], $_[2] ]; | |
} | |
sub do_list { | |
shift; | |
return \@_; | |
} | |
sub do_null { | |
return undef; | |
} | |
sub do_join { | |
shift; | |
return join '', @_; | |
} | |
sub do_func { | |
shift; | |
return [ 'func', $_[0], $_[2] ]; | |
} | |
sub do_arg1 { | |
shift; | |
return $_[1]; | |
} | |
sub do_arg02 { | |
shift; | |
return ['line', $_[0], $_[2]]; | |
} | |
1; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
use RR 'replace'; | |
my $source = <<"SOURCE"; | |
10 + 1000 * power(10*x,n) | |
SOURCE | |
my $newsource = replace($source, '10+:a', '22+:a'); | |
print replace($newsource, ':a(100)', 'h(10)') . "\n"; | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment