Permalink
Browse files

work on test/04 for binary tree base

  • Loading branch information...
1 parent 53c9644 commit 5b4478479710325e0b26c450a3a74290dcf4df49 Hakim Cassimally committed May 29, 2011
Showing with 173 additions and 31 deletions.
  1. +121 −18 scratch/perl/text-piecetable/lib/Tree/BinaryFP.pm
  2. +52 −13 scratch/perl/text-piecetable/t/04-tree-fp.t
@@ -44,7 +44,7 @@ sub node {
}
sub match {
- my ($self, $match) = @_;
+ my ($self, $match, $sym) = @_;
return $self if $match->isEmpty;
my $p = $match->value;
@@ -54,17 +54,43 @@ sub match {
else {
return unless $self->value eq $p;
}
+
+ my @dirs = qw/ left right /;
+ my %opposite = ( left=>'right', right=>'left' );
+
my @children;
- for my $dir ('left', 'right') {
+ for my $dir (@dirs) {
my $child = $match->$dir;
next if $child->isEmpty;
- my @child = $self->$dir->match($child)
+
+ my $descend = $sym ? $opposite{$dir} : $dir;
+ my @child = $self->$descend->match($child, $sym)
or return;
push @children, @child;
}
return ($self, @children);
}
+sub run_match {
+ my ($self, $tree, $f) = @_;
+ my @list = eval { $self->match($tree) };
+ if (@list) {
+ return $f->(@list);
+ }
+ return;
+}
+sub run_match_and_sym {
+ my ($self, $tree, $f) = @_;
+
+ for my $sym (0,1) {
+ my @list = eval { $self->match($tree, $sym) };
+ if (@list) {
+ return $f->(@list);
+ }
+ }
+ return;
+}
+
sub default_comparison {
return sub { $_[0]->value <=> $_[1] }
}
@@ -88,23 +114,24 @@ 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 inorder { 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;
- }
+sub debug_inorder {
+ my $self = shift;
+ return join ',' => map $_->show, $self->inorder;
}
package Tree::BinaryFP::Empty;
use Moose;
extends 'Tree::BinaryFP';
+sub min { shift }
+sub max { shift }
+
+sub popMax {
+ die "popMax called on empty list";
+}
+
sub reverse {
return shift;
}
@@ -115,9 +142,10 @@ sub _insertWith {
sub member { return }
sub compare { return }
sub debug_tree { '' }
-sub leaves { () }
+sub inorder { () }
sub show { '()' }
sub isEmpty { 1 }
+sub childless { 1 }
package Tree::BinaryFP::Node;
use Moose;
@@ -134,6 +162,19 @@ has right => (
default => sub { $_[0]->empty },
);
+sub hasLeft {
+ my $self = shift;
+ return $self->left->isEmpty ? 0 : 1;
+}
+sub hasRight {
+ my $self = shift;
+ return $self->right->isEmpty ? 0 : 1;
+}
+sub childless {
+ my $self = shift;
+ return !($self->hasLeft || $self->hasRight);
+}
+
has value => (
is => 'ro',
);
@@ -168,13 +209,75 @@ sub debug_tree {
return $left . $padding . $value . $right;
}
-sub leaves {
+sub inorder {
my $self = shift;
return (
- $self->left->leaves,
- $self->value,
- $self->right->leaves
+ $self->left->inorder,
+ $self,
+ $self->right->inorder
);
}
+sub min {
+ my $self = shift;
+ # return $self->hasLeft ? $self->left : $self;
+ my $left = $self->left;
+ return $left->isEmpty ? $self : $left;
+}
+sub max {
+ my $self = shift;
+ # return $self->hasRight ? $self->right : $self;
+ my $right = $self->right;
+ return $right->isEmpty ? $self : $right;
+}
+sub popMax {
+ my $self = shift;
+ my $right = $self->right;
+ if ($right->isEmpty) {
+ return ($self, $self->left);
+ }
+ else {
+ my ($popped, $newRight) = $right->popMax;
+ return (
+ $popped,
+ $self->new({
+ %$self,
+ right => $newRight,
+ }),
+ );
+ }
+}
+
+sub A;
+sub N;
+sub E;
+*A = __PACKAGE__->mk_node( sub { 1 } );
+*E = __PACKAGE__->mk_node( sub { shift->isEmpty } );
+*N = __PACKAGE__->mk_node( sub { ! shift->isEmpty } );
+
+sub _delete {
+ my $self = shift;
+
+ #$self->run_match( any(empty,empty),
+ if ($self->childless) {
+ return $self->empty;
+ }
+
+ $self->run_match_and_sym(
+ A(N,E),
+ sub {
+ my ($self, $node, undef) = @_;
+ return $node;
+ })
+ or do {
+ # $self->run_match( any(node,node),
+ my ($popped, $left) = $self->left->popMax;
+ return $self->new({
+ %$popped,
+ left => $left,
+ right => $self->right,
+ });
+ };
+}
+
1;
@@ -2,6 +2,7 @@
use strict; use warnings;
use Data::Dumper;
use Test::More;
+use Test::LongString;
use feature 'say';
use Tree::BinaryFP;
@@ -14,27 +15,65 @@ for (@list) {
$node = $node->insertWith($cmp, $_);
}
-diag $node->debug_tree;
-diag join ',' => $node->leaves;
-# diag Dumper($node);
+is_string $node->debug_tree, <<EOT, 'Node created correctly';
+ i
+ h
+ g
+ f
+e
+ d
+ c
+ b
+ a
+EOT
+is $node->debug_inorder, 'i,h,g,f,e,d,c,b,a', 'i,h,g,f,e,d,c,b,a';
BEGIN {
no strict 'refs';
for ('a'..'i') {
*$_ = Tree::BinaryFP->mk_node($_);
}
*any = Tree::BinaryFP->mk_node( sub {1} );
+ *A = Tree::BinaryFP->mk_node( sub { 1 } );
+ *E = Tree::BinaryFP->mk_node( sub { shift->isEmpty } );
+ *N = Tree::BinaryFP->mk_node( sub { ! shift->isEmpty } );
}
-$node->run_match( e(d,f), 'e(d,f)' );
-$node->run_match( e(f,d), 'e(f,d)' );
-$node->run_match( e(d,f)->reverse, 'e(d,f)->reverse' );
-$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))' );
+sub test_match {
+ my ($node, $ok, $expr, $string) = @_;
+ my @list = eval { $node->match($expr) };
+ if (@list) {
+ ok $ok, $string . ' MATCHED (' . (join ',' => map $_->show, @list) .')';
+ }
+ else {
+ ok !$ok, "$string NO MATCH";
+ }
+ return @list;
+}
+
+test_match( $node, 0, e(d,f), 'e(d,f)' );
+my ($e, $f, $d) =
+test_match( $node, 1, e(f,d), 'e(f,d)' );
+test_match( $node, 1, e(d,f)->reverse, 'e(d,f)->reverse' );
+test_match( $node, 1, e(undef,d), 'e(undef,d)' );
+test_match( $node, 1, e(f,undef), 'e(f,undef)' );
+test_match( $node, 1, any(any(any(any()))), 'any x4');
+test_match( $node, 1, any(any(any(any(any())))), 'any x5');
+test_match( $node, 1, any(any(any(any(any(any()))))), 'any x6');
+test_match( $node, 0, any(any(any(any(any(any(any())))))), 'any x7');
+test_match( $node, 1, any(undef, any(undef, any)), 'any(undef, any(undef, any))' );
+
+is_string $e->_delete->debug_tree, <<EOT, 'delete root node';
+ i
+ h
+ g
+f
+ d
+ c
+ b
+ a
+EOT
+is $d->_delete->debug_inorder, 'c,b,a', 'c,b,a';
+is $f->_delete->debug_inorder, 'i,h,g', 'i,h,g';
done_testing;

0 comments on commit 5b44784

Please sign in to comment.