The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
 / 
Array-PatternMatcher-0.04
River stage zero No dependents
++
/ Array::PatternMatcher

NAME

Array::PatternMatcher - Pattern matching for arrays.

SYNOPSIS

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

 use Array::PatternMatcher;

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) ;

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) ;
 }

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) ;
 }

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 '') ;
 }

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.

EXPORT

None by default.

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

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)] ;

Valid pattern elements:

1 a variable
2 a constant (a string or number)
3 a segment pattern
4 a meta-pattern to applied to the input
5 an array ref whose array consists of items 1 .. 4

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.

BUGS

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

AUTHOR

Terrence M. Brannon, tbone@cpan.org

AUTHOR

T.M. Brannon <tbone@cpan.org>

SEE ALSO

Data::Walker, Data::Match, Data::Compare