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