File Coverage

blib/lib/Array/PatternMatcher.pm

Criterion	Covered	Total	%
statement	179	194	92.2
branch	56	66	84.8
condition	21	30	70.0
subroutine	25	26	96.1
pod	0	20	0.0
total	281	336	83.6

package Array::PatternMatcher;

require 5.005_62;
use strict;
use warnings;
use diagnostics;

require Exporter;

our @ISA = qw(Exporter);



use Carp::Datum qw(:all on);
#use Carp::Datum;

#DLOAD_CONFIG(-config => "all(on)");
#DLOAD_CONFIG(-config => "all(off)");
#DLOAD_CONFIG(-config => "all(yes)");
#DLOAD_CONFIG(-config => "all(no)");
#DLOAD_CONFIG(-config => $ENV{Array_PatternMatcher_Trace});

use Data::Dumper;
use Storable;
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Array::PatternMatcher ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(pat_match rest subseq

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);
our $VERSION = '0.04';


# Preloaded methods go here.



=head1 NAME

Array::PatternMatcher - Pattern matching for arrays.

=head1 SYNOPSIS

This section inlines the entire test suite. Please excuse the ok()s.

 use Array::PatternMatcher;

=head2 Matching logical variables to input stream

 #  1 - simple match of logical variable to input
 my $pattern = 'AGE' ;
 my $input   = 969 ;
 my $result = pat_match ($pattern, $input, {} ) ;
 ok($result->{AGE}, 969) ;

 # 2 - if binding exists, it must equal the input
 $input = 12;
 my $new_result = pat_match ($pattern, $input, $result) ;
 ok(!defined($new_result)) ;

 # 3 - bind the pattern logical variables to the input list

 $pattern = [qw(X   Y)] ;
 $input   = [   77, 45 ] ;
 my $result = pat_match ($pattern, $input, {} ) ;
 ok($result->{X}, 77) ;

=head2 Matching segments (quantifying) portions of the input stream

 # 1
 {
     my $pattern = ['a', [qw(X *)], 'd'] ;
     my $input   = ['a', 'b', 'c',  'd'] ;

     my $result = pat_match ($pattern, $input, {} ) ;
     ok ("@{$result->{X}}","b c") ;
 }

 # 2
 {

     my $pattern = ['a', [qw(X *)], [qw(Y *)], 'd'] ;
     my $input   = ['a', 'b', 'c', 'd'] ;
     my $result = pat_match ($pattern, $input, {} ) ;
     ok ("@{$result->{Y}}","b c") ;

 }
 # 3
 {
     my $pattern = ['a', [qw(X +)], 'd'] ;
     my $input   = ['a', 'b', 'c',  'd'] ;
     ok ("@{$result->{X}}","b c") ;
 }
 # 4
 {
     my $pattern = [ 'a', [qw(X ?)], 'c' ] ;
     my $input   = [ 'a', 'b',       'c' ] ;
     my $result = pat_match ($pattern, $input, {} ) ;
     ok ("$result->{X}","b") ;
 }
 # 5
 {
     my $pattern = [ qw(X OP Y is Z),
 	    [
 	      sub { "($_->{X} $_->{OP} $_->{Y}) == $_->{Z}" },
 		'IF?'
 	      ]
 	   ] ;
     my $input   = [qw(3 + 4 is 7) ] ;
     my $result = pat_match ($pattern, $input, {} ) ;
     ok ($result) ;
 }

