Announce: Array::PatternMatcher
[email protected] (Terrence Brannon)
| Newsgroups | perl.ai |
|---|---|
| Message-ID | <[email protected]> |
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, [email protected]
AUTHOR
T.M. Brannon <[email protected]>
SEE ALSO
perl(1).