Permalink
Browse files

base BinaryFP class pattern matching

  • Loading branch information...
1 parent eff343f commit 683451a2af79bfb7fc4a9afc3e5ec845116220f7 Hakim Cassimally committed May 29, 2011
Showing with 119 additions and 21 deletions.
  1. +82 −19 scratch/perl/text-piecetable/lib/Tree/BinaryFP.pm
  2. +37 −2 scratch/perl/text-piecetable/t/04-tree-fp.t
@@ -1,8 +1,10 @@
package Tree::BinaryFP;
use Moose;
+use feature 'say';
sub node_class { __PACKAGE__ . '::Node' }
sub empty_class { __PACKAGE__ . '::Empty' }
+sub isEmpty { undef }
{
my $empty;
@@ -12,43 +14,99 @@ sub empty_class { __PACKAGE__ . '::Empty' }
}
}
+sub make_maker {
+ my ($class, $val) = @_;
+ if (defined $val) {
+ return sub {
+ return $class->node($val, @_);
+ }
+ }
+ else {
+ return sub { $class->empty }
+ }
+}
+sub node {
+ my ($class, $val, $left, $right) = @_;
+ return $class->empty unless grep defined, ($val, $left, $right);
+ $class->node_class->new({
+ value => $val,
+ left => $left ? $left : $class->empty,
+ right => $right ? $right : $class->empty,
+ });
+}
+
+sub match {
+ my ($self, $match) = @_;
+
+ return $self if $match->isEmpty;
+ my $p = $match->value;
+ if (ref $p and ref $p eq 'CODE') {
+ $p->($self) or return;
+ }
+ else {
+ return unless $self->value eq $p;
+ }
+ my @children;
+ for my $dir ('left', 'right') {
+ my $child = $match->$dir;
+ next if $child->isEmpty;
+ my @child = $self->$dir->match($child)
+ or return;
+ push @children, @child;
+ }
+ return ($self, @children);
+}
+
sub default_comparison {
- return sub { $_[0]->data <=> $_[1] }
+ return sub { $_[0]->value <=> $_[1] }
}
sub compare {
- my ($self, $data) = @_;
+ my ($self, $value) = @_;
return $self->compareWith(
$self->default_comparison,
- $data);
+ $value);
}
sub insert {
- my ($self, $data) = @_;
- return $self->insertWith($self->default_comparison, $data);
+ my ($self, $value) = @_;
+ return $self->insertWith($self->default_comparison, $value);
}
sub insertWith {
- my ($self, $comparison, $data) = @_;
- return $self->_insertWith( $comparison, $data );
+ my ($self, $comparison, $value) = @_;
+ return $self->_insertWith( $comparison, $value );
}
sub _insertWith { die "abstract method" };
sub compareWith { die "abstract method" };
sub member { die "abstract method" };
sub debug_tree { die "abstract method" };
sub leaves { die "abstract method" };
+sub show { die "abstract method" };
+
+sub run_match {
+ my ($self, $tree, $debug) = @_;
+ my @list = eval { $self->match($tree) };
+ if ($debug) {
+ say sprintf "$debug %s: %s",
+ (@list ? 'OK' : 'FAIL'),
+ join ',' => map $_->show, @list;
+ }
+}
package Tree::BinaryFP::Empty;
use Moose;
extends 'Tree::BinaryFP';
sub _insertWith {
- my ($self, $comparison, $data) = @_;
- return $self->node_class->new({ data => $data });
+ my ($self, $comparison, $value) = @_;
+ return $self->node_class->new({ value => $value });
}
sub member { return }
sub compare { return }
sub debug_tree { '' }
sub leaves { () }
+sub show { '()' }
+sub isEmpty { 1 }
package Tree::BinaryFP::Node;
use Moose;
@@ -65,20 +123,25 @@ has right => (
default => sub { $_[0]->empty },
);
-has data => (
+has value => (
is => 'ro',
);
+sub show {
+ my $self = shift;
+ return $self->value;
+}
+
sub _insertWith {
- my ($self, $cf, $data) = @_;
+ my ($self, $cf, $value) = @_;
- my $cmp = $cf->($self, $data)
+ my $cmp = $cf->($self, $value)
or return $self;
return $self->new(
- data => $self->data,
- left => $cmp < 0 ? $self->left ->insertWith($cf, $data) : $self->left,
- right=> $cmp > 0 ? $self->right->insertWith($cf, $data) : $self->right,
+ value => $self->value,
+ left => $cmp < 0 ? $self->left ->insertWith($cf, $value) : $self->left,
+ right=> $cmp > 0 ? $self->right->insertWith($cf, $value) : $self->right,
);
}
sub debug_tree {
@@ -89,16 +152,16 @@ sub debug_tree {
my $left = $self->left ->debug_tree($level+1);
my $right = $self->right->debug_tree($level+1);
- my $data = $self->data;
- $data = $data ? "$data\n" : '';
+ my $value = $self->value;
+ $value = $value ? "$value\n" : '';
- return $left . $padding . $data . $right;
+ return $left . $padding . $value . $right;
}
sub leaves {
my $self = shift;
return (
$self->left->leaves,
- $self->data,
+ $self->value,
$self->right->leaves
);
}
@@ -2,13 +2,14 @@
use strict; use warnings;
use Data::Dumper;
use Test::More;
+use feature 'say';
use Tree::BinaryFP;
my $node = Tree::BinaryFP->empty;
my @list = qw/ e d f c g b h a i /;
-my $cmp = sub { $_[0]->data cmp $_[1] };
+my $cmp = sub { $_[0]->value cmp $_[1] };
for (@list) {
$node = $node->insertWith($cmp, $_);
}
@@ -17,5 +18,39 @@ diag $node->debug_tree;
diag join ',' => $node->leaves;
# diag Dumper($node);
-done_testing;
+BEGIN {
+ no strict 'refs';
+ for ('a'..'i') {
+ *$_ = Tree::BinaryFP->make_maker($_);
+ }
+ *any = Tree::BinaryFP->make_maker( sub {1} );
+}
+$node->run_match( e(d,f), 'e(d,f)' );
+$node->run_match( e(f,d), 'e(f,d)' );
+$node->run_match( e(undef,d), 'e(undef,d)' );
+$node->run_match( e(f,undef), 'e(f,undef)' );
+$node->run_match( any(any(any(any()))), 'any(any(any(any)))' );
+$node->run_match( any(any(any(any(any())))), 'any x5');
+$node->run_match( any(any(any(any(any(any()))))), 'any x6');
+$node->run_match( any(any(any(any(any(any(any())))))), 'any x7');
+$node->run_match( any(undef, any(undef, any)), 'any(undef, any(undef, any))' );
+
+BEGIN {
+ no strict 'refs';
+ for ('V'..'Z') {
+ *$_ = Tree::BinaryFP->make_maker($_);
+ }
+}
+my $node2 = V(W(X,undef), Y(Z, undef));
+diag $node2->debug_tree;
+say '';
+
+my $node3 = Tree::BinaryFP->node('V',
+ Tree::BinaryFP->node('W',
+ Tree::BinaryFP->node('X'), undef),
+ Tree::BinaryFP->node('Y',
+ Tree::BinaryFP->node('Z'), undef));
+diag $node3->debug_tree;
+
+done_testing;

0 comments on commit 683451a

Please sign in to comment.