=head2 Single-matching:

 Take a single input and a series of patterns and decide which pattern
 matches the input:

 # 1 - Here all input patterns must match the input

 {
 my @pattern ;
 push @pattern, [ qw(X  Y)  ] ;
 push @pattern, [ qw(22 Z ) ] ;
 push @pattern, [ qw(M  33) ] ;

 my $input    = [ qw(22 33) ] ;

 my $meta_pattern = [ 'AND?', \@pattern ] ;

 # if no bindings, add a binding between pattern and input
 my $result = pat_match ($meta_pattern, $input, {} ) ;
 ok ($result->{Z},33) ;
 }

 # 2 - Here, any one of the patterns must match the input

 {
 my @pattern ;
 push @pattern, [ qw(99  22)  ] ;
 push @pattern, [ qw(33 22) ] ;
 push @pattern, [ qw(44 3) ] ;
 push @pattern, [ qw(22 Z) ] ;

 my $input    = [ qw(22 33) ] ;

 my $meta_pattern = [ 'OR?', \@pattern ] ;

 # if no bindings, add a binding between pattern and input
 my $result = pat_match ($meta_pattern, $input, {} ) ;
 ok ($result->{Z},33) ;
 }

 # 3 - Here, none of the patterns must match the input

 {
     my @pattern ;
     push @pattern, [ qw(99  22)  ] ;
     push @pattern, [ qw(33 22) ] ;
     push @pattern, [ qw(44 3) ] ;
     push @pattern, [ qw(22 Z) ] ;

     my $input    = [ qw(22 33) ] ;

     my $meta_pattern = [ 'NOT?', \@pattern ] ;

 # if no bindings, add a binding between pattern and input
     my $result = pat_match ($meta_pattern, $input, {} ) ;
     ok (scalar keys %$result == 0) ;
 }

 # 4 - here the input must satisfy the predicate
 {
 sub numberp { $_[0] =~ /\d+/ }

 my $pattern = [ qw(X    age), [qw(IS? N), \&numberp] ] ;
 my $input   = [ qw(Mary age),     'thirty-four'      ] ;

 # if no bindings, add a binding between pattern and input
 my $result = pat_match ($pattern, $input, {} ) ;
 ok (!defined($result));
 }

 # 5 - same thing, but this time a failing result --- ''
 # not undef because it is the return val of numberp
 {
 sub numberp { $_[0] =~ /\d+/ }

 my $pattern = [ qw(X    age), [qw(IS? N), \&numberp] ] ;
 my $input   = [ qw(Mary age),     34                ] ;
 my $result  = pat_match ($pattern, $input, {} ) ;

 ok ($result->{N},34) ;
 }

=head2 Segment-matching:

 Match a chunk of the input stream using *, +, ?

 # 1 - * is greedy in this case, but not with 2 consecutve * patterns
 {
     my $pattern = ['a', [qw(X *)], 'd'] ;
     my $input   = ['a', 'b', 'c',  'd'] ;

 # if no bindings, add a binding between pattern and input
     my $result = pat_match ($pattern, $input, {} ) ;
     warn sprintf "X*RETVAL: %s", Data::Dumper::Dumper($result) ;
     ok ("@{$result->{X}}","b c") ;
 }
 # 2 - X* gets nothing, Y* gets all it can:
 {

     my $pattern = ['a', [qw(X *)], [qw(Y *)], 'd'] ;
     my $input   = ['a', 'b', 'c', 'd'] ;

 # if no bindings, add a binding between pattern and input
     my $result = pat_match ($pattern, $input, {} ) ;
     warn sprintf "X*Y*RETVAL: %s", Data::Dumper::Dumper($result) ;
     ok ("@{$result->{Y}}","b c") ;

 }
 # 3 - samething , but require at least one match for X
 {
     my $pattern = ['a', [qw(X +)], 'd'] ;
     my $input   = ['a', 'b', 'c',  'd'] ;

     my $result = pat_match ($pattern, $input, {} ) ;
     warn sprintf "RETVAL: @{$result->{X}}" ;
     ok ("@{$result->{X}}","b c") ;
 }
 # 4 - require 0 or 1 match for X
 {
     my $pattern = [ 'a', [qw(X ?)], 'c' ] ;
     my $input   = [ 'a', 'b',       'c' ] ;


     my $result = pat_match ($pattern, $input, {} ) ;

     ok ("$result->{X}","b") ;
 }
 # 5 - evaluate a sub on the fly after match
 {
     my $pattern = [ qw(X OP Y is Z),
 	    [
 	      sub { "($_->{X} $_->{OP} $_->{Y}) == $_->{Z}" },
 		'IF?'
 	      ]
 	   ] ;
     my $input   = [qw(3 + 4 is 7) ] ;

     my $result = pat_match ($pattern, $input, {} ) ;

     ok ($result) ;
 }
 # --- 6 same thing, but fail
 {
     my $pattern = [ qw(X OP Y is Z),
 	    [
 	      sub { "($_->{X} $_->{OP} $_->{Y}) == $_->{Z}" },
 		'IF?'
 	      ]
 	   ] ;
     my $input   = [qw(3 + 4 is 8) ] ;

     my $result = pat_match ($pattern, $input, {} ) ;
     warn sprintf "IF_RETVAL2: *%s*", Data::Dumper::Dumper($result);
     ok ($result eq '') ;
 }


