 Think about Loose Coupling PerlMonks

### comment on

 Need Help??

This is the code for Algorithm::Treap. If you run it as perl treap.pm then it will self test/demonstrate. Also included is a test snippet that I have been using.

This should be installed as ./Algorithm/Treap.pm somewhere reachable by @INC. (I set PERL5LIB to a development module tree for stuff I work on, and this is where this module lives. Warning: Large.

```package Algorithm::Treap;
@ISA=(Treap);
*import=\&Treap::import;

#import
package Treap;
use strict;
use warnings;
use base qw(Tie::Hash);

use constant DEBUG =>0;

use constant ROOT => 0;

use constant KEY   => 0;
use constant VALUE => 1;
use constant LEFT  => 2;
use constant RIGHT => 3;
use constant L_PAR => 4;
use constant R_PAR => 5;
use constant UVAL  => 6;
use Data::Dumper;

# no import

#
#
# Binary tree with two keys and ordering maintained simultaneously
#   Tree is stored inorder by the "key" and in heap order by "value"
#   left/right ordered by key, and parent/child by value
#   We also maintain two extra pointers for parent threading.
#   A node is the left parent of all nodes on its left spine,
#   and is the right parent of all node on its right spine.
#   The left spine of a node is the nodes right child and all that nod
+es
#   left children, and the right spine of a node is the nodes left
#   child and all of its right children. This means that
#           D
#        B     F
#       A C  E   G
#   D is the right parent of B and C, and the left parent of E and F
#   B is right parent of A and the left parent of C, F is the right pa
+rent
#   of E and the left parent of G. The right parent of D, F and G is u
+ndef
#   and the left parents of A B D is also undef.
#   This means that the tree can be walked in both directions
#   non recursively, it also means that searches can occur from any no
+de
#   in the tree quite efficiently. Unfortunately extra code is require
#   before this property can be properly exploited.

# We keep four pointers into the tree, 'root' which is the top and mid
+dle
# of the tree, 'left' which holds the leftmost element in the tree, 'r
+ight'
# which holds the rightmost element, and 'itor' which holds the next e
+lement
# we will visit on a call to each() (it is also used when keys() or va
+lues()
# are called).  We also keep track of the count explicitly.
#
# In order to provide for more use values than simply numbers as the d
+efault is
# we provide the ability for the user to supply a sub that is used to
+determine
# if two values are inorder or not.
{
my \$eval_text;

sub import {
warn "import(@_) " if Treap::DEBUG;
my \$callpack = shift;
return 1 unless (@_);
my \$name = join ( "::", __PACKAGE__, shift );
Carp::croak "Expecting key=>value pairs ".join("\n",@_) if @_
+% 2;
my %opts = @_;
key_lt  => 1,
key_gt  => 1,
heap_lt => 1,
DEBUG   => 1
}->{\$_},
keys %opts );

unless (\$eval_text) {
seek DATA, 0, 0;
my \$import_line = 0;
\$eval_text = "";
while (<DATA>) {
if ( my ( \$lhs, \$no ) = /^\s*(\S+\s*)*#\s*(no\s*)?impo
+rt\s*\$/ ) {
if (\$lhs) {
\$eval_text .= \$_ unless \$no;
next;
} else {
\$import_line = !\$no;
}
}
next if !Treap::DEBUG && /^\s*#/ || /^\s*\$/;
\$eval_text .= \$_ if \$import_line;
}
\$eval_text .= "\n'Generated code!';\n";
}
my \$eval = \$eval_text;
foreach my \$opt ( keys %opts ) {
next unless \$opt =~ /^(?:key_|heap_)/;
\$eval =~ s/('Generated code!';\n)/sub \$opt { \\$self->\$opt(
+ \\$_ , \\$_ ) }\n\$1/;
my \$meth_eval = "\\$eval=~s/\\\\$self->\$opt\\s*\\(([^,]+),([
+^)]+)\\)/\$opts{\$opt}/g;";
eval \$meth_eval
or Carp::confess
"Template option substituion \$opt \$opts{\$opt}\n\$meth_e
+val\n failed with '\$@' ";
}
my \$pack = __PACKAGE__;
#\$eval =~ s/package \$pack;/package \$name;\nuse base qw(\$pack);
+/;
\$eval =~ s/package \$pack;/package \$name;\n\@\${name}::ISA=qw(\$p
+ack);/;
if ( defined *Test::More::diag{CODE} ) {
Test::More::diag("Evaling>>\n\$eval\n<<\n") if DEBUG || \$op
+ts{DEBUG};
} else {
print "Evaling>>\n\$eval\n<<\n" if DEBUG || \$opts{DEBUG};
}
eval("{\$eval}");
\$@ and die "Failed eval import build:\n\$@";
return 1;
}
}

sub heap_lt { \$_ < \$_ };
sub key_lt  { \$_ lt \$_ };
sub key_gt  { \$_ gt \$_ };

sub new {
my \$class = shift;

my \$obj = bless {
root  => undef,    # root holds the root of the tree
left  => undef,    # left holds its leftmost element
right => undef,    # right holds its rightmost element
count => 0,        # Number of elements stored
itor  => undef,    # The next node to visited when iterating
},
\$class;

while (@_) {
my ( \$key, \$value ) = ( shift @_, shift @_ );
\$obj->Store( \$key, \$value );
}
return \$obj;
}

#
# A Node in the tree is represented by a 5 element array
#   [
#     key,            # KEY       = 0
#     value,          # VALUE     = 1
#     left_ref,       # LEFT      = 2
#     right_ref,      # RIGHT     = 3
#     left_parent,    # L_PAR     = 4
#     right_parent,   # R_PAR     = 5
#   ]

#
# See Treap::Node for details of the class wrapper for the nodes.

# find_path_to_node()
#
# (\$node,\$path)=\$self->find_path_to_node(\$key);
#
# This is used to find existing nodes or the insert point
# if the nodes don't exist.
# Maintains a "path" through the tree, including the visited nodes
# and which branch was taken to get there.  This was needed for Store
# and DELETE before parent threading as nodes did not necessarily have
# parent pointers. This should be removed by rewriting the routines th
+at
# use it to exploit the parent pointers properly, but ive not had the
+time.
# Returns a list of two parts, the first is the found node or undef
# The second is a ref to a LOL
# [
#   [ root,  0 ],  # the path to the root is 0
#   [ node1, 2 ],  # we used the reference in root-> (left) to get
+to node1
# ]
# The last node in the list will be the found node if it exists.

# import
sub find_path_to_node {
my ( \$self, \$key ) = @_;
my \$node  = \$self->{root};
my @nodes = ( [ \$node, ROOT ] );
my \$index = 0;
while (\$node) {
if ( \$self->key_lt( \$key, \$node->[KEY] ) ) {
\$index = LEFT;
} elsif ( \$self->key_gt( \$key, \$node->[KEY] ) ) {
\$index = RIGHT;
} else {
last;
}
\$node = \$node->[\$index];
push @nodes, [ \$node, \$index ] if \$node;
}
return ( \$node, \@nodes );
}

# Finds a node with the desired key, or returns undef if it doesnt exi
+st
# Used by FETCH and EXISTS as these routines dont need the path return
+ed by
# the similar find_path_to_node() and thus the overhead of building th
+e path can
# be avoided.

sub find_node {
Carp::confess "Scalar context only "
if DEBUG && ( !defined(wantarray) || wantarray );
my ( \$self, \$key ) = @_;
my \$node = \$self->{root};
while (\$node) {
if ( \$self->key_lt( \$key, \$node->[KEY] ) ) {
\$node = \$node->[LEFT];
} elsif ( \$self->key_gt( \$key, \$node->[KEY] ) ) {
\$node = \$node->[RIGHT];
} else {
last;
}
}
return \$node;
}

# _shift_up(\$nodes)
#
# Rotates a node up the tree until heap order has been
# restored, if the tree is already in heap order then does
# nothing. Called by Store() after inserting a new node in_order
#
# Takes a path as returned by find_path_to_node() and ensures that
# its last element is in heap order, rotating the node up the
# path (tree) until it is.
#
# If rise is true, then the bottom node gets rotated to the top of the
# structure (the root) regardless of it s value.

sub _shift_up {
my \$self  = shift;
my \$nodes = shift;
my \$rise  = shift;

print Data::Dumper::Dumper(\$nodes), "\n" if Treap::DEBUG > 2;
my ( \$node, \$pidx ) = @{ pop @\$nodes };
my ( \$parent, \$ppidx );

while (@\$nodes) {
( \$parent, \$ppidx ) = @{ \$nodes->[-1] };
if ( DEBUG > 1 ) {
print \$self->dump_tree(
"_shift_up \$node ["
. join ( ", ", map { defined(\$_) ? \$_ : 'undef' }
+@\$node )
. "] \$pidx" );
}
unless ( !\$rise && \$self->heap_lt( \$node->[VALUE], \$parent->[V
+ALUE] ) ) {
DEBUG > 1 and print "In heap order\n";
last;
} else {
DEBUG > 1 and print "Not in heap order\n";

# we are out of heap order with regard to our parent
my \$ret;

# we need to bring a certain side up, so we
# take the parent and rotate it the other direction
# thus bringing the parent down and the desired node up

if ( \$pidx == LEFT ) {
\$nodes->[-1]->rotate_right;
} else {
\$nodes->[-1]->rotate_left;
}

#print "\$@ : \n",\$self->dump_tree,"\n";
#die if \$@;

pop @\$nodes;

# so now we replace our parent.

if (@\$nodes) {
\$pidx = \$ppidx;
} else {
\$self->{root} = \$node;
\$ppidx = ROOT;
last;
}
}
}
push @\$nodes, [ \$node, \$ppidx ];
print Data::Dumper::Dumper(\$nodes), "\n" if Treap::DEBUG > 2;
return \$node;
}

#
#_shift_down(\$nodes,\$sink)
#
# Takes a path as returned by find_path_to_node and rotates its bottom
# element down (extending the path as it goes) until heap order is
# restored. This is used by Store after an assignment (not insert)
# and by DELETE to move a node to the bottom of the tree.
#
# If the argument \$sink is true then the node to be moved will be rota
+ted
# down to the bottom of the tree regardless of the heap ordering of th
+e node
# and its children, otherwise the rotation will be stopped as soon as
+the
# children of the node are in heap order with regard to the parent.
#
# returns \$nodes, as adjusted by any rotations that may occur.
# also modifies \$nodes in place so it can be access either way.

sub _shift_down {
my ( \$self, \$nodes, \$sink ) = @_;
print Data::Dumper::Dumper(\$nodes), "\n" if Treap::DEBUG > 2;

my ( \$node, \$pidx ) = @{ \$nodes->[-1] };
while (1) {
if ( DEBUG > 1 ) {
print "_shift_down\n";
print \$self->dump_tree();
}
my \$child;
my \$cidx;
if ( \$node->[LEFT] && \$node->[RIGHT] ) {

# two children make sure the one that maintains heap order
# moves up. note that L<R then if N<L then N<R
if ( \$self->heap_lt( \$node->[LEFT][VALUE], \$node->[RIGHT][
+VALUE] ) ) {

# L < R
print "L < R \$self->heap_lt(\$node->[VALUE],\$node->[LEF
+T][VALUE] )\n"
if Treap::DEBUG >= 2;
unless ( !\$sink && \$self->heap_lt( \$node->[VALUE], \$no
+de->[LEFT][VALUE] ) ) {

#\$child=\$node->rotate_right;
\$child = \$nodes->[-1]->rotate_right;
\$cidx  = RIGHT;
}
} else {

# R < L
print "L > R \$self->heap_lt(\$node->[VALUE],\$node->[RIG
+HT][VALUE] )\n"
if Treap::DEBUG >= 2;
unless ( !\$sink && \$self->heap_lt( \$node->[VALUE], \$no
+de->[RIGHT][VALUE] ) ) {

#\$child=\$node->rotate_left;
\$child = \$nodes->[-1]->rotate_left;
\$cidx  = LEFT;
}
}

# Now its either one side
} elsif ( \$node->[LEFT] ) {
print "L? \$self->heap_lt(\$node->[VALUE],\$node->[LEFT][VALU
+E] )\n" if Treap::DEBUG >= 2;
unless ( !\$sink && \$self->heap_lt( \$node->[VALUE], \$node->
+[LEFT][VALUE] ) ) {

#\$child=\$node->rotate_right;
\$child = \$nodes->[-1]->rotate_right;
\$cidx  = RIGHT;
}

# Or the other
} elsif ( \$node->[RIGHT] ) {
print "R? \$self->heap_lt(\$node->[VALUE],\$node->[RIGHT][VAL
+UE] )\n" if Treap::DEBUG > 2;
unless ( !\$sink && \$self->heap_lt( \$node->[VALUE], \$node->
+[RIGHT][VALUE] ) ) {
\$child = \$nodes->[-1]->rotate_left;
\$cidx  = LEFT;
}
} else {

# Or no children
print "no children\n" if DEBUG >= 2;
}

if (\$child) {
print "Child\n" if Treap::DEBUG >= 2;
unless (\$pidx) {
\$self->{root} = \$nodes->[-1];
}
push @\$nodes, [ \$node, \$cidx ];
\$pidx = \$cidx;
} else {
print "No child\n" if Treap::DEBUG >= 2;

#push @\$nodes,[\$node,\$pidx];
last;
}
}
print Data::Dumper::Dumper(\$nodes), "\n" if Treap::DEBUG > 2;
return \$nodes;
}

#
# Store key value
#
# Adds a new node to the data structure or updates the value
# of an existing node. Returns the value that was set.
#
# We insert inorder the new node as a leaf, and then _shift_up
# the node up until heap order is restored (if necessary).
# If we only change the value then we _shift_down first, and then
# _shift_up.  This ensures that heap order is maintained.

sub Store {
my ( \$self, \$key, \$value,\$user ) = @_;

print "Store \$key \$value\n" if DEBUG > 1;

# create the new node

unless ( \$self->{root} ) {
my \$new = Treap::Node->new( [ \$key, \$value, undef, undef, unde
+f, undef,\$user ] );
# The treap is empty, so create a new root.
\$self->{left}  = \$new;
\$self->{right} = \$new;
\$self->{count} = 1;
return \$self->{root} = \$new;
}

# the current node as we walk the tree, starting with root
# the [nodes,branch] passed through in path to insert point
my ( \$node, \$nodes ) = \$self->find_path_to_node(\$key);    # 0==roo
+t, 2==left, 3==right
if (\$node) {
if (@_>3) {
\$node->[UVAL]=\$user
} else {
\$node->[VALUE] = \$value;
\$self->_shift_down(\$nodes);
}
} else {
my \$new = Treap::Node->new( [ \$key, \$value, undef, undef, unde
+f, undef,\$user ] );

# its new, which side does it go on?
(\$node) = @{ \$nodes->[-1] };
if ( \$self->key_lt( \$key, \$node->[KEY] ) ) {
print "Attach left: \$node->[KEY] \$new->[KEY]\n" if Treap::
+DEBUG >= 2;
\$new->[R_PAR] = \$node;
\$new->[L_PAR] = \$node->[L_PAR];
\$node->[LEFT] = \$new;
\$self->{count}++;
push @\$nodes, [ \$new, LEFT ];
\$self->{left} = \$new
if ( !\$new->[L_PAR] and \$self->key_lt( \$new->[KEY], \$s
+elf->{left}[KEY] ) );
} elsif ( \$self->key_gt( \$key, \$node->[KEY] ) ) {
print "Attach Right: \$node->[KEY] \$new->[KEY]\n" if Treap:
+:DEBUG >= 2;
\$new->[L_PAR]  = \$node;
\$new->[R_PAR]  = \$node->[R_PAR];
\$node->[RIGHT] = \$new;
\$self->{count}++;
push @\$nodes, [ \$new, RIGHT ];
\$self->{right} = \$new
if ( !\$new->[R_PAR] and \$self->key_gt( \$new->[KEY], \$s
+elf->{right}[KEY] ) );
} else {
die "Bang! This shouldnt happen! Node keys equal in store!
+\n";
}
}
print \$self->dump_tree("Before:") if DEBUG > 1;
\$self->_shift_up(\$nodes);
print \$self->dump_tree("After:") if DEBUG > 1;

return \$value;
}

# no import

#
# DELETE key
#
# Remove a node with a given key from the data structure.
# We do this by finding the node, setting its value to undef
# and then use _shift_down to rotate it down until it is a
# leaf node, where  we excise it from the tree.

sub Delete {
my ( \$self, \$key ) = @_;
print "Delete '\$key'\n" if Treap::DEBUG > 1;
my ( \$node, \$nodes ) = \$self->find_path_to_node(\$key);
if (\$node) {
print Data::Dumper::Dumper(\$node), "\n" if Treap::DEBUG > 2;
\$self->_shift_down( \$nodes, 'sink' );
my \$side;
( \$node, \$side ) = @{ pop @\$nodes };
unless (\$side) {
\$self->{root}  = undef;
\$self->{left}  = undef;
\$self->{right} = undef;
} else {
my (\$parent) = @{ pop @\$nodes };
@{\$parent}[ \$side, \$side + 2 ] = @{\$node}[ \$side, \$side +
+2 ];
\$self->{left}  = \$parent if \$self->{left} == \$node;
\$self->{right} = \$parent if \$self->{right} == \$node;
}
@\$node[ LEFT, RIGHT, L_PAR, R_PAR ] = ( undef, undef, undef, u
+ndef );
\$self->{count}--;
print \$self->dump_tree("After_Delete")
if Treap::DEBUG > 1;
return \$node->[VALUE];
}
print "does not exist\n" if Treap::DEBUG > 1;
return;
}

#
# Does a node with a given key exist in the tree?
#

sub Exists {
my ( \$self, \$key ) = @_;
return defined \$self->find_node(\$key);
}

#
# Remove all nodes from the tree.
#

sub Clear {
my \$self = shift;
my \$node = \$self->left;
while (\$node) {
my \$newnode = \$node->succ;
\$node->[LEFT]  = undef;
\$node->[RIGHT] = undef;
\$node->[L_PAR] = undef;
\$node->[R_PAR] = undef;
\$node = \$newnode;
}
\$self->{root}  = undef;
\$self->{left}  = undef;
\$self->{right} = undef;
\$self->{itor}  = undef;
\$self->{count} = 0;
}

#
# Initialize the iterator for each(), keys() etc.
#
# 'itor' holds the _next_ node to visit.
#

sub Firstkey {
my \$self = shift;
\$self->{itor} = \$self->{left};
\$self->NEXTKEY;
}

#
# Get the next element to visit, and return the current one.
#
# The order of these events is critical as it must be possible
# to delete the node just returned without disrupting the iteration
# (see the documentation of each() in perlfunc)
#

sub Nextkey {
my \$self = shift;
my \$node = \$self->{itor};
return unless \$node;
\$self->{itor} = \$node->succ;
return wantarray ? @{\$node}[ KEY, VALUE ] : \$node->[KEY];
}

#
# Returns the value of a node with a given key, or undef
# if it doesn't exist.
#

sub Fetch {
my ( \$self, \$key ) = @_;
my \$node = \$self->find_node(\$key);
return \$node->[VALUE] if defined \$node;
return;
}

sub FetchUser {
my ( \$self, \$key ) = @_;
my \$node = \$self->find_node(\$key);
return \$node->[UVAL] if defined \$node;
return;
}

#
# Ensure that any circular references are removed
# upon object destruction.
#

sub DESTROY {
my \$self = shift;
\$self->Clear() if \$self;
}

#####################################################
#
# Auxiliary methods.
#
#

# number of nodes (keys) in tree
sub count { \$_->{count} }

# Left most element
sub left { \$_->{left} }

# Right most element
sub right { \$_->{right} }

# Root element
sub root { \$_->{root} }

sub _sub_as_list {
my \$list = shift;
my @ret  = ("[");
foreach my \$elem (@\$list) {
push @ret, "\t[ \$elem->, \$elem-> ],";
}
return join ( "\n", @ret, "]" );
}

my \$self = shift;
my @list;
my @queue = ( defined \$self->{root} ? [ \$self->{root}, 1 ] : () );
my %hash;
my ( \$kl, \$vl ) = ( 3, 3 );
while (@queue) {
my ( \$node, \$depth ) = @{ shift @queue };
push @list, \$node;
\$kl = length \$node->[KEY]   if \$kl < length \$node->[KEY];
\$vl = length \$node->[VALUE] if \$vl < length \$node->[VALUE];
unless (wantarray) {
\$hash{\$node} = \$hash{\$node}
? die "BF Failure! \$node"
: {
d => \$depth,
x => scalar @list
};
}
if ( \$node->[LEFT] ) {
push @queue, [ \$node->[LEFT], \$depth + 1 ];
}
if ( \$node->[RIGHT] ) {
push @queue, [ \$node->[RIGHT], \$depth + 1 ];
}
}
unless (wantarray) {

my \$ret = "Nodes by Depth\n";
\$ret .= sprintf "%3s(%2s): %\${kl}s / %\${vl}s %3s %3s %3s %3s\n
+",
qw(Id De Key Val Lft Rht LPr RPr);
foreach my \$node (@list) {
\$ret .= sprintf "%3d(%2d): %\${kl}s / %\${vl}s %3d %3d %3d %
+3d\n", \$hash{\$node}{x},
( \$hash{\$node}{d} || die "Unknown \$node" ), @\$node[ KE
+Y, VALUE ],
( map { defined \$_ ? \$hash{\$_}{x} || die "WTF: \$_" : 0
+ }
@\$node[ LEFT, RIGHT, L_PAR, R_PAR ] );
}
print \$ret unless defined wantarray;
return \$ret;
}
return @list;
}

# In list context returns an inorder list of elements
# in scalar context returns a reference to the array
sub in_order {
my \$self = shift;
my \$node = \$self->{left};
my @array;
while (\$node) {
push @array, \$node;
\$node = \$node->succ();
}
!defined(wantarray) and print _sub_as_list( \@array ), "\n";
return wantarray ? @array : \@array;
}

# In list context returns an reverse order list of elements
# in scalar context returns a reference to the array
sub rev_order {
my \$self = shift;
my \$node = \$self->{right};
my @array;
while (\$node) {
push @array, \$node;
\$node = \$node->pred();
}
!defined(wantarray) and print _sub_as_list( \@array ), "\n";
return wantarray ? @array : \@array;
}

# In list context returns a list of elements ordered by value.
# (Heap order) in scalar context returns a reference to the array.

sub heap_order {
my \$self = shift;
my \$array = \$self->_heap_order_recurse( \$self->{root}, [] );
!defined(wantarray) and print _sub_as_list(\$array), "\n";
return wantarray ? @\$array : \$array;
}

# Repeatedly merge the left hand branches of the tree with the right h
+and
# branches. (One trip down a continuous branch will produce inorder el
+ements)
# import
sub _heap_order_recurse {
my ( \$self, \$node, \$array ) = @_;
push @\$array, \$node;
if ( \$node->[LEFT] ) {
print "L" if Treap::DEBUG >= 2;
\$array = \$self->_heap_order_recurse( \$node->[LEFT], \$array ) i
+f \$node->[LEFT];
}
if ( \$node->[RIGHT] ) {
print "R" if Treap::DEBUG >= 2;
my \$right = \$self->_heap_order_recurse( \$node->[RIGHT], [] ) i
+f \$node->[RIGHT];
my \$merge = [];
print " Merging:\n" if Treap::DEBUG >= 2;
;
if ( Treap::DEBUG >= 2 ) {
print "A:", join ( " ", map { \$_->[VALUE] } @\$array ), "\n
+";
print "R:", join ( " ", map { \$_->[VALUE] } @\$right ), "\n
+";

}
while ( @\$array && @\$right ) {
push @\$merge,
( \$self->heap_lt( \$array->[VALUE], \$right->[VALU
+E] ) )
? shift @\$array
: shift @\$right;
}
push @\$merge, @\$array, @\$right;
print "M:", join ( " ", map { \$_->[VALUE] } @\$merge ), "\n"
if Treap::DEBUG >= 2;
return \$merge;
}
print ":", join ( " ", map { \$_->[VALUE] } @\$array ), "\n"
if Treap::DEBUG >= 2;
return \$array;
}

*TIEHASH  =*TIEHASH  = *new;
*EXISTS   =*EXISTS   = *Exists;
*CLEAR    =*CLEAR    = *Clear;
*FIRSTKEY =*FIRSTKEY = *Firstkey;
*NEXTKEY  =*NEXTKEY  = *Nextkey;
*STORE    =*STORE    = *Store ;
*DELETE   =*DELETE   = *Delete;
*FETCH    =*FETCH    = *Fetch;

# no import

# Returns the key or key/value of the top of the heap.
# if a true parameter is provided then this node will be
# deleted.

sub top {
my \$self = shift;
return unless \$self->{root};
my ( \$key, \$value ) = @{ \$self->{root} };
\$self->Delete(\$key) if \$_;
return wantarray ? ( \$key, \$value ) : [ \$key, \$value ];
}

# wrapper to top() for extracting (removing) the top of the heap

sub extract_top {
\$_->top('delete');
}

#####################################################
#
# Dump the data structure.
#

#
# Prints out the key/values using one of the order methods
#

sub print_order {
my \$self  = shift;
my \$order = shift;
my \$array = \$self->\$order();
print "-- \$order --\n";
foreach my \$node (@\$array) {
if ( defined( \$node->[VALUE] ) ) {
printf "%10s / %10s\n", \$node->[KEY], \$node->[VALUE];
} else {
printf "%10s / undef\n", \$node->[KEY];
}
}
print "-- done \$order --\n";
}

#
# Simple indented vertical dump
#
# top is left, bottom is right
#

sub __dump {
my ( \$n, \$s ) = @_;
__dump( \$n->[LEFT], ( " " x length(\$s) ) . "|" ) if \$n->[LEFT];
printf "%s%s %d \n", \$s, \$n->[KEY], \$n->[VALUE];
__dump( \$n->[RIGHT], ( " " x length(\$s) ) . "|" ) if \$n->[RIGHT];
}

sub dump_vert {
__dump( \$_->{root}, "" ) if \$_->{root};
}

sub __center {
my ( \$str, \$w, \$lc, \$rc ) = @_;
no warnings 'uninitialized';
\$lc = " " unless length \$lc;
\$rc = " " unless length \$rc;
while ( length(\$str) < \$w ) {
if ( length(\$str) % 2 ) {
\$str = \$lc . \$str;
} else {
\$str .= \$rc;
}
}
return \$str;
}

#
# Pretty horizontal tree with lines
#

sub dump_tree {

Carp::confess "dump_tree() called in void context" unless wantarra
+y || defined(wantarray);
my \$self = shift;
my @results;
my @board;
my @width;
my \$col = 0;
my \$sub;
my %visited;
\$sub = sub {
my ( \$n, \$d ) = @_;
Carp::confess "Visited \$n twice! From direction \$d" if \$visite
+d{\$n}++;
\$sub->( \$n->[LEFT], \$d + 1 ) if \$n->[LEFT];
my \$cell = sprintf "%s%s=%d%s", \$n->[LEFT] ? "-" : " ", \$n->[K
+EY],
defined( \$n->[VALUE] ) ? \$n->[VALUE] : '0', \$n->[RIGHT] ?
+"-" : " ";

\$width[\$col] = length(\$cell)
if !\$width[\$col] || \$width[\$col] < length(\$cell);

\$board[\$d][ \$col++ ] = \$cell;

\$sub->( \$n->[RIGHT], \$d + 1 ) if \$n->[RIGHT] && \$n->[RIGHT];
};
\$sub->( \$self->{root}, 0 );

DEBUG>1 && print Data::Dumper::Dumper(\@board);

for my \$row ( 0 .. \$#board ) {

#DEBUG>1 && print print \$row;
no warnings 'uninitialized';
my \$data  = "";
my \$line  = "";
my \$draw  = 0;
my \$width =
\$#{ \$board[\$row] } < \$#{ \$board[ \$row + 1 ] }
? \$#{ \$board[ \$row + 1 ] }
: \$#{ \$board[\$row] };
for my \$col ( 0 .. \$width ) {
if ( \$board[\$row][\$col] ) {
\$data .= __center( \$board[\$row][\$col], \$width[\$col] );
my ( \$l, \$r ) = ( \$board[\$row][\$col] =~ /^(-?).*?(-?)\$
+/ );
\$line .= __center( ( \$l || \$r ) ? "+" : ' ', \$width[\$c
+ol], \$l, \$r );
\$draw = \$r;
} else {
\$data .= " " x \$width[\$col];
if (\$draw) {
if ( \$board[ \$row + 1 ][\$col] ) {
\$line .= __center( "+", \$width[\$col], "-" );
\$draw = !\$draw;
} else {
\$line .= "-" x \$width[\$col];
}
} else {
if ( \$board[ \$row + 1 ][\$col] ) {
\$line .= __center( "+", \$width[\$col], " ", "-"
+ );
\$draw = !\$draw;
} else {
\$line .= " " x \$width[\$col];
}
}
}
}
push @results, \$data, \$line;
}
return join "\n", @_, "\$self Nodes:\$self->{count}", @results, "";
}

sub Tied_Hash {
my \$class = shift;
my %hash;
my \$obj = tie %hash, \$class, @_;
return \%hash;
}

#####################################################
package Random::Treap;
use base qw(Treap);

sub FETCH {
my (\$s,\$k)=@_;
return \$s->FetchUser(\$k);
}

sub STORE {
my (\$s,\$k,\$v)=@_;
return \$s->Store(\$k,rand(1),\$v);
}

1;

package Treap::Node;
use strict;
use warnings;
use vars qw/@ISA \$Count/;

use constant ROOT  => Treap::ROOT;
use constant KEY   => Treap::KEY;
use constant VALUE => Treap::VALUE;
use constant LEFT  => Treap::LEFT;
use constant RIGHT => Treap::RIGHT;
use constant L_PAR => Treap::L_PAR;
use constant R_PAR => Treap::R_PAR;
use constant UVAL  => Treap::UVAL;

use Class::Struct 'Treap::_Node' => [
key    => '\$',    # KEY
weight => '\$',    # VALUE
_left  => '\$',    # LEFT
_right => '\$',    # RIGHT
_l_par => '\$',    # L_PAR
_r_par => '\$',    # L_PAR
value  => '\$',    # UVAL
];

BEGIN {
@Treap::Node::ISA = ('Treap::_Node');
\$Count            = 0;
}

sub new {
my \$self = shift;
\$Count++;
if ( @_ == 1 and UNIVERSAL::isa( \$_, "ARRAY" ) ) {
return bless shift @_, \$self;
} else {
return \$self->SUPER::new(@_);
}
}

sub pred {
my \$node = shift;
my \$pred = \$node->[LEFT];
if (\$pred) {
\$node = \$node->[LEFT];
Treap::DEBUG > 2 && print "pred left child  ( \$node->[KEY] / \$
+node->[VALUE]",
( \$pred ? " | \$pred->[KEY] / \$pred->[VALUE]" : " undef" ),
+ " )\n";
while ( \$pred->[RIGHT] ) {
\$pred = \$pred->[RIGHT];
Treap::DEBUG > 2 && print "R";
}
Treap::DEBUG > 2 && print "predecessor ( \$node->[KEY] / \$node-
+>[VALUE]",
( \$pred ? " | \$pred->[KEY] / \$pred->[VALUE]" : " undef" ),
+ " )\n";
} else {
\$pred = \$node->[L_PAR];
Treap::DEBUG > 2 && print "pred left_parent ( \$node->[KEY] / \$
+node->[VALUE]",
( \$pred ? " | \$pred->[KEY] / \$pred->[VALUE]" : " undef" ),
+ " )\n";
}

return \$pred;
}

sub succ {
my \$node = shift;
my \$succ = \$node->[RIGHT];
if (\$succ) {
Treap::DEBUG > 2 && print "succ right child  ( \$node->[KEY] /
+\$node->[VALUE]",
( \$succ ? " | \$succ->[KEY] / \$succ->[VALUE]" : " undef" ),
+ " )\n";

while ( \$succ->[LEFT] ) {
\$succ = \$succ->[LEFT];
Treap::DEBUG > 2 && print "L";
}
Treap::DEBUG > 2 && print " successor ( \$node->[KEY] / \$node->
+[VALUE]",
( \$succ ? " | \$succ->[KEY] / \$succ->[VALUE]" : " undef" ),
+ " )\n";
} else {
\$succ = \$node->[R_PAR];
Treap::DEBUG > 2 && print "succ right thread  ( \$node->[KEY] /
+ \$node->[VALUE]",
( \$succ ? " | \$succ->[KEY] / \$succ->[VALUE]" : " undef" ),
+ " )\n";
}
return \$succ;
}

sub on_side {
my \$self = shift;
if ( \$self->[L_PAR] && \$self->[L_PAR][RIGHT] && \$self->[L_PAR][RIG
+HT] == \$self ) {
return RIGHT;
} elsif ( \$self->[R_PAR] ) {
return LEFT;
} else {
return ROOT;
}
}

sub parent {
my (\$self) = @_;
if ( \$self->[L_PAR] && \$self->[L_PAR][RIGHT] && \$self->[L_PAR][RIG
+HT] == \$self ) {
return \$self->[L_PAR];
} else {
return \$self->[R_PAR];    # if its undef then we are the root!
}
}

sub set_parent_child {
my ( \$self, \$child ) = @_;
if ( \$self->[L_PAR] && \$self->[L_PAR][RIGHT] && \$self->[L_PAR][RIG
+HT] == \$self ) {
\$self->[L_PAR][RIGHT] = \$child;
} elsif ( \$self->[R_PAR] ) {
\$self->[R_PAR][LEFT] = \$child;
}
\$_ = \$child;
return \$self;
}

# Takes a node rotates itself right, it return the node that replaces
+it
# updating the parent is the _callers_ responsibility.

#      S          C
#   C   sr  ->  cl   S
# cl cr            cr sr

sub rotate_right {
my (\$self) = @_;
print "rotate_right\n" if Treap::DEBUG > 1;
Carp::confess "no child\n" if (Treap::DEBUG) && !\$self->[LEFT];
my \$child = \$self->[LEFT];
\$_->set_parent_child(\$child);
my \$child_right = \$child->[RIGHT];
\$child->[RIGHT] = \$self;
\$child->[R_PAR] = \$self->[R_PAR];
\$self->[L_PAR]  = \$child;
\$self->[LEFT]   = \$child_right;

#\$_=\$child;
return \$_->[RIGHT];
}

# Takes a node rotates itself left, it return the node that replaces i
+t
# updating the parent is the _callers_ responsibility.

#   S                C
# sl   C     ->   S   cr
#    cl cr      sl cl

sub rotate_left {
my (\$self) = @_;
print "roate_left\n" if Treap::DEBUG > 1;
Carp::confess "no child\n" if (Treap::DEBUG) && !\$self->[RIGHT];
my \$child = \$self->[RIGHT];
\$_->set_parent_child(\$child);
my \$child_left = \$child->[LEFT];
\$child->[LEFT]  = \$self;
\$self->[RIGHT]  = \$child_left;
\$child->[L_PAR] = \$self->[L_PAR];
\$self->[R_PAR]  = \$child;

#\$_=\$child;
return \$_->[LEFT];
}

sub DESTROY {
my \$self = shift;
--\$Treap::Node::Count;
print "DESTROY [" . (\$Treap::Node::Count) . "] \$self ",
join ( " / ", map { defined \$_ ? \$_ : 'undef' } @{\$self}[ KEY,
+ VALUE ] ), "\n"
if Treap::DEBUG;
}

sub END {
warn "\$Treap::Node::Count undestroyed nodes? Cleanup not correct?
+\n"
if \$Treap::Node::Count;
}

1;
unless (caller) {
package main;
use List::Util qw(shuffle);
my \$test=Treap->new();
my %Test=map { \$_ => int(rand 1000) } ('A'..'Z');

#qw(a 10 b 5 c 5 d 3 e 5 f 4 g 5 h 3 i 5);
foreach my \$key (shuffle keys %Test) {
\$test->Store(\$key,\$Test{\$key});
\$test->print_order('in_order');
\$test->print_order('rev_order');
\$test->print_order('heap_order');
print \$test->dump_tree;
}
my @list;#=qw(A 11 B 11 C 3 D 2 E 1);
while (@list) {
\$test->Store(shift @list,shift @list);
\$test->print_order('in_order');
\$test->print_order('rev_order');
\$test->print_order('heap_order');
print \$test->dump_tree;
}

print "Delete\n";
\$test->Delete('M');
print \$test->dump_tree;
}
1;
package Treap;
1;
__DATA__

Test script for the module. This should be runnable if the Algorithm treap is correctly located in @INC.

```use constant Size            => 10;
use Test::More tests         => ( ( ( Size + 1 ) * 5 ) );
use Algorithm::Treap IntKey =>
#DEBUG=>1,
key_lt  => '\$1 < \$2',
key_gt  => '\$1 > \$2',
heap_lt => '\$1 < \$2',
;
use List::Util 'shuffle';
use strict;
use warnings;
#use Data::BFDump;#
use Data::Dumper;#
{
my \$treap=Treap::IntKey->Tied_Hash();
\$treap->{1}=10;
\$treap->{2}=5;
\$treap->{10}=5;
diag join(", ",keys %\$treap),"\n";
}

srand 501;

my @list = map { \$_ => int rand 100 } shuffle 1 .. Size;

my \$obj = Treap::IntKey->new(@list);
isa_ok( \$obj, 'Treap::IntKey', 'Treap::IntKey' );

diag \$obj->dump_tree;

my \$size = Size;
is( \$obj->count, \$size, "count \$size" );
my @delete = ( -1, shuffle( 1 .. \$size / 2 ), (0) x ( \$size / 2 ) );

while (@delete) {
my \$x = shift @delete;
if ( \$x > -1 ) {
if (\$x) {
eval { \$obj->Delete(\$x); };
ok( !\$@, \$@ || "Delete \$x" );
} else {
eval { \$obj->extract_top; };
ok( !\$@, \$@ || "extract_top" );
}
is( \$obj->count, --\$size, "count \$size" );
} else {
diag "After new()";
}
eval {
my \$last;
foreach my \$item ( \$obj->in_order ) {
die "Not in in_order after delete \$x" if \$last && \$last->k
+ey > \$item->key;
\$last = \$item;
}
};
ok( !\$@, \$@ || "in_order after delete \$x" );
eval {
my \$last;
foreach my \$item ( \$obj->rev_order ) {
die "Not in rev_order after delete \$x" if \$last && \$last->
+key < \$item->key;
\$last = \$item;
}
};
ok( !\$@, \$@ || "rev_order after delete \$x" );
eval {
my \$last;
foreach my \$item ( \$obj->heap_order ) {
die "Not in heap_order after delete \$x" if \$last && \$last-
+>weight > \$item->weight;
\$last = \$item;
}
};
ok( !\$@, \$@ || "heap_order after delete \$x" );
}

my \$t=Random::Treap->Tied_Hash();
\$t->{\$_}=\$_ for ('A'..'Z');
tied(%\$t)->print_order('heap_order');
tied(%\$t)->print_order('in_order');
print Dumper(\$t);
my \$itor=tied(%\$t)->left;
print(\$itor->key),\$itor=\$itor->succ while \$itor;

my \$test=Treap->new();
my %Test=(A => 121, B => 674, C => 970, D => 82, E => 658, F => 957);
print "(".join(", ",map { "\$_ => \$Test{\$_}" } sort keys %Test),")\n";

foreach my \$key (shuffle keys %Test) {
\$test->Store(\$key,\$Test{\$key});

}
\$test->Store('D',600);
\$test->Store('A',500);

\$test->print_order('in_order');
\$test->print_order('rev_order');
\$test->print_order('heap_order');
print \$test->dump_tree;
print "-----\n";
@list=qw(A 11 B 11 C 3 D 2 E 1);
while (@list) {
\$test->Store(shift @list,shift @list);
}
\$test->print_order('in_order');
\$test->print_order('rev_order');
\$test->print_order('heap_order');
print \$test->dump_tree;

print "Delete\n";
\$test->Delete('D');
print \$test->dump_tree;
#print Data::BFDump::Dumper(\%INC);

:-)

---
demerphq

<Elian> And I do take a kind of perverse pleasure in having an OO assembly language...

In reply to Algorithm::Treap (code) by demerphq

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

• Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
• Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
• Read Where should I post X? if you're not absolutely sure you're posting in the right place.
• Posts may use any of the Perl Monks Approved HTML tags:
a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
• You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
 For: Use: & & < < > > [ [ ] ]
• Link using PerlMonks shortcuts! What shortcuts can I use for linking?

Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others studying the Monastery: (5)
As of 2019-11-13 19:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
Strict and warnings: which comes first?

Results (74 votes). Check out past polls.

Notices?