Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Enfilade (very WIP, to refactor)

this will build on RedBlackFP, which is still pending BinaryFP base role changes,
checking in in very rough state, just for reference.
  • Loading branch information...
commit ca0a5bcc0085d4b77c0fd01f1223c88140a3240f 1 parent 1722290
Hakim Cassimally authored
View
50 scratch/perl/text-piecetable/lib/Tree/Enfilade.pm
@@ -0,0 +1,50 @@
+package Tree::Enfilade;
+use Moose;
+use Data::Dumper;
+
+has colour => (
+ isa => 'Int',
+ is => 'ro',
+ default => 0,
+);
+
+has disp => (
+ isa => 'Int',
+ is => 'ro',
+ default => 0,
+);
+
+use constant width => 0;
+use constant total_width => 0;
+
+{
+ my $empty;
+ sub empty {
+ $empty //= __PACKAGE__->new()
+ }
+}
+
+# default methods (for Empty)
+sub member { return }
+sub compare { return }
+
+sub insert {
+ my ($self, $data) = @_;
+ my $result = $self->_insert($data);
+ return $result->new( %$result, colour => 0 );
+}
+sub _insert {
+ my ($self, $data) = @_;
+ require Tree::Enfilade::Node;
+ my $result = Tree::Enfilade::Node->new({
+ data => $data,
+ colour => 1,
+ });
+
+ return $result;
+}
+
+sub debug_tree { '' }
+sub leaves { () }
+
+no Moose; __PACKAGE__->meta->make_immutable; 1;
View
160 scratch/perl/text-piecetable/lib/Tree/Enfilade/Node.pm
@@ -0,0 +1,160 @@
+package Tree::Enfilade::Node;
+use Moose;
+
+extends 'Tree::Enfilade';
+
+has left => (
+ is => 'ro',
+ isa => 'Tree::Enfilade',
+ default => sub { shift->empty },
+);
+has right => (
+ is => 'ro',
+ isa => 'Tree::Enfilade',
+ default => sub { shift->empty },
+);
+
+has data => ( is => 'ro', isa => 'Str' );
+
+sub width {
+ my $self = shift;
+ return length $self->data;
+}
+sub total_width {
+ my $self = shift;
+
+ return $self->width
+ + $self->left->total_width
+ + $self->right->total_width;
+}
+
+sub descend {
+ my ($self, $dir) = @_;
+ return $self->left if $dir eq 'L';
+ return $self->right if $dir eq 'R';
+ die "Bad direction '$dir'";
+}
+
+sub _insert {
+ my ($self, $data) = @_;
+
+ my $cmp = $self->compare($data)
+ or return $self;
+
+ my $left = $cmp < 0 ? $self->left ->_insert($data) : $self->left;
+ my $right = $cmp > 0 ? $self->right->_insert($data) : $self->right;
+
+ my $result = $self->new(
+ data => $self->data,
+ colour => $self->colour,
+ disp => $left->total_width,
+ )->balance;
+
+ return $result;
+}
+
+sub balance {
+ my ($self) = @_;
+
+ if (! $self->colour) {
+ # if we are black
+
+ TRY: for my $try (qw/ LL LR RL RR /) {
+ my @path;
+ my $root = $self;
+
+ for my $dir (split //, $try) {
+ my $node = $root->descend($dir);
+ next TRY unless $node->colour;
+
+ push @path, {
+ root => $root,
+ node => $node,
+ dir => $dir,
+ };
+ $root = $node;
+ }
+
+ my $grandchild = $path[-1];
+ my $gc_node = $grandchild->{node};
+
+ my @abcd = ($gc_node->left, $gc_node->right);
+ my @xyz = ($gc_node);
+
+ for my $path (reverse @path) {
+ my $dir = $path->{dir};
+ my $root = $path->{root};
+
+ if ($dir eq 'L') {
+ push @xyz, $root;
+ push @abcd, $root->right;
+ }
+ else {
+ unshift @xyz, $root;
+ unshift @abcd, $root->left;
+ }
+ }
+
+ my ($x, $y, $z) = @xyz;
+ my ($A, $B, $C, $D) = @abcd;
+
+ return $self->new(
+ data => $y->data,
+ colour => 1,
+ left => $self->new(
+ data => $x->data,
+ left => $A, right => $B,
+ colour => 0,
+ ),
+ right => $self->new(
+ data => $z->data,
+ left => $C, right => $D,
+ colour => 0,
+ ),
+ );
+ }
+ }
+ return $self;
+}
+
+sub compare {
+ my ($self, $pos) = @_;
+ return -1 if $pos < $
+ return $data cmp $self->data;
+}
+
+sub member {
+ my ($self, $data) = @_;
+
+ my $cmp = $self->compare($data)
+ or return 1;
+
+ return $cmp > 0 ?
+ $self->right->member($data)
+ : $self->left ->member($data);
+}
+
+sub debug_tree {
+ my ($self, $level) = @_;
+ $level ||= 0;
+ my $padding = ' ' x $level;
+
+ my $left = $self->left ->debug_tree($level+1);
+ my $right = $self->right->debug_tree($level+1);
+
+ my $data = $self->data . ' (' . ($self->colour ? 'R' : 'B') . ')';
+ $data = $data ? "$data\n" : '';
+
+ return $left . $padding . $data . $right;
+}
+
+sub leaves {
+ my ($self) = @_;
+ return (
+ $self->left->leaves,
+ $self->data,
+ $self->right->leaves,
+ );
+}
+
+no Moose; __PACKAGE__->meta->make_immutable; 1;
Please sign in to comment.
Something went wrong with that request. Please try again.