=head1 DESCRIPTION

Array::PatternMatcher is based directly on the pattern matcher in
Peter Norvig's excellent text
"Paradigms of AI Programming: Case Studies in Common Lisp".

All in all, it basically offers a different way to work with an array.
Instead of manually indexing into the array and using if-thens to
validate and otherwise characterize the array, you can use
pattern-matching instead.

=head2 EXPORT

None by default.

use Array::PatternMatcher qw(:all) exports pat_match(), rest(), subseq()

=head1 Description of Pattern Matching

The pattern-matching routine, pat-match, takes 3 arguments, a pattern,
an input, and a set of "bindings".

The input is an array ref of constants:

  my $input_1 = [qw(how   is it going   dude) ] ;
  my $input_2 = [qw(where is it going   dude) ] ;
  my $input_3 = [qw(when  is it going   pal) ] ;
  my $input_4 = [qw(when  is it flying  chum) ] ;
  my $input_5 = [qw(how   is it hanging homeboy) ] ;

The pattern is your spec on how you expect to match the input:

  my $pattern = [qw(ADJECTIVE is it VERB OBJECT)] ;

=head2 Valid pattern elements:

=over 4

=item 1 a variable

=item 2 a constant (a string or number)

=item 3 a segment pattern

=item 4 a meta-pattern to applied to the input

=item 5 an array ref whose array consists of items 1 .. 4

=back


