Ann: Array::PatternMatcher - Pattern matching for arrays.

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 se All patterns can be classified into one of five
    cases.

    1 a variable
    2 a constant
    3 a segment pattern
    4 a single-element pattern
    5 a list consisting of items 1 .. 4
  match_is

    Succeed and bind var if the input satisfies pred, where var_and_pred is
    the list [var, pred].

AUTHOR
    T.M. Brannon <[email protected]>

SEE ALSO
    perl(1).