Math::Symbolic::Custom::Pattern - Pattern matching on Math::Symbolic trees

  use Math::Symbolic qw/parse_from_string/;
  use Math::Symbolic::Custom::Pattern;
  my $patternstring = "VAR_foo + sin(CONST * VAR_foo)"
  my $pattern = Math::Symbolic::Custom::Pattern->new( $patternstring );

  my $formula = parse_from_string("a + sin(5 * a)");

  if ($pattern->match($formula)) {
    print "The pattern matches the formula.\n";
  }
  else {
    print "The pattern does not match the formula.\n";
  }

  # will print "The pattern matches the formula" since "a" is
  # found to be "VAR_foo" and 5 is a constant.
  # "a + sin(5 * b)" would not match since VAR_foo is already "a"
  # when the "b" is encountered. "VAR" would match any variable.
  # "TREE" matches any tree. "TREE_name" and "CONST_name" work as
  # you would expect.

  # Alternatively:
  my $pattern = $some_formula->to_pattern();

  print "yes\n" if $formula->is_of_form($pattern); # fast-ish
  # This has syntactic sugar, too:
  print "yes\n" if $formula->is_of_form("VAR + TREE"); # slow!
  print "yes\n" if $formula->is_of_form($another_formula); # semi-slow...

  # Finally, when creating a pattern, one can specify that addition and
  # product should match commutatively:
  my $pattern = Math::Symbolic::Custom::Pattern->new(
    parse_from_string("a + b"), commutation => 1,
  );
  my $formula = parse_from_string("b + a");
  # does match even though "a+b" <=> "b+a" aren't the same
  # internal tree representations
  print "yes\n" if $pattern->match($formula);

  my $pattern = Math::Symbolic::Custom::Pattern->new("a+(b*c)");

  my $boolean = $pattern->match($tree);

package Math::Symbolic::Custom::Pattern;

use 5.006001;
use strict;
use warnings;
no warnings 'recursion';
use Carp qw/cluck confess/;

use Clone qw/clone/;
use Math::Symbolic qw/:all/;
use Math::Symbolic::Custom::Pattern::Export;

our $VERSION = '2.00';

use constant EPSILON => 1e-29;

use constant TYPE  => 0;
use constant VAL   => 1;
use constant OPS   => 2;
use constant ATTR  => 3;

use constant PATTERN => -1;

use constant ANY_TREE    => 0;
use constant ANY_CONST   => 1;
use constant ANY_VAR     => 2;
use constant NAMED_TREE  => 3;
use constant NAMED_CONST => 4;
use constant NAMED_VAR   => 5;

use constant ATTR_COMMUTATIVE => 1;

sub new {
  my $proto = shift;
  my $class = ref($proto)||$proto;

  # I want to call that 'proto', too ;)
  $proto = shift;
  confess(
    __PACKAGE__."new() requires a Math::Symbolic tree as first "
    ."argument."
  ) if not ref($proto) =~ /^Math::Symbolic/;

  my %opt = @_;

  my $info = {
    vars => {},
    constants => {},
    trees => {},
    commutation => $opt{commutation},
  };
  
  my $pattern = _descend_build($proto, $info);

  #_descend_generalize($pattern, $info);

  my $self = {
    pattern => $pattern,
    info => $info,
    string => $proto->to_string(),
  };

  return bless $self => $class;
}


sub _descend_build {
  my ($proto, $info) = @_;
  
  my $tree = [];
  my $tt   = $proto->term_type();

  if ($tt == T_CONSTANT) {
    $tree->[TYPE] = T_CONSTANT;
    $tree->[VAL]  = $proto->value();
  }
  elsif ($tt == T_OPERATOR) {
    $tree->[TYPE] = T_OPERATOR;
    $tree->[VAL]  = $proto->type();
    $tree->[OPS]  = [
      map { _descend_build($_, $info) }
      @{$proto->{operands}}
    ];
    $tree->[ATTR] = 0;
    $tree->[ATTR] |= ATTR_COMMUTATIVE
      if $info->{commutation} and $Math::Symbolic::Operator::Op_Types[$tree->[VAL]]{commutative};
    # todo: ATTR_CONSTANT?
  }
  else { # variable
    my $name = $proto->name();

    $tree->[TYPE] = PATTERN;
    if ($name eq 'TREE') {
      $tree->[VAL] = ANY_TREE;
    }
    elsif ($name eq 'CONST') {
      $tree->[VAL] = ANY_CONST;
    }
    elsif ($name eq 'VAR') {
      $tree->[VAL] = ANY_VAR;
    }
    elsif ($name =~ /^TREE_(\w+)$/) {
      $tree->[VAL] = NAMED_TREE;
      my @names = split /_/, $1;
      $tree->[OPS] = \@names;
      $info->{trees}{$_}++ for @names;
    }
    elsif ($name =~ /^CONST_(\w+)$/) {
      $tree->[VAL] = NAMED_CONST;
      my @names = split /_/, $1;
      $tree->[OPS] = \@names;
      $info->{constants}{$_}++ for @names;
    }
    elsif ($name =~ /^VAR_(\w+)$/) {
      $tree->[VAL] = NAMED_VAR;
      my @names = split /_/, $1;
      $tree->[OPS] = \@names;
      $info->{vars}{$_}++ for @names;
    }
    else {
      $tree->[TYPE] = T_VARIABLE;
      $tree->[VAL] = $name;
    }
  }

  return $tree;
}