The bindings is a hashref consisting of all logical variables
bound during the matching of the input to the pattern. Thus:

 use Array::PatternMatcher qw(:all);
 {
 my $b1 =  pat_match  $pattern, $input_1, {} ;

 # yields these bindings
 { ADJECTIVE => 'how', VERB => 'going, OBJECT => 'dude' }
 }
Skipping to input_4:
 {
 my $b1 =  pat_match  $pattern, $input_1, {} ;

 # yields these bindings
 { ADJECTIVE => 'when', VERB => 'flying', OBJECT => 'chum' }
 }


Please see the synopsis for comprehensive usage examples.

=head1 BUGS

Please report them, if possible submitting a test case similar to the
ones in the /t directory.

=head1 AUTHOR

Terrence M. Brannon, [e-mail]

=cut


sub match_variable {
    DFEATURE my $f_;
    my ($var,$input,$bindings) = @_;
    my $binding = $bindings->{$var} ;
    if (!$binding) {
	DTRACE "no bindings for $var. extending and setting equal to %s", Data::Dumper::Dumper($input);
	$bindings->{$var} = $input ;
	return DVAL $bindings;
    } elsif ($binding eq $input) { # this equal will be inadequate for lists
	DTRACE "binding for $var with $input already exists";
	return DVAL $bindings ;
    } else {
	return DVOID ;
    }
}

sub subseq {
    DFEATURE my $f_;
    my ($input,$start,$end) = @_;

    my $max = $#$input ;
    $end = defined($end) ? $end : $max ;

    DTRACE "subseq_start: $start end: $end max: $max";

    [ @{$input}[$start..$end] ] ;

}

sub atomic {
    DFEATURE my $f_;
    my $pat = shift ;

    if (ref($pat) eq 'ARRAY') { return DVOID }
    return DVAL 1;
}

sub is_variable {
    DFEATURE my $f_;

    my $p = shift;

    if (ref($p)) {
	return DVOID;
    } else {
	my $r = ($p =~ /^[A-Z][A-Z0-9]*$/) ;
	return DVAL $r ;
    }
}


sub first_match_pos {
    DFEATURE my $f_;
    my ($pattern, $input, $start) = @_;

    $start = int($start) if (!defined($start));

    DTRACE sprintf "first_match_pos_pattern: %s", Data::Dumper::Dumper($pattern);
    DTRACE sprintf "first_match_pos_input: %s", Data::Dumper::Dumper($input);
    DTRACE sprintf "first_match_pos_start: %s", Data::Dumper::Dumper($start);

    if ((atomic $pattern) && (!is_variable($pattern))) {
	# look for first place that pattern equals input
	for (my $i = $start; $i <= $#$input; ++$i) {
	    if ($pattern eq $input->[$i]) {
		return DVAL $i;
	    }
	}
	return DVAL undef;
    }
    elsif ($start < @$input) {
	return DVAL $start;
    }
}
sub rest {
    DFEATURE my $f_;
    my $aref = shift;
    my @ary  = @$aref;

    if (@$aref == 1) {
	return DVAL undef ;
    }

    if (@$aref > 1) {
	splice @ary, 0, 1;
	return DVAL \@ary;
    }

}

sub segment_match {
    DFEATURE my $f_;
    my ($pattern, $input, $bindings, $start) = @_;
    my $var = $pattern->[0]->[0] ;
    my $pat = rest $pattern ;

    if (!defined($pat)) {
	DTRACE "not defined pat";
	return DVAL match_variable($var,$input,$bindings) ;
    } else {
	DTRACE "    defined pat";
	my $pos = first_match_pos($pat->[0], $input, $start) ;

	if (!defined($pos)) {
	    DTRACE "no first match pos";
	    return DVAL undef;
	} else {
	    DTRACE "there is a first match pos ($pos)";
	    # if it does have a match
	    my $match_variable_subseq_end = (!$pos) ? 0 : $pos - 1 ;
	    my $b2 = pat_match($pat, subseq($input,$pos),
			       match_variable($var, subseq($input,0,$match_variable_subseq_end), $bindings));
	    if ($b2) {
		DTRACE "found our match ($b2)";
		return DVAL $b2;
	    } else {
		DTRACE "incrementing and attempting again";
		return DVAL (segment_match($pattern, $input, $bindings,
			     (1+$pos)));
	    }
	}
    }
}

sub segment_match_plus {
    DFEATURE my $f_;
    my ($pattern, $input, $bindings) = @_;
    return DVAL segment_match $pattern, $input, $bindings, 1 ;
}

sub segment_match_optional {
    DFEATURE my $f_;
    my ($pattern, $input, $bindings) = @_ ;
    my $var = $pattern->[0][0] ;
    my $pat = rest $pattern ;

    return DVAL (
		 (pat_match ( [($var, @$pat)], $input, $bindings) ) ||
		 (pat_match            $pat  , $input, $bindings)
		 ) ;
}


sub pat_match ;
sub single_match_is {
    DFEATURE my $f_;
    my ($is_var_and_pred, $input, $bindings) = @_ ;

    DTRACE "INPUT ", Data::Dumper::Dumper(\@_) ;
    my ($var,$pred)  = ($is_var_and_pred->[1],$is_var_and_pred->[2]) ;
    my $new_bindings = pat_match $var, $input, $bindings ;
    DTRACE "NEW_BINDINGS ", Data::Dumper::Dumper($new_bindings) ;

    if (!defined($new_bindings) or !defined($pred->($input))) {
	DTRACE "pred FAILED";
	return DVOID ;
    } else {
	my $result = $pred->($input) ;
	DTRACE "pred result: $result";
	if ($result) {
	    return DVAL $bindings ;
	} else {
	    return DVOID;
	}
    }
}

sub single_match_or ;
sub single_match_not {
    DFEATURE my $f_;

    my ($pattern,$input,$bindings) = @_;
    my $o = single_match_or $pattern, $input, $bindings ;
    if ($o) {
	return DVOID ;
    } else {
	return DVAL $bindings ;
    }
}

sub match_or;
sub single_match_or {
    DFEATURE my $f_;

    my ($pattern,$input,$bindings) = @_;

    DTRACE "smor_input: ", Data::Dumper::Dumper($input) ;

    if (!defined($pattern) or (scalar @$pattern == 0)) { return DVOID }
    my $input_copy = Storable::dclone($input);
    my $rest_pattern = rest $pattern;
    my $new_bindings = pat_match $pattern->[0], $input, $bindings ;
    if (!defined($new_bindings)) {
	my $r = single_match_or $rest_pattern, $input_copy, $bindings ;
    } else {
	return DVAL $new_bindings ;
    }
}

sub single_match_and {
    DFEATURE my $f_;

    my ($meta_pattern,$input,$bindings) = @_;
    DTRACE "single_match_and meta_p: i: b:", Data::Dumper::Dumper($meta_pattern,$input,$bindings) ;

    if (!defined($bindings)) { return DVOID }
    if (!defined($meta_pattern) or !@$meta_pattern) { return DVAL $bindings }
    my $rest_meta_pattern = rest $meta_pattern ;

    my $input_copy = [ @$input ] ;
    my $f = pat_match $meta_pattern->[0], $input, $bindings ;
    DTRACE sprintf "and_first gave this: %s now we work with these: %s,%s",
          Data::Dumper::Dumper($f),
          Data::Dumper::Dumper($rest_meta_pattern),
          Data::Dumper::Dumper($input_copy) ;
    my $ret = single_match_and ($rest_meta_pattern, $input_copy, $f) ;

    return DVAL $ret ;
}


sub segment_match_if {
    DFEATURE my $f_;
    my ($pattern, $input, $bindings) = @_ ;

    DTRACE "p: i: b:", Data::Dumper::Dumper($pattern,$input,$bindings) ;


    local $_ = $bindings ;

    return DVAL eval $pattern->[0]->[0]->() ;

}

our %segment_dispatch =
(
 '*'  => \&segment_match,
 '+'  => \&segment_match_plus,
 '?'  => \&segment_match_optional,
 'IF?' => \&segment_match_if
 ) ;

our %single_dispatch =
(
 'IS?'  => \&single_match_is,
 'AND?' => \&single_match_and,
 'OR?'  => \&single_match_or,
 'NOT?' => \&single_match_not,
 ) ;


sub is_array_ref {
    DFEATURE my $f_;
    return DVAL ref ($_[0]) eq 'ARRAY';
}
sub is_code_ref {
    DFEATURE my $f_;
    return DVAL ref ($_[0]) eq 'CODE';
}



sub segment_match_fn {
    my $x = shift;
    DTRACE "dispatching on $x";
    my $fn = $segment_dispatch{$x} ;
    return $fn;
}

sub is_single_pattern {
    DFEATURE my $f_;
#    warn "@_" , Data::Dumper::Dumper(\@_) ;
    my $term_aref = $_[0] ;
    if (is_array_ref($term_aref)) {
	DTRACE "dispatching on", Data::Dumper::Dumper($term_aref->[0]);
	return DVAL $single_dispatch{$term_aref->[0]} ;
    } else {
	return DVOID ;
    }

}

sub is_segment_pattern {
    DFEATURE my $f_;
    my $pat = shift;
    DTRACE "is_segment_pattern ", Data::Dumper::Dumper($pat) ;
    my $a = is_array_ref($pat) ;
    my $first = $a ? $pat->[0] : undef ;
    my $a2 = is_array_ref($first) ;

    return undef unless ($a && $a2) ;

    DTRACE "hi there $first->[1]" ;

    my $s = segment_match_fn($first->[1]) ;

    DTRACE "s $s" ;

    if ($s) {
	return  $s ;
    } else {
	return undef ;
    }

}



sub pat_match {
    DFEATURE my $f_;

    my ($pattern, $input, $bindings) = @_;

    DTRACE "pattern,input,bindings", Data::Dumper::Dumper($pattern,$input,$bindings) ;

    if (!defined($bindings))   { return DVOID }
    if (is_variable($pattern)) { return DVAL match_variable(@_) }
    if (my $segment_matcher = is_segment_pattern($pattern)) {
	return DVAL $segment_matcher->(@_) ;
    }

    if (my $single_matcher = is_single_pattern($pattern)) {
	if (($pattern->[0] eq 'AND?') or ($pattern->[0] eq 'OR?')) {
	    DTRACE sprintf "p0: %s p1: %s p2: %s", Data::Dumper::Dumper($pattern->[0]), Data::Dumper::Dumper($pattern->[1]), Data::Dumper::Dumper($pattern->[2]) ;
	    # remove AND? and the entire outer list
	    $pattern = $pattern->[1] ;
	}
	return DVAL $single_matcher->($pattern,$input,$bindings) ;
    }

    if ( (
	  (ref($pattern) eq 'ARRAY') &&
	  (ref($input)   eq 'ARRAY') &&
	  (@$pattern) && (@$input)
	  )
	 ) {
	DTRACE "handling first and rest" ;
	my $b = pat_match($pattern->[0], $input->[0], $bindings) ;
	my $newer_binds  = pat_match((rest $pattern), (rest $input), $b);
	DTRACE "new binds($newer_binds)", Data::Dumper::Dumper($newer_binds) ;
	return DVAL $newer_binds;
	}
    if ($pattern eq $input) {
	DTRACE "$pattern eq $input ... returning bindings($bindings)";
	return DVAL $bindings ;
    }
    return DVOID ;
}

=head1 AUTHOR

T.M. Brannon

=head1 SEE ALSO

L,
L, L

=cut

1;
__END__