#!/usr/bin/perl -I/home/phil/perl/cpan/DataTableText/lib/ -I. #------------------------------------------------------------------------------- # Bulk Tree operations # Philip R Brenan at appaapps dot com, Appa Apps Ltd Inc., 2021 #------------------------------------------------------------------------------- # podDocumentation package Tree::Bulk; our $VERSION = "20210302"; use warnings FATAL => qw(all); use strict; use Carp qw(confess cluck); use Data::Dump qw(dump); use Data::Table::Text qw(:all); use feature qw(say current_sub); sub saveLog($) #P Save a result to the log file if we are developing {my ($string) = @_; # String to save my $l = q(/home/phil/perl/z/bulkTree/zzz.txt); # Log file if available owf($l, $string) if -e $l; confess "Saved to logfile:\n$l\n"; exit } sub save # Simplified save {my ($t) = @_; # Tree saveLog($t->printKeys); } sub Left {q(left)} # Left sub Right {q(right)} # Right #D1 Bulk Tree # Bulk Tree sub node(;$$$$) #P Create a new bulk tree node {my ($key, $data, $up, $side) = @_; # Key, $data, parent node, side of parent node my $t = genHash(__PACKAGE__, # Bulk tree node keysPerNode => $up ? $up->keysPerNode : 4, # Maximum number of keys per node up => $up, # Parent node left => undef, # Left node right => undef, # Right node height => 1, # Height of node keys => [$key ? $key : ()], # Array of data items for this node data => [$data ? $data : ()], # Data corresponding to each key ); if ($up) # Install new node in tree {if ($side) {$up->{$side} = $t; $up->setHeights(2); } else {confess 'Specify side' if !$side; } } $t } sub new {node} # Create a new tree sub isRoot($) # Return the tree if it is the root {my ($tree) = @_; # Tree confess unless $tree; !$tree->up ? $tree : undef } sub root($) # Return the root node of a tree {my ($tree) = @_; # Tree confess unless $tree; for(; $tree->up; $tree = $tree->up) {} $tree } sub leaf($) # Return the tree if it is a leaf {my ($tree) = @_; # Tree confess unless $tree; $tree and !$tree->right and !$tree->left ? $tree : undef } sub duplex($) # Return the tree if it has left and right children {my ($tree) = @_; # Tree confess unless $tree; $tree->right and $tree->left ? $tree : undef } sub simplex($) # Return the tree if it has either a left child or a right child but not both. {my ($tree) = @_; # Tree confess unless $tree; $tree->right xor $tree->left ? $tree : undef } sub simplexWithLeaf($) # Return the tree if it has either a left child or a right child but not both and the child it has a leaf. {my ($tree) = @_; # Tree confess unless $tree; return undef unless $tree->right xor $tree->left; return undef if $tree->right and !$tree->right->leaf; return undef if $tree->left and !$tree->left ->leaf; $tree } sub empty($) # Return the tree if it is empty {my ($tree) = @_; # Tree confess unless $tree; $tree->leaf and !$tree->keys->@* ? $tree : undef } sub singleton($) # Return the tree if it contains only the root node and nothing else {my ($tree) = @_; # Tree confess unless $tree; $tree->leaf and $tree->isRoot ? $tree : undef; } sub isLeftChild($) # Return the tree if it is the left child {my ($tree) = @_; # Tree confess unless $tree; $tree->up and $tree->up->left and $tree->up->left == $tree ? $tree : undef; } sub isRightChild($) # Return the tree if it is the right child {my ($tree) = @_; # Tree confess unless $tree; $tree->up and $tree->up->right and $tree->up->right == $tree ? $tree : undef; } sub name($) # Name of a tree {my ($tree) = @_; # Tree confess unless $tree; join ' ', $tree->keys->@* } sub names($) # Names of all nodes in a tree in order {my ($tree) = @_; # Tree confess unless $tree; join ' ', map {$_->name} $tree->inorder; } sub setHeights($) #P Set heights along path to root {my ($tree) = @_; # Tree confess unless $tree; for(my $n = $tree; $n; $n = $n->up) {$n->setHeight; $n->balance; } } # setHeights sub actualHeight($) #P Get the height of a node {my ($tree) = @_; # Tree return 0 unless $tree; $tree->height } sub maximum($$) #P Maximum of two numbers {my ($a, $b) = @_; # First, second $a > $b ? $a : $b } sub setHeight($) #P Set height of a tree from its left and right trees {my ($tree) = @_; # Tree confess unless $tree; my $l = actualHeight($tree->left); my $r = actualHeight($tree->right); $tree->height = 1 + maximum($l, $r); } # setHeight # Rotate left # p p # n r # l r n R # L R l L sub rotateLeft($) #P Rotate a node left {my ($n) = @_; # Node confess unless $n; my $p = $n->up; return unless $p; my $r = $n->right; return unless $r; my $L = $r->left; $p->{$n->isRightChild ? Right : Left} = $r; $r->up = $p; $r->left = $n; $n->up = $r; $n->right = $L; $L->up = $n if $L; setHeight $_ for $n, $r, $p; $r->refill; } # rotateLeft sub rotateRight($) #P Rotate a node right {my ($n) = @_; # Node confess unless $n; my $p = $n->up; return unless $p; my $l = $n->left; return unless $l; my $R = $l->right; $p->{$n->isLeftChild ? Left : Right} = $l; $l->up = $p; $l->right = $n; $n->up = $l; $n->left = $R; $R->up = $n if $R; setHeight $_ for $n, $l, $p; $l->refill; } # rotateLeft # Balance - make the deepest sub tree one less deep # 1 1 # 2 5 # 6 2 6 # 5 4 # 4 3 # 3 sub balance($) # Balance a node {my ($t) = @_; # Tree confess unless $t; my ($l, $r) = (actualHeight($t->left), actualHeight($t->right)); if ($l > 2 * $r + 1) # Rotate right {if (my $l = $t->left) # Counter balance if necessary {if (actualHeight($l->right) > actualHeight($l->left)) {$l->rotateLeft } } $t->rotateRight; } elsif ($r > 2 * $l + 1) # Rotate left {if (my $r = $t->right) # Counter balance if necessary {if (actualHeight($r->left) > actualHeight($r->right)) {$r->rotateRight } } $t->rotateLeft; } $t } # balance sub insertUnchecked($$$) #P Insert a key and some data into a tree {my ($tree, $key, $data) = @_; # Tree, key, data confess unless $tree; confess unless defined $key; my sub insertIntoNode # Insert the current key into the specified node {my @k; my @d; # Rebuilt node my $low = 1; # Keys less than the key for my $i(keys $tree->keys->@*) # Insert key and data in node {my $k = $tree->keys->[$i]; confess "Duplicate key" if $k == $key; if ($low and $k > $key) # Insert key and data before first greater key {$low = undef; push @k, $key; push @d, $data; } push @k, $k; push @d, $tree->data->[$i]; } if ($low) # Key bigger than largest key {push @d, $data; push @k, $key; } $tree->keys = \@k; $tree->data = \@d; # Keys and data in node } # insertIntoNode if ($tree->keys->@* < $tree->keysPerNode and leaf $tree) # Small node so we can add within the node {insertIntoNode; return $tree; } elsif ($key < $tree->keys->[0]) # Less than least - Go left {if ($tree->left) # New node left {return __SUB__->($tree->left, $key, $data); } else {return node $key, $data, $tree, Left; # Add a new node left } } elsif ($key > $tree->keys->[-1]) # Greater than most - go right {if ($tree->right) # New node right {return __SUB__->($tree->right, $key, $data); } else {return node $key, $data, $tree, Right; # Add a new node right } } else # Full node and key is inside it {insertIntoNode; # Keys in node if ($tree->keys->@* > $tree->keysPerNode) # Reinsert last key and data if the node is now to big {my $k = pop $tree->keys->@*; my $d = pop $tree->data->@*; if (my $r = $tree->right) {return $r->insertUnchecked($k, $d); } else # Insert right in new node and balance {return node $k, $d, $tree, Right; } } return $tree; } } # insertUnchecked sub insert($$$) # Insert a key and some data into a tree {my ($tree, $key, $data) = @_; # Tree, key, data confess unless $tree; confess unless defined $key; $tree->insertUnchecked($key, $data); } # insert sub find($$) # Find a key in a tree and returns its data {my ($tree, $key) = @_; # Tree, key confess unless $tree; confess "No key" unless defined $key; confess "Non numeric key" unless $key =~ m(\A\d+\Z); sub # Find the key in the sub-tree {my ($tree) = @_; # Sub-tree if ($tree) {my $keys = $tree->keys; confess "Empty node" unless $keys->@*; return __SUB__->($tree->left) if $key < $$keys[ 0]; return __SUB__->($tree->right) if $key > $$keys[-1]; for my $i(keys $keys->@*) # Find key in node {my $v = $tree->data->[$i]; confess "undefined data for key $key" unless defined $v; return $tree->data->[$i] if $key == $$keys[$i]; } } undef }->($tree) } # find sub first($) # First node in a tree {my ($n) = @_; # Tree confess unless $n; $n = $n->left while $n->left; $n } sub last($) # Last node in a tree {my ($n) = @_; # Tree confess unless $n; $n = $n->right while $n->right; $n } sub next($) # Next node in order {my ($tree) = @_; # Tree confess unless $tree; if (my $r = $tree->right) {return $r->left ? $r->left->first : $r; } my $p = $tree; for(; $p; $p = $p->up) {return $p->up unless $p->up and $p->up->right and $p->up->right == $p; } undef } sub prev($) # Previous node in order {my ($tree) = @_; # Tree confess unless $tree; if (my $l = $tree->left) {return $l->right ? $l->right->last : $l; } my $p = $tree; for(; $p; $p = $p->up) {return $p->up unless $p->up and $p->up->left and $p->up->left == $p; } undef } sub inorder($) # Return a list of all the nodes in a tree in order {my ($tree) = @_; # Tree confess unless $tree; my @n; for(my $n = $tree->first; $n; $n = $n->next) {push @n, $n; } @n } sub unchain($) #P Remove a tree from the middle of a chain. A leaf is considered to be in the middle of a chain and so can be removed with this method {my ($t) = @_; # Tree confess unless $t; confess "Duplex tree cannot be unchained" if duplex $t; confess "Root cannot be unchained" unless my $p = $t->up; my $c = $t->left // $t->right; # Not duplex so at most one of these $p->{$t->isLeftChild ? Left : Right} = $c; # Unchain $c->up = $p if $c; $t->up = undef; if (my $l = $p->left) {$l->setHeights($l->height)} # Set heights from a known point elsif (my $r = $p->right) {$r->setHeights($r->height)} else {$p->setHeights(1)} $p->balance; # Rebalance parent $p # Unchained node } # unchain sub refillFromRight($) #P Push a key to the target node from the next node {my ($target) = @_; # Target tree confess unless $target; confess "No right" unless $target->right; # Ensure source will be in this sub tree confess "No source" unless my $source = $target->next; # No source while ($source->keys->@* > 0 and $target->keys->@* < $target->keysPerNode) # Transfer fill from source {push $target->keys->@*, shift $source->keys->@*; push $target->data->@*, shift $source->data->@*; } $source->unchain if $source->empty; $_->refill for $target, $source; } # refillFromRight sub refillFromLeft($) #P Push a key to the target node from the previous node {my ($target) = @_; # Target tree confess unless $target; confess "No left" unless $target->left; # Ensure source will be in this sub tree confess "No source" unless my $source = $target->prev; # No source while ($source->keys->@* > 0 and $target->keys->@* < $target->keysPerNode) # Transfer fill from source {unshift $target->keys->@*, pop $source->keys->@*; unshift $target->data->@*, pop $source->data->@*; } $source->unchain if $source->empty; $_->refill for $target, $source; } # refillFromLeft sub refill($) #P Refill a node so it has the expected number of keys {my ($tree) = @_; # Tree confess unless $tree; return if $tree->singleton; return if $tree->keys->@* == $tree->keysPerNode; if ($tree->empty) # Remove an empty leaf that is not the root {$tree->unchain unless $tree->isRoot; } elsif ($tree->keys->@* < $tree->keysPerNode) # Refill the node from neighboring leaf nodes {if (!$tree->leaf) # Do not refill leaves {$tree->refillFromRight if $tree->right; $tree->refillFromLeft if $tree->left; } } else {while($tree->keys->@* > $tree->keysPerNode) # Empty node if over full {$tree->insertUnchecked(pop $tree->keys->@*, pop $tree->data->@*); # Reinsert lower down } } } # refill sub delete($$) # Delete a key in a tree {my ($tree, $key) = @_; # Tree, key confess unless $tree; confess "No key" unless defined $key; sub # Find then delete the key in the sub-tree {my ($tree) = @_; # Sub-tree return unless $tree; return unless $tree->keys->@*; # Empty tree if ($key < $tree->keys->[ 0]) {__SUB__->($tree->left)} # Less than least key so go left elsif ($key > $tree->keys->[-1]) {__SUB__->($tree->right)} # Greater than most key so go right elsif (grep {$_ == $key} $tree->keys->@*) # Key present in current node {my @k, my @d; for my $i(keys $tree->keys->@*) # Remove the key and corresponding data {next if $tree->keys->[$i] == $key; push @d, $tree->data->[$i]; push @k, $tree->keys->[$i]; } $tree->keys = \@k; $tree->data = \@d; $tree->refill; # Refill the tree } }->($tree); } # delete sub printKeys2($$$) #P print the keys for a tree {my ($t, $in, $g) = @_; # Tree, indentation, list of keys, return unless $t; __SUB__->($t->left, $in+1, $g); # Left my $h = $t->height; my $s = $t->up && $t->up->left && $t->up->left == $t ? 'L' : # Print $t->up && $t->up->right && $t->up->right == $t ? 'R' : 'S'; $s .= $t->leaf ? 'z' : $t->isRoot ? 'A' : $t->left && $t->right ? 'd' : $t->left ? 'l' : 'r'; $s .= "$in $h ".(' ' x $in); $s .= $t->name; $s .= '->'.$t->up->name if $t->up; push @$g, $s; __SUB__->($t->right, $in+1, $g); # Right } sub printKeys($) # Print the keys in a tree {my ($t) = @_; # Tree confess unless $t; my @s; printKeys2 $t, 0, \@s; (join "\n", @s, "") =~ s(\s+\Z) (\n)sr } # printKeys sub setKeysPerNode($$) # Set the number of keys for the current node {my ($tree, $N) = @_; # Tree, keys per node to be set confess unless $tree; confess unless $N and $N > 0; $tree->keysPerNode = $N; # Set $tree->refill; # Refill if necessary $tree # Allow chaining } # setKeysPerNode sub printKeysAndData($) # Print the mapping from keys to data in a tree {my ($t) = @_; # Tree confess unless $t; my @s; my sub print($$) {my ($t, $in) = @_; return unless $t; __SUB__->($t->left, $in+1); # Left push @s, [$t->keys->[$_], $t->data->[$_]] for keys $t->keys->@*; # Find key in node __SUB__->($t->right, $in+1); # Right } print $t, 0; formatTableBasic(\@s) } # printKeysAndData sub checkLRU($) #P Confirm pointers in tree {my ($tree) = @_; # Tree my %seen; # Nodes we have already seen sub # Check pointers in a tree {my ($tree, $dir) = @_; # Tree return unless $tree; confess "Recursed $dir into: ".$tree->name if $seen{$tree->name}++; __SUB__->($tree->left, Left); __SUB__->($tree->right, Right); }->($tree->root); } sub check($) #P Confirm that each node in a tree is ordered correctly {my ($tree) = @_; # Tree confess unless $tree; $tree->checkLRU; my $maxHeight = 0; sub {my ($tree) = @_; # Tree return unless $tree; __SUB__->($tree->left); __SUB__->($tree->right); confess $tree->name unless $tree->keys->@* == $tree->data->@*; # Check key count matches data count if ( !$tree->leaf and !$tree->isRoot # Confirm that all interior nodes are fully filled and $tree->keys->@* != $tree->keysPerNode) {confess "Interior node not full: " .$tree->name."\n". $tree->root->printKeys; } confess $tree->name unless $tree->isRoot or # Node is either a root or a left or right child $tree->up && $tree->up->left && $tree == $tree->up->left or $tree->up && $tree->up->right && $tree == $tree->up->right; confess 'Left:'.$tree->name if $tree->left and # Left child has correct parent !$tree->left->up || $tree->left->up != $tree; confess 'Right:'.$tree->name if $tree->right and # Right child has correct parent !$tree->right->up || $tree->right->up != $tree; if ($tree->simplex and !$tree->simplexWithLeaf and $tree->up # Simplex children must always have duplex parents and !$tree->up->isRoot and !$tree->up->duplex) {confess "Simplex does not have duplex parent: ".$tree->name ."\n".$tree->root->printKeys; } $maxHeight = $tree->height if $tree->height > $maxHeight; my @k = $tree->keys->@*; # Check keys @k <= $tree->keysPerNode or confess "Too many keys:".scalar(@k); for my $i(keys @k) {confess "undef key position $i" unless defined $k[$i]; } my @d = $tree->data->@*; # Check data @d <= $tree->keysPerNode or confess "Too many data:".scalar(@d); my %k; for my $i(1..$#k) {confess "Out of order: ", dump(\@k) if $k[$i-1] >= $k[$i]; confess "Duplicate key: ", $k[$i] if $k{$k[$i]}++; confess "Undefined data: ", $k[$i] unless defined $d[$i]; } }->($tree); if ($tree->height < $maxHeight) # Check tree heights {cluck "Tree height failure at: ", $tree->name; save($tree); } } # check sub checkAgainstHash($%) #P Check a tree against a hash {my ($t, %t) = @_; # Tree, expected for my $k(keys %t) # Check we can find all the keys expected {my ($t) = @_; my $v = $t{$k}; confess "Cannot find $k" unless my $f = find($t, $k); confess "Found $f but expected $v" unless $f == $v; } sub # Check that the tree does not contain unexpected keys {my ($t) = @_; return unless $t; __SUB__->($t->left); # Left for($t->keys->@*) {confess $_ unless delete $t{$_}; } __SUB__->($t->right); # Right }->($t); confess if keys %t; # They should have all been deleted } # checkAgainstHash #d #------------------------------------------------------------------------------- # Export - eeee #------------------------------------------------------------------------------- use Exporter qw(import); use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); @ISA = qw(Exporter); @EXPORT = qw(); @EXPORT_OK = qw( ); %EXPORT_TAGS = (all=>[@EXPORT, @EXPORT_OK]); # podDocumentation =pod =encoding utf-8 =head1 Name Tree::Bulk - Bulk Tree operations =head1 Synopsis Bulk trees store several (key,data) pairs in each node of a balanced tree to reduce the number of tree pointers: up, left, right, etc. used to maintain the tree. This has no useful effect in Perl code, but in C code, especially C code that uses SIMD instructions, the savings in space can be considerable which allows the processor caches to be used more effectively. This module demonstrates insert, find, delete operations on bulk trees as a basis for coding these algorithms more efficiently in assembler code. is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END for my $n($t->inorder) {$n->setKeysPerNode(2); } is_deeply $t->printKeys, <5 6 Ld2 2 5 6->9 10 Rz3 1 7 8->5 6 Rd1 4 9 10->1 2 Lz4 1 11 12->13 14 Ld3 2 13 14->17 18 Rz4 1 15 16->13 14 Rd2 3 17 18->9 10 Rr3 2 19 20->17 18 Rz4 1 21 22->19 20 END =head1 Description Bulk Tree operations Version "20210302". The following sections describe the methods in each functional area of this module. For an alphabetic listing of all methods by name see L. =head1 Bulk Tree Bulk Tree =head2 isRoot($tree) Return the tree if it is the root Parameter Description 1 $tree Tree B if (1) {lll "Attributes"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $b = $t->insert(2,4); my $a = $t->insert(1,2); my $c = $t->insert(3,6); ok $a->isLeftChild; ok $c->isRightChild; ok !$a->isRightChild; ok !$c->isLeftChild; ok $b->isRoot; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok !$a->isRoot; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok !$c->isRoot; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok $a->leaf; ok $c->leaf; ok $b->duplex; ok $c->root == $b; ok $c->root != $a; } =head2 root($tree) Return the root node of a tree Parameter Description 1 $tree Tree B if (1) {lll "Attributes"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $b = $t->insert(2,4); my $a = $t->insert(1,2); my $c = $t->insert(3,6); ok $a->isLeftChild; ok $c->isRightChild; ok !$a->isRightChild; ok !$c->isLeftChild; ok $b->isRoot; ok !$a->isRoot; ok !$c->isRoot; ok $a->leaf; ok $c->leaf; ok $b->duplex; ok $c->root == $b; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok $c->root != $a; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 } =head2 leaf($tree) Return the tree if it is a leaf Parameter Description 1 $tree Tree B if (1) {lll "Attributes"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $b = $t->insert(2,4); my $a = $t->insert(1,2); my $c = $t->insert(3,6); ok $a->isLeftChild; ok $c->isRightChild; ok !$a->isRightChild; ok !$c->isLeftChild; ok $b->isRoot; ok !$a->isRoot; ok !$c->isRoot; ok $a->leaf; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok $c->leaf; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok $b->duplex; ok $c->root == $b; ok $c->root != $a; } =head2 duplex($tree) Return the tree if it has left and right children Parameter Description 1 $tree Tree B if (1) {lll "Attributes"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $b = $t->insert(2,4); my $a = $t->insert(1,2); my $c = $t->insert(3,6); ok $a->isLeftChild; ok $c->isRightChild; ok !$a->isRightChild; ok !$c->isLeftChild; ok $b->isRoot; ok !$a->isRoot; ok !$c->isRoot; ok $a->leaf; ok $c->leaf; ok $b->duplex; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok $c->root == $b; ok $c->root != $a; } =head2 simplex($tree) Return the tree if it has either a left child or a right child but not both. Parameter Description 1 $tree Tree B if (1) {lll "SetHeights"; my $a = node(1,1)->setKeysPerNode(1); my $b = node(2,2)->setKeysPerNode(1); my $c = node(3,3)->setKeysPerNode(1); my $d = node(4,4)->setKeysPerNode(1); my $e = node(5,5); $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->right = $d; $d->up = $c; $d->right = $e; $e->up = $d; is_deeply $a->printKeys, <1 Rr2 1 3->2 Rr3 1 4->3 Rz4 1 5->4 END #save $a; $e->setHeights(1); is_deeply $a->printKeys, <1 Lz3 1 3->4 Rd2 2 4->2 Rz3 1 5->4 END #save $a; ok $b->simplex; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok !$c->simplex; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 $c->balance; is_deeply $a->printKeys, <1 Lz3 1 3->4 Rd2 2 4->2 Rz3 1 5->4 END #save $a; $b->balance; is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Rz2 1 5->4 END #save $a; } =head2 simplexWithLeaf($tree) Return the tree if it has either a left child or a right child but not both and the child it has a leaf. Parameter Description 1 $tree Tree B if (1) {lll "Balance"; my $a = node(1,1)->setKeysPerNode(1); $a->height = 5; my $b = node(2,2)->setKeysPerNode(1); $b->height = 4; my $c = node(3,3)->setKeysPerNode(1); $c->height = 3; my $d = node(4,4)->setKeysPerNode(1); $d->height = 2; my $e = node(5,5); $e->height = 1; $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->right = $d; $d->up = $c; $d->right = $e; $e->up = $d; $e->balance; is_deeply $a->printKeys, <1 Rr2 3 3->2 Rr3 2 4->3 Rz4 1 5->4 END #save $a; ok $d->simplexWithLeaf; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok !$c->simplexWithLeaf; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 $d->balance; is_deeply $a->printKeys, <1 Rr2 3 3->2 Rr3 2 4->3 Rz4 1 5->4 END #save $a; $c->balance; is_deeply $a->printKeys, <1 Lz3 1 3->4 Rd2 2 4->2 Rz3 1 5->4 END #save $a; $b->balance; is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Rz2 1 5->4 END #save $a; } =head2 empty($tree) Return the tree if it is empty Parameter Description 1 $tree Tree B if (1) {lll "Balance"; my $t = Tree::Bulk::new->setKeysPerNode(1); ok $t->empty; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok $t->singleton; } =head2 singleton($tree) Return the tree if it contains only the root node and nothing else Parameter Description 1 $tree Tree B if (1) {lll "Balance"; my $t = Tree::Bulk::new->setKeysPerNode(1); ok $t->empty; ok $t->singleton; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 } =head2 isLeftChild($tree) Return the tree if it is the left child Parameter Description 1 $tree Tree B if (1) {lll "Attributes"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $b = $t->insert(2,4); my $a = $t->insert(1,2); my $c = $t->insert(3,6); ok $a->isLeftChild; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok $c->isRightChild; ok !$a->isRightChild; ok !$c->isLeftChild; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok $b->isRoot; ok !$a->isRoot; ok !$c->isRoot; ok $a->leaf; ok $c->leaf; ok $b->duplex; ok $c->root == $b; ok $c->root != $a; } =head2 isRightChild($tree) Return the tree if it is the right child Parameter Description 1 $tree Tree B if (1) {lll "Attributes"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $b = $t->insert(2,4); my $a = $t->insert(1,2); my $c = $t->insert(3,6); ok $a->isLeftChild; ok $c->isRightChild; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok !$a->isRightChild; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok !$c->isLeftChild; ok $b->isRoot; ok !$a->isRoot; ok !$c->isRoot; ok $a->leaf; ok $c->leaf; ok $b->duplex; ok $c->root == $b; ok $c->root != $a; } =head2 name($tree) Name of a tree Parameter Description 1 $tree Tree B if (1) {lll "Split and Refill"; my $N = 22; my $t = Tree::Bulk::new; for my $k(1..$N) {$t->insert($k, 2 * $k); } is_deeply $t->name, "1 2 3 4"; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END #save $t; for my $n($t->inorder) {$n->setKeysPerNode(2); } is_deeply $t->printKeys, <5 6 Ld2 2 5 6->9 10 Rz3 1 7 8->5 6 Rd1 4 9 10->1 2 Lz4 1 11 12->13 14 Ld3 2 13 14->17 18 Rz4 1 15 16->13 14 Rd2 3 17 18->9 10 Rr3 2 19 20->17 18 Rz4 1 21 22->19 20 END #save $t; for my $n($t->inorder) {$n->setKeysPerNode(1); } is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 5 9->1 Lz5 1 10->11 Ld4 2 11->13 Rz5 1 12->11 Ld3 3 13->17 Lz5 1 14->15 Rd4 2 15->13 Rz5 1 16->15 Rd2 4 17->9 Lz4 1 18->19 Rd3 3 19->17 Lz5 1 20->21 Rd4 2 21->19 Rz5 1 22->21 END #save $t; $_->setKeysPerNode(2) for $t->inorder; is_deeply $t->printKeys, <5 6 Ld2 2 5 6->9 10 Rz3 1 7 8->5 6 Rd1 4 9 10->1 2 Lz4 1 11 12->13 14 Ld3 2 13 14->17 18 Rz4 1 15 16->13 14 Rd2 3 17 18->9 10 Lz4 1 19 20->21 22 Rl3 2 21 22->17 18 END #save $t; $_->setKeysPerNode(4) for $t->inorder; is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END #save $t; } =head2 names($tree) Names of all nodes in a tree in order Parameter Description 1 $tree Tree B if (1) {my sub randomLoad($$$) # Randomly load different size nodes {my ($N, $keys, $height) = @_; # Number of elements, number of keys per node, expected height lll "Random load $keys"; srand(1); # Same randomization my $t = Tree::Bulk::new->setKeysPerNode($keys); for my $r(randomizeArray 1..$N) {$debug = $r == 74; $t->insert($r, 2 * $r); $t->check; } is_deeply $t->actualHeight, $height; # Check height confess unless $t->actualHeight == $height; is_deeply join(' ', 1..$N), $t->names; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 my %t = map {$_=>2*$_} 1..$N; for my $r(randomizeArray 1..$N) # Delete in random order {$t->delete ($r); delete $t{$r}; checkAgainstHash $t, %t; check($t); } ok $t->empty; is_deeply $t->actualHeight, 1; } randomLoad(222, 1, 11); randomLoad(222, 8, 8); randomLoad(222, 4, 9); } =head2 balance($t) Balance a node Parameter Description 1 $t Tree B if (1) {lll "Balance"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $a = node(1,2) ->setKeysPerNode(1); my $b = node(2,4) ->setKeysPerNode(1); my $c = node(6,12)->setKeysPerNode(1); my $d = node(5,10)->setKeysPerNode(1); my $e = node(4,8) ->setKeysPerNode(1); my $f = node(3,6) ->setKeysPerNode(1); $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->left = $d; $d->up = $c; $d->left = $e; $e->up = $d; $e->left = $f; $f->up = $e; $f->setHeights(1); is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Lz3 1 5->6 Rl2 2 6->4 END #save $a; $b->balance; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Lz3 1 5->6 Rl2 2 6->4 END #save $a; } =head2 insert($tree, $key, $data) Insert a key and some data into a tree Parameter Description 1 $tree Tree 2 $key Key 3 $data Data B if (1) {lll "Insert"; my $N = 23; my $t = Tree::Bulk::new->setKeysPerNode(1); for(1..$N) {$t->insert($_, 2 * $_); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 } is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 7 9->1 Lz4 1 10->11 Ld3 2 11->13 Rz4 1 12->11 Rd2 6 13->9 Lz5 1 14->15 Ld4 2 15->17 Rz5 1 16->15 Rd3 5 17->13 Lz5 1 18->19 Rd4 4 19->17 Lz6 1 20->21 Rd5 3 21->19 Rr6 2 22->21 Rz7 1 23->22 END #save $t; ok $t->height == 8; } =head2 find($tree, $key) Find a key in a tree and returns its data Parameter Description 1 $tree Tree 2 $key Key B if (1) {my $t = Tree::Bulk::new; $t->insert($_, $_*$_) for 1..20; ok !find($t, 0); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok !find($t, 21); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 ok find($t, $_) == $_ * $_ for qw(1 5 10 11 15 20); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 } =head2 first($n) First node in a tree Parameter Description 1 $n Tree B if (1) {my $N = 220; my $t = Tree::Bulk::new; for(reverse 1..$N) {$t->insert($_, 2*$_); } is_deeply $t->actualHeight, 10; if (1) {my @n; for (my $n = $t->first; $n; $n = $n->next) # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 {push @n, $n->keys->@* } is_deeply \@n, [1..$N]; } if (1) {my @p; for my $p(reverse $t->inorder) {push @p, reverse $p->keys->@*; } is_deeply \@p, [reverse 1..$N]; } my @p; for(my $p = $t->last; $p; $p = $p->prev) {push @p, reverse $p->keys->@* } is_deeply \@p, [reverse 1..$N]; my %t = map {$_=>2*$_} 1..$N; for my $i(0..3) {for my $j(map {4 * $_-$i} 1..$N/4) {$t->delete ($j); delete $t{$j}; checkAgainstHash $t, %t; } } ok $t->empty; is_deeply $t->actualHeight, 1; } =head2 last($n) Last node in a tree Parameter Description 1 $n Tree B if (1) {my $N = 220; my $t = Tree::Bulk::new; for(reverse 1..$N) {$t->insert($_, 2*$_); } is_deeply $t->actualHeight, 10; if (1) {my @n; for (my $n = $t->first; $n; $n = $n->next) {push @n, $n->keys->@* } is_deeply \@n, [1..$N]; } if (1) {my @p; for my $p(reverse $t->inorder) {push @p, reverse $p->keys->@*; } is_deeply \@p, [reverse 1..$N]; } my @p; for(my $p = $t->last; $p; $p = $p->prev) # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 {push @p, reverse $p->keys->@* } is_deeply \@p, [reverse 1..$N]; my %t = map {$_=>2*$_} 1..$N; for my $i(0..3) {for my $j(map {4 * $_-$i} 1..$N/4) {$t->delete ($j); delete $t{$j}; checkAgainstHash $t, %t; } } ok $t->empty; is_deeply $t->actualHeight, 1; } =head2 next($tree) Next node in order Parameter Description 1 $tree Tree B if (1) {my $N = 220; my $t = Tree::Bulk::new; for(reverse 1..$N) {$t->insert($_, 2*$_); } is_deeply $t->actualHeight, 10; if (1) {my @n; for (my $n = $t->first; $n; $n = $n->next) # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 {push @n, $n->keys->@* } is_deeply \@n, [1..$N]; } if (1) {my @p; for my $p(reverse $t->inorder) {push @p, reverse $p->keys->@*; } is_deeply \@p, [reverse 1..$N]; } my @p; for(my $p = $t->last; $p; $p = $p->prev) {push @p, reverse $p->keys->@* } is_deeply \@p, [reverse 1..$N]; my %t = map {$_=>2*$_} 1..$N; for my $i(0..3) {for my $j(map {4 * $_-$i} 1..$N/4) {$t->delete ($j); delete $t{$j}; checkAgainstHash $t, %t; } } ok $t->empty; is_deeply $t->actualHeight, 1; } =head2 prev($tree) Previous node in order Parameter Description 1 $tree Tree B if (1) {my $N = 220; my $t = Tree::Bulk::new; for(reverse 1..$N) {$t->insert($_, 2*$_); } is_deeply $t->actualHeight, 10; if (1) {my @n; for (my $n = $t->first; $n; $n = $n->next) {push @n, $n->keys->@* } is_deeply \@n, [1..$N]; } if (1) {my @p; for my $p(reverse $t->inorder) {push @p, reverse $p->keys->@*; } is_deeply \@p, [reverse 1..$N]; } my @p; for(my $p = $t->last; $p; $p = $p->prev) # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 {push @p, reverse $p->keys->@* } is_deeply \@p, [reverse 1..$N]; my %t = map {$_=>2*$_} 1..$N; for my $i(0..3) {for my $j(map {4 * $_-$i} 1..$N/4) {$t->delete ($j); delete $t{$j}; checkAgainstHash $t, %t; } } ok $t->empty; is_deeply $t->actualHeight, 1; } =head2 inorder($tree) Return a list of all the nodes in a tree in order Parameter Description 1 $tree Tree B if (1) {my $N = 220; my $t = Tree::Bulk::new; for(reverse 1..$N) {$t->insert($_, 2*$_); } is_deeply $t->actualHeight, 10; if (1) {my @n; for (my $n = $t->first; $n; $n = $n->next) {push @n, $n->keys->@* } is_deeply \@n, [1..$N]; } if (1) {my @p; for my $p(reverse $t->inorder) # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 {push @p, reverse $p->keys->@*; } is_deeply \@p, [reverse 1..$N]; } my @p; for(my $p = $t->last; $p; $p = $p->prev) {push @p, reverse $p->keys->@* } is_deeply \@p, [reverse 1..$N]; my %t = map {$_=>2*$_} 1..$N; for my $i(0..3) {for my $j(map {4 * $_-$i} 1..$N/4) {$t->delete ($j); delete $t{$j}; checkAgainstHash $t, %t; } } ok $t->empty; is_deeply $t->actualHeight, 1; } =head2 delete($tree, $key) Delete a key in a tree Parameter Description 1 $tree Tree 2 $key Key B if (1) {lll "Delete"; my $N = 28; my $t = Tree::Bulk::new->setKeysPerNode(1); for(1..$N) {$t->insert($_, 2 * $_); } is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 7 9->1 Lz5 1 10->11 Ld4 2 11->13 Rz5 1 12->11 Ld3 3 13->17 Lz5 1 14->15 Rd4 2 15->13 Rz5 1 16->15 Rd2 6 17->9 Lz5 1 18->19 Ld4 2 19->21 Rz5 1 20->19 Rd3 5 21->17 Lz5 1 22->23 Rd4 4 23->21 Lz6 1 24->25 Rd5 3 25->23 Lz7 1 26->27 Rd6 2 27->25 Rz7 1 28->27 END #save $t; for my $k(reverse 1..$N) {$t->delete($k); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 4 9->1 Lz4 1 10->11 Ld3 2 11->13 Rz4 1 12->11 Rd2 3 13->9 Lz4 1 14->15 Rd3 2 15->13 Rz4 1 16->15 END #save $t if $k == 17; is_deeply $t->printKeys, <3 Ld2 2 3->5 Rz3 1 4->3 Rd1 3 5->1 Lz3 1 6->7 Rd2 2 7->5 Rz3 1 8->7 END #save $t if $k == 9; is_deeply $t->printKeys, <3 Rd1 3 3->1 Lz3 1 4->5 Rl2 2 5->3 END #save $t if $k == 6; is_deeply $t->printKeys, <1 Rz2 1 3->2 END #save $t if $k == 4; is_deeply $t->printKeys, <1 END #save $t if $k == 3; is_deeply $t->printKeys, < if (1) {lll "Insert"; my $N = 23; my $t = Tree::Bulk::new->setKeysPerNode(1); for(1..$N) {$t->insert($_, 2 * $_); } is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 7 9->1 Lz4 1 10->11 Ld3 2 11->13 Rz4 1 12->11 Rd2 6 13->9 Lz5 1 14->15 Ld4 2 15->17 Rz5 1 16->15 Rd3 5 17->13 Lz5 1 18->19 Rd4 4 19->17 Lz6 1 20->21 Rd5 3 21->19 Rr6 2 22->21 Rz7 1 23->22 END #save $t; ok $t->height == 8; } =head2 setKeysPerNode($tree, $N) Set the number of keys for the current node Parameter Description 1 $tree Tree 2 $N Keys per node to be set B if (1) {lll "Split and Refill"; my $N = 22; my $t = Tree::Bulk::new; for my $k(1..$N) {$t->insert($k, 2 * $k); } is_deeply $t->name, "1 2 3 4"; is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END #save $t; for my $n($t->inorder) {$n->setKeysPerNode(2); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 } is_deeply $t->printKeys, <5 6 Ld2 2 5 6->9 10 Rz3 1 7 8->5 6 Rd1 4 9 10->1 2 Lz4 1 11 12->13 14 Ld3 2 13 14->17 18 Rz4 1 15 16->13 14 Rd2 3 17 18->9 10 Rr3 2 19 20->17 18 Rz4 1 21 22->19 20 END #save $t; for my $n($t->inorder) {$n->setKeysPerNode(1); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 } is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 5 9->1 Lz5 1 10->11 Ld4 2 11->13 Rz5 1 12->11 Ld3 3 13->17 Lz5 1 14->15 Rd4 2 15->13 Rz5 1 16->15 Rd2 4 17->9 Lz4 1 18->19 Rd3 3 19->17 Lz5 1 20->21 Rd4 2 21->19 Rz5 1 22->21 END #save $t; $_->setKeysPerNode(2) for $t->inorder; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $t->printKeys, <5 6 Ld2 2 5 6->9 10 Rz3 1 7 8->5 6 Rd1 4 9 10->1 2 Lz4 1 11 12->13 14 Ld3 2 13 14->17 18 Rz4 1 15 16->13 14 Rd2 3 17 18->9 10 Lz4 1 19 20->21 22 Rl3 2 21 22->17 18 END #save $t; $_->setKeysPerNode(4) for $t->inorder; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END #save $t; } =head2 printKeysAndData($t) Print the mapping from keys to data in a tree Parameter Description 1 $t Tree B if (1) {my $N = 22; my $t = Tree::Bulk::new; ok $t->empty; ok $t->leaf; for(1..$N) {$t->insert($_, 2 * $_); } ok $t->right->duplex; is_deeply actualHeight($t), 4; is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END #save $t; is_deeply $t->printKeysAndData, <2*$_} 1..$N; for(map {2 * $_} 1..$N/2) {$t->delete($_); delete $t{$_}; checkAgainstHash $t, %t; } is_deeply $t->printKeys, <1 3 5 7 Rz2 1 17 19 21->9 11 13 15 END #save($t); is_deeply $t->printKeysAndData, <delete($_); delete $t{$_}; checkAgainstHash $t, %t; } is_deeply $t->printKeys, < if (1) {lll "Balance"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $a = node(1,2) ->setKeysPerNode(1); my $b = node(2,4) ->setKeysPerNode(1); my $c = node(6,12)->setKeysPerNode(1); my $d = node(5,10)->setKeysPerNode(1); my $e = node(4,8) ->setKeysPerNode(1); my $f = node(3,6) ->setKeysPerNode(1); $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->left = $d; $d->up = $c; $d->left = $e; $e->up = $d; $e->left = $f; $f->up = $e; $f->setHeights(1); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Lz3 1 5->6 Rl2 2 6->4 END #save $a; $b->balance; is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Lz3 1 5->6 Rl2 2 6->4 END #save $a; } =head2 actualHeight($tree) Get the height of a node Parameter Description 1 $tree Tree B if (1) {my $N = 22; my $t = Tree::Bulk::new; ok $t->empty; ok $t->leaf; for(1..$N) {$t->insert($_, 2 * $_); } ok $t->right->duplex; is_deeply actualHeight($t), 4; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END #save $t; is_deeply $t->printKeysAndData, <2*$_} 1..$N; for(map {2 * $_} 1..$N/2) {$t->delete($_); delete $t{$_}; checkAgainstHash $t, %t; } is_deeply $t->printKeys, <1 3 5 7 Rz2 1 17 19 21->9 11 13 15 END #save($t); is_deeply $t->printKeysAndData, <delete($_); delete $t{$_}; checkAgainstHash $t, %t; } is_deeply $t->printKeys, < if (1) {is_deeply maximum(1,2), 2; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply maximum(2,1), 2; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 } =head2 setHeight($tree) Set height of a tree from its left and right trees Parameter Description 1 $tree Tree =head2 rotateLeft($n) Rotate a node left Parameter Description 1 $n Node B if (1) {lll "Rotate"; my $a = node(1,2)->setKeysPerNode(1); my $b = node(2,4)->setKeysPerNode(1); my $c = node(3,6)->setKeysPerNode(1); my $d = node(4,8)->setKeysPerNode(1); $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->right = $d; $d->up = $c; $d->setHeights(1); is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $b->rotateLeft; # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $c->rotateLeft; $c->setHeights(2); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $d->rotateRight; $d->setHeights(1); is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $c->rotateRight; $c->setHeights(2); is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; } =head2 rotateRight($n) Rotate a node right Parameter Description 1 $n Node B if (1) {lll "Rotate"; my $a = node(1,2)->setKeysPerNode(1); my $b = node(2,4)->setKeysPerNode(1); my $c = node(3,6)->setKeysPerNode(1); my $d = node(4,8)->setKeysPerNode(1); $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->right = $d; $d->up = $c; $d->setHeights(1); is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $b->rotateLeft; is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $c->rotateLeft; $c->setHeights(2); is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $d->rotateRight; $d->setHeights(1); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $c->rotateRight; $c->setHeights(2); # 𝗘𝘅𝗮𝗺𝗽𝗹𝗲 is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; } =head2 insertUnchecked($tree, $key, $data) Insert a key and some data into a tree Parameter Description 1 $tree Tree 2 $key Key 3 $data Data =head2 unchain($t) Remove a tree from the middle of a chain. A leaf is considered to be in the middle of a chain and so can be removed with this method Parameter Description 1 $t Tree =head2 refillFromRight($target) Push a key to the target node from the next node Parameter Description 1 $target Target tree =head2 refillFromLeft($target) Push a key to the target node from the previous node Parameter Description 1 $target Target tree =head2 refill($tree) Refill a node so it has the expected number of keys Parameter Description 1 $tree Tree =head2 printKeys2($t, $in, $g) print the keys for a tree Parameter Description 1 $t Tree 2 $in Indentation 3 $g List of keys =head2 checkLRU($tree) Confirm pointers in tree Parameter Description 1 $tree Tree =head2 check($tree) Confirm that each node in a tree is ordered correctly Parameter Description 1 $tree Tree =head2 checkAgainstHash($t, %t) Check a tree against a hash Parameter Description 1 $t Tree 2 %t Expected =head1 Index 1 L - Get the height of a node 2 L - Balance a node 3 L - Confirm that each node in a tree is ordered correctly 4 L - Check a tree against a hash 5 L - Confirm pointers in tree 6 L - Delete a key in a tree 7 L - Return the tree if it has left and right children 8 L - Return the tree if it is empty 9 L - Find a key in a tree and returns its data 10 L - First node in a tree 11 L - Return a list of all the nodes in a tree in order 12 L - Insert a key and some data into a tree 13 L - Insert a key and some data into a tree 14 L - Return the tree if it is the left child 15 L - Return the tree if it is the right child 16 L - Return the tree if it is the root 17 L - Last node in a tree 18 L - Return the tree if it is a leaf 19 L - Maximum of two numbers 20 L - Name of a tree 21 L - Names of all nodes in a tree in order 22 L - Next node in order 23 L - Create a new bulk tree node 24 L - Previous node in order 25 L - Print the keys in a tree 26 L - print the keys for a tree 27 L - Print the mapping from keys to data in a tree 28 L - Refill a node so it has the expected number of keys 29 L - Push a key to the target node from the previous node 30 L - Push a key to the target node from the next node 31 L - Return the root node of a tree 32 L - Rotate a node left 33 L - Rotate a node right 34 L - Set height of a tree from its left and right trees 35 L - Set heights along path to root 36 L - Set the number of keys for the current node 37 L - Return the tree if it has either a left child or a right child but not both. 38 L - Return the tree if it has either a left child or a right child but not both and the child it has a leaf. 39 L - Return the tree if it contains only the root node and nothing else 40 L - Remove a tree from the middle of a chain. =head1 Installation This module is written in 100% Pure Perl and, thus, it is easy to read, comprehend, use, modify and install via B: sudo cpan install Tree::Bulk =head1 Author L L =head1 Copyright Copyright (c) 2016-2021 Philip R Brenan. This module is free software. It may be used, redistributed and/or modified under the same terms as Perl itself. =cut # Tests and documentation sub test {my $p = __PACKAGE__; binmode($_, ":utf8") for *STDOUT, *STDERR; return if eval "eof(${p}::DATA)"; my $s = eval "join('', <${p}::DATA>)"; $@ and die $@; eval $s; $@ and die $@; 1 } test unless caller; 1; # podDocumentation __DATA__ use Time::HiRes qw(time); use Test::More; my $localTest = ((caller(1))[0]//'Tree::Bulk') eq "Tree::Bulk"; # Local testing mode Test::More->builder->output("/dev/null") if $localTest; # Reduce number of confirmation messages during testing if ($^O =~ m(bsd|linux)i) {plan tests => 90} # Supported systems else {plan skip_all =>qq(Not supported on: $^O); } my $start = time; # Tests if (1) #Tsimplex {lll "SetHeights"; my $a = node(1,1)->setKeysPerNode(1); my $b = node(2,2)->setKeysPerNode(1); my $c = node(3,3)->setKeysPerNode(1); my $d = node(4,4)->setKeysPerNode(1); my $e = node(5,5); $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->right = $d; $d->up = $c; $d->right = $e; $e->up = $d; is_deeply $a->printKeys, <1 Rr2 1 3->2 Rr3 1 4->3 Rz4 1 5->4 END #save $a; $e->setHeights(1); is_deeply $a->printKeys, <1 Lz3 1 3->4 Rd2 2 4->2 Rz3 1 5->4 END #save $a; ok $b->simplex; ok !$c->simplex; $c->balance; is_deeply $a->printKeys, <1 Lz3 1 3->4 Rd2 2 4->2 Rz3 1 5->4 END #save $a; $b->balance; is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Rz2 1 5->4 END #save $a; } if (1) #TsimplexWithLeaf {lll "Balance"; my $a = node(1,1)->setKeysPerNode(1); $a->height = 5; my $b = node(2,2)->setKeysPerNode(1); $b->height = 4; my $c = node(3,3)->setKeysPerNode(1); $c->height = 3; my $d = node(4,4)->setKeysPerNode(1); $d->height = 2; my $e = node(5,5); $e->height = 1; $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->right = $d; $d->up = $c; $d->right = $e; $e->up = $d; $e->balance; is_deeply $a->printKeys, <1 Rr2 3 3->2 Rr3 2 4->3 Rz4 1 5->4 END #save $a; ok $d->simplexWithLeaf; ok !$c->simplexWithLeaf; $d->balance; is_deeply $a->printKeys, <1 Rr2 3 3->2 Rr3 2 4->3 Rz4 1 5->4 END #save $a; $c->balance; is_deeply $a->printKeys, <1 Lz3 1 3->4 Rd2 2 4->2 Rz3 1 5->4 END #save $a; $b->balance; is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Rz2 1 5->4 END #save $a; } if (1) {lll "Leaf becomes non leaf"; my $a = node(14,1)->setKeysPerNode(1); $a->height = 4; my $b = node(5,2) ->setKeysPerNode(1); $b->height = 3; my $c = node(4,3) ->setKeysPerNode(1); $c->height = 1; my $d = node(9,4) ->setKeysPerNode(1); $d->height = 1; my $e = node(10,5); $e->height = 2; $a->left = $b; $b->up = $a; $b->left = $c; $c->up = $b; $b->right = $e; $e->up = $b; $e->left = $d; $d->up = $e; is_deeply $a->printKeys, <5 Ld1 3 5->14 Lz3 1 9->10 Rl2 2 10->5 SA0 4 14 END #save $a; $a->delete(4); is_deeply $a->printKeys, <9 Ld1 2 9->14 Rz2 1 10->9 SA0 3 14 END #save $a; } if (1) {lll "Unchain"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $a = node(1,2); my $b = node(2,4); my $c = node(3,6); my $d = node(4,8); my $e = node(5,10); $a->right = $b; $b->up = $a; $b->right = $d; $d->up = $b; $d->left = $c; $c->up = $d; $d->right = $e; $e->up = $d; is_deeply $a->printKeys, <1 Lz3 1 3->4 Rd2 1 4->2 Rz3 1 5->4 END #save $a; $b->unchain; is_deeply $a->printKeys, <4 Rd1 2 4->1 Rz2 1 5->4 END #save $a; } if (1) #TrotateLeft #TrotateRight {lll "Rotate"; my $a = node(1,2)->setKeysPerNode(1); my $b = node(2,4)->setKeysPerNode(1); my $c = node(3,6)->setKeysPerNode(1); my $d = node(4,8)->setKeysPerNode(1); $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->right = $d; $d->up = $c; $d->setHeights(1); is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $b->rotateLeft; is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $c->rotateLeft; $c->setHeights(2); is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $d->rotateRight; $d->setHeights(1); is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; $c->rotateRight; $c->setHeights(2); is_deeply $a->printKeys, <3 Rd1 2 3->1 Rz2 1 4->3 END #save $a; } if (1) #Tmaximum {is_deeply maximum(1,2), 2; is_deeply maximum(2,1), 2; } if (1) #Tempty #Tsingleton {lll "Balance"; my $t = Tree::Bulk::new->setKeysPerNode(1); ok $t->empty; ok $t->singleton; } if (1) #Tbalance #TsetHeights {lll "Balance"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $a = node(1,2) ->setKeysPerNode(1); my $b = node(2,4) ->setKeysPerNode(1); my $c = node(6,12)->setKeysPerNode(1); my $d = node(5,10)->setKeysPerNode(1); my $e = node(4,8) ->setKeysPerNode(1); my $f = node(3,6) ->setKeysPerNode(1); $a->right = $b; $b->up = $a; $b->right = $c; $c->up = $b; $c->left = $d; $d->up = $c; $d->left = $e; $e->up = $d; $e->left = $f; $f->up = $e; $f->setHeights(1); is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Lz3 1 5->6 Rl2 2 6->4 END #save $a; $b->balance; is_deeply $a->printKeys, <4 Rz3 1 3->2 Rd1 3 4->1 Lz3 1 5->6 Rl2 2 6->4 END #save $a; } if (1) #TisLeftChild #TisRightChild #TisRoot #Tleaf #Tduplex #Troot {lll "Attributes"; my $t = Tree::Bulk::new->setKeysPerNode(1); my $b = $t->insert(2,4); my $a = $t->insert(1,2); my $c = $t->insert(3,6); ok $a->isLeftChild; ok $c->isRightChild; ok !$a->isRightChild; ok !$c->isLeftChild; ok $b->isRoot; ok !$a->isRoot; ok !$c->isRoot; ok $a->leaf; ok $c->leaf; ok $b->duplex; ok $c->root == $b; ok $c->root != $a; } if (1) #Tinsert #Theight #TprintKeys {lll "Insert"; my $N = 23; my $t = Tree::Bulk::new->setKeysPerNode(1); for(1..$N) {$t->insert($_, 2 * $_); } is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 7 9->1 Lz4 1 10->11 Ld3 2 11->13 Rz4 1 12->11 Rd2 6 13->9 Lz5 1 14->15 Ld4 2 15->17 Rz5 1 16->15 Rd3 5 17->13 Lz5 1 18->19 Rd4 4 19->17 Lz6 1 20->21 Rd5 3 21->19 Rr6 2 22->21 Rz7 1 23->22 END #save $t; ok $t->height == 8; } if (1) #Tdelete {lll "Delete"; my $N = 28; my $t = Tree::Bulk::new->setKeysPerNode(1); for(1..$N) {$t->insert($_, 2 * $_); } is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 7 9->1 Lz5 1 10->11 Ld4 2 11->13 Rz5 1 12->11 Ld3 3 13->17 Lz5 1 14->15 Rd4 2 15->13 Rz5 1 16->15 Rd2 6 17->9 Lz5 1 18->19 Ld4 2 19->21 Rz5 1 20->19 Rd3 5 21->17 Lz5 1 22->23 Rd4 4 23->21 Lz6 1 24->25 Rd5 3 25->23 Lz7 1 26->27 Rd6 2 27->25 Rz7 1 28->27 END #save $t; for my $k(reverse 1..$N) {$t->delete($k); is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 4 9->1 Lz4 1 10->11 Ld3 2 11->13 Rz4 1 12->11 Rd2 3 13->9 Lz4 1 14->15 Rd3 2 15->13 Rz4 1 16->15 END #save $t if $k == 17; is_deeply $t->printKeys, <3 Ld2 2 3->5 Rz3 1 4->3 Rd1 3 5->1 Lz3 1 6->7 Rd2 2 7->5 Rz3 1 8->7 END #save $t if $k == 9; is_deeply $t->printKeys, <3 Rd1 3 3->1 Lz3 1 4->5 Rl2 2 5->3 END #save $t if $k == 6; is_deeply $t->printKeys, <1 Rz2 1 3->2 END #save $t if $k == 4; is_deeply $t->printKeys, <1 END #save $t if $k == 3; is_deeply $t->printKeys, <insert($k, 2 * $k); } is_deeply $t->name, "1 2 3 4"; is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END #save $t; for my $n($t->inorder) {$n->setKeysPerNode(2); } is_deeply $t->printKeys, <5 6 Ld2 2 5 6->9 10 Rz3 1 7 8->5 6 Rd1 4 9 10->1 2 Lz4 1 11 12->13 14 Ld3 2 13 14->17 18 Rz4 1 15 16->13 14 Rd2 3 17 18->9 10 Rr3 2 19 20->17 18 Rz4 1 21 22->19 20 END #save $t; for my $n($t->inorder) {$n->setKeysPerNode(1); } is_deeply $t->printKeys, <3 Ld3 2 3->5 Rz4 1 4->3 Ld2 3 5->9 Lz4 1 6->7 Rd3 2 7->5 Rz4 1 8->7 Rd1 5 9->1 Lz5 1 10->11 Ld4 2 11->13 Rz5 1 12->11 Ld3 3 13->17 Lz5 1 14->15 Rd4 2 15->13 Rz5 1 16->15 Rd2 4 17->9 Lz4 1 18->19 Rd3 3 19->17 Lz5 1 20->21 Rd4 2 21->19 Rz5 1 22->21 END #save $t; $_->setKeysPerNode(2) for $t->inorder; is_deeply $t->printKeys, <5 6 Ld2 2 5 6->9 10 Rz3 1 7 8->5 6 Rd1 4 9 10->1 2 Lz4 1 11 12->13 14 Ld3 2 13 14->17 18 Rz4 1 15 16->13 14 Rd2 3 17 18->9 10 Lz4 1 19 20->21 22 Rl3 2 21 22->17 18 END #save $t; $_->setKeysPerNode(4) for $t->inorder; is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END #save $t; } if (1) #TactualHeight #TprintKeysAndData {my $N = 22; my $t = Tree::Bulk::new; ok $t->empty; ok $t->leaf; for(1..$N) {$t->insert($_, 2 * $_); } ok $t->right->duplex; is_deeply actualHeight($t), 4; is_deeply $t->printKeys, <9 10 11 12 Rd1 3 9 10 11 12->1 2 3 4 Lz3 1 13 14 15 16->17 18 19 20 Rd2 2 17 18 19 20->9 10 11 12 Rz3 1 21 22->17 18 19 20 END #save $t; is_deeply $t->printKeysAndData, <2*$_} 1..$N; for(map {2 * $_} 1..$N/2) {$t->delete($_); delete $t{$_}; checkAgainstHash $t, %t; } is_deeply $t->printKeys, <1 3 5 7 Rz2 1 17 19 21->9 11 13 15 END #save($t); is_deeply $t->printKeysAndData, <delete($_); delete $t{$_}; checkAgainstHash $t, %t; } is_deeply $t->printKeys, <insert($_, 2 * $_); } for(reverse 1..$N) {$t->delete($_); } is_deeply $t->printKeys, <insert($_, 2*$_); } is_deeply $t->actualHeight, 10; if (1) {my @n; for (my $n = $t->first; $n; $n = $n->next) {push @n, $n->keys->@* } is_deeply \@n, [1..$N]; } if (1) {my @p; for my $p(reverse $t->inorder) {push @p, reverse $p->keys->@*; } is_deeply \@p, [reverse 1..$N]; } my @p; for(my $p = $t->last; $p; $p = $p->prev) {push @p, reverse $p->keys->@* } is_deeply \@p, [reverse 1..$N]; my %t = map {$_=>2*$_} 1..$N; for my $i(0..3) {for my $j(map {4 * $_-$i} 1..$N/4) {$t->delete ($j); delete $t{$j}; checkAgainstHash $t, %t; } } ok $t->empty; is_deeply $t->actualHeight, 1; } if (1) #Tnames {my sub randomLoad($$$) # Randomly load different size nodes {my ($N, $keys, $height) = @_; # Number of elements, number of keys per node, expected height lll "Random load $keys"; srand(1); # Same randomization my $t = Tree::Bulk::new->setKeysPerNode($keys); for my $r(randomizeArray 1..$N) {$t->insert($r, 2 * $r); $t->check; } is_deeply $t->actualHeight, $height; # Check height confess unless $t->actualHeight == $height; is_deeply join(' ', 1..$N), $t->names; my %t = map {$_=>2*$_} 1..$N; for my $r(randomizeArray 1..$N) # Delete in random order {$t->delete ($r); delete $t{$r}; checkAgainstHash $t, %t; check($t); } ok $t->empty; is_deeply $t->actualHeight, 1; } randomLoad(222, 1, 11); # Random loads randomLoad(222, 8, 8); randomLoad(222, 4, 9); } if (1) #Tfind {my $t = Tree::Bulk::new; $t->insert($_, $_*$_) for 1..20; ok !find($t, 0); ok !find($t, 21); ok find($t, $_) == $_ * $_ for qw(1 5 10 11 15 20); } lll "Success:", time - $start;