 Clear questions and runnable codeget the best and fastest answer PerlMonks

### Algorithm::Treap (code)

by demerphq (Chancellor)
 on Sep 07, 2003 at 15:21 UTC ( #289585=note: print w/replies, xml ) 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...

Replies are listed 'Best First'.
Re: Algorithm::Treap (code)
by Anonymous Monk on Sep 07, 2003 at 21:27 UTC
Uh oh (what's going on?):
```perl treap.pm
Subroutine import redefined at Treap.pm line 67.
Subroutine heap_lt redefined at Treap.pm line 127.
Subroutine key_lt redefined at Treap.pm line 128.
Subroutine key_gt redefined at Treap.pm line 129.
Subroutine new redefined at Treap.pm line 131.
Subroutine find_path_to_node redefined at Treap.pm line 184.
Subroutine find_node redefined at Treap.pm line 209.
Subroutine _shift_up redefined at Treap.pm line 241.
Subroutine _shift_down redefined at Treap.pm line 316.
Subroutine Store redefined at Treap.pm line 410.
Subroutine Delete redefined at Treap.pm line 484.
Subroutine Exists redefined at Treap.pm line 517.
Subroutine Clear redefined at Treap.pm line 526.
Subroutine Firstkey redefined at Treap.pm line 551.
Subroutine Nextkey redefined at Treap.pm line 565.
Subroutine Fetch redefined at Treap.pm line 579.
Subroutine FetchUser redefined at Treap.pm line 586.
Subroutine DESTROY redefined at Treap.pm line 598.
Subroutine count redefined at Treap.pm line 611.
Subroutine left redefined at Treap.pm line 614.
Subroutine right redefined at Treap.pm line 617.
Subroutine root redefined at Treap.pm line 620.
Subroutine _sub_as_list redefined at Treap.pm line 622.
Subroutine breadth_first redefined at Treap.pm line 631.
Subroutine in_order redefined at Treap.pm line 676.
Subroutine rev_order redefined at Treap.pm line 690.
Subroutine heap_order redefined at Treap.pm line 705.
Subroutine _heap_order_recurse redefined at Treap.pm line 715.
Subroutine top redefined at Treap.pm line 764.
Subroutine extract_top redefined at Treap.pm line 774.
Subroutine print_order redefined at Treap.pm line 788.
Subroutine __dump redefined at Treap.pm line 810.
Subroutine dump_vert redefined at Treap.pm line 817.
Subroutine __center redefined at Treap.pm line 821.
Subroutine dump_tree redefined at Treap.pm line 840.
Subroutine Tied_Hash redefined at Treap.pm line 913.
Subroutine FETCH redefined at treap.pm line 924.
Subroutine STORE redefined at treap.pm line 929.
function 'new' already defined in package Treap::_Node at treap.pm line 950
BEGIN failed--compilation aborted at treap.pm line 958.
```

Uh oh (what's going on?):

I dont know. This doesnt make sense to me. Obviously it doesnt happen here, and at least one other person has had the code pass all tests. Can you double check that you copied the code correctly?

---
demerphq

<Elian> And I do take a kind of perverse pleasure in having an OO assembly language...
If treap.pm is in the current directory, it doesn't work, but if I am not, it works. Very weird.
Perl 5.6, Windows NT ActivePerl Build 633. I didn't copy anything, I clicked the download code link, and saved as.

Create A New User
Node Status?
node history
Node Type: note [id://289585]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (8)
As of 2019-12-12 14:49 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?

No recent polls found

Notices?