sub match {
  my $self = shift;

  my $tree = shift;
  confess(
    __PACKAGE__."match() requires a Math::Symbolic tree as first "
    ."argument."
  ) if not ref($tree) =~ /^Math::Symbolic/;

  my $info = $self->{info};
  my $info_copy = {
    constants => { map {($_,undef)} keys %{$info->{constants}} },
    vars => { map {($_,undef)} keys %{$info->{vars}} },
    trees => { map {($_,undef)} keys %{$info->{trees}} },
  };
  
  my $okay = _descend_match($self->{pattern}, $tree, $info_copy);
  return $info_copy if $okay;
  return undef;
}

sub _descend_match {
  my ($pat, $tree, $info) = @_;
  
  my $ptype = $pat->[TYPE];
  my $ttype = $tree->term_type();

  if ($ptype == T_CONSTANT) {
    return undef if $ttype != T_CONSTANT;
    return 1 if abs($tree->value()-$pat->[VAL]) < EPSILON;
    return undef;
  }
  elsif ($ptype == T_VARIABLE) {
    return undef if $ttype != T_VARIABLE;
    return 1 if $tree->name() eq $pat->[VAL];
    return undef;
  }
  elsif ($ptype == T_OPERATOR) {
    return undef if $ttype != T_OPERATOR;
    my $optype = $tree->type();
    return undef if $optype != $pat->[VAL];
    
    my @operands = @{$pat->[OPS]};
    my @tree_ops = @{$tree->{operands}};

    return undef if @operands != @tree_ops;
    
    if (($pat->[ATTR] & ATTR_COMMUTATIVE) && @operands > 1) {
      if (@operands == 2) { # use hard coded permutation
        my $ok = _descend_match($operands[0], $tree_ops[0], $info) && _descend_match($operands[1], $tree_ops[1], $info);
        if (!$ok) {
          $ok = _descend_match($operands[0], $tree_ops[1], $info) && _descend_match($operands[1], $tree_ops[0], $info);
        }
        return undef unless $ok;
      }
      else {
        _permute {
          my $ok;
          for (@_) {
            $ok = _descend_match($_->[0], $_->[1], $info);
            last if not $ok;
          }
          $ok
        } map {[$operands[$_], $tree_ops[$_]]} 0..$#operands;
      }
    }
    else { # no commutation
      foreach my $oper_no (0..$#operands) {
        my $ok = _descend_match($operands[$oper_no], $tree_ops[$oper_no], $info);
        return undef unless $ok;
      }
    }
    return 1;
  }
  elsif ($ptype == PATTERN) {
    my $match = $pat->[VAL];
    if ($match == ANY_TREE) {
      return 1;
    }
    elsif ($match == ANY_CONST) {
      my $ttype = $tree->term_type();
      return $ttype == T_CONSTANT ? 1 : undef;
    }
    elsif ($match == ANY_VAR) {
      my $ttype = $tree->term_type();
      return $ttype == T_VARIABLE ? 1 : undef;
    }
    elsif ($match == NAMED_TREE) {
      my @names = @{$pat->[OPS]};
      my $itrees = $info->{trees};
      foreach my $name (@names) {
        die "tree name '$name' should exist, but does not. "
          ."Internal error."
          if not exists $itrees->{$name};
        
        my $itree = $itrees->{$name};
        if (defined $itree) {
          my $ok = $itree->is_identical($tree);
          return 1 if $ok;
        }
        else {
          $itrees->{$name} = $tree;
          return 1;
        }
      }
      return undef;
    }
    elsif ($match == NAMED_CONST) {
      return undef unless $ttype == T_CONSTANT;
      
      my @names = @{$pat->[OPS]};
      my $iconsts = $info->{constants};
      foreach my $name (@names) {
        die "constant name '$name' should exist, but does not. "
          ."Internal error."
          if not exists $iconsts->{$name};
        
        my $iconst = $iconsts->{$name};
        if (defined $iconst) {
          my $ok = $iconst == $tree->value();
          return 1 if $ok;
        }
        else {
          $iconsts->{$name} = $tree->value();
          return 1;
        }
      }
      return undef;
    }
    elsif ($match == NAMED_VAR) {
      return undef unless $ttype == T_VARIABLE;
      
      my @names = @{$pat->[OPS]};
      my $ivars = $info->{vars};
      foreach my $name (@names) {
        die "variable name '$name' should exist, but does not. "
          ."Internal error."
          if not exists $ivars->{$name};
        
        my $ivar = $ivars->{$name};
        if (defined $ivar) {
          my $ok = $ivar eq $tree->name();
          return 1 if $ok;
        }
        else {
          $ivars->{$name} = $tree->name();
          return 1;
        }
      }
      return undef;
    }
    else {
      die "Internal error: Invalid pattern type '$match'";
    }
    
  }
  else {
    die "Invalid pattern type with number $ptype.";
  }
}

# Fischer-Krause ordered permutation generator adapted from perlfaq4
sub _permute (&@) {
  my $code = shift;
  my @idx = 0..$#_;
  while ( not $code->(@_[@idx]) ) {
    my $p = $#idx;
    --$p while $idx[$p-1] > $idx[$p];
    my $q = $p or return;
    push @idx, reverse splice @idx, $p;
    ++$q while $idx[$p-1] > $idx[$q];
    @idx[$p-1,$q]=@idx[$q,$p-1];
  }
}

sub to_string {
    my $self = shift;
    return $self->{string};
}

1;
__END__