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
#
# Threaded Treap
#
# 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 = @_;
my @bad;
Carp::confess "Unknown options @bad"
if @bad = grep( !{
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(
+ \$_[1] , \$_[2] ) }\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 { $_[1] < $_[2] };
sub key_lt { $_[1] lt $_[2] };
sub key_gt { $_[1] gt $_[2] };
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->[2] (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][0]->rotate_right;
} else {
$nodes->[-1][0]->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][0]->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][0]->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][0]->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][0]->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][0];
}
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) {
# it already exists
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->breadth_first if DEBUG > 1;
$self->_shift_up($nodes);
$self->breadth_first if DEBUG > 1;
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 { $_[0]->{count} }
# Left most element
sub left { $_[0]->{left} }
# Right most element
sub right { $_[0]->{right} }
# Root element
sub root { $_[0]->{root} }
sub _sub_as_list {
my $list = shift;
my @ret = ("[");
foreach my $elem (@$list) {
push @ret, "\t[ $elem->[0], $elem->[1] ],";
}
return join ( "\n", @ret, "]" );
}
sub breadth_first {
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->[0][VALUE], $right->[0][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 $_[0];
return wantarray ? ( $key, $value ) : [ $key, $value ];
}
# wrapper to top() for extracting (removing) the top of the heap
sub extract_top {
$_[0]->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( $_[0]->{root}, "" ) if $_[0]->{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( $_[0], "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;
}
$_[0] = $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];
$_[0]->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;
#$_[0]=$child;
return $_[0]->[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];
$_[0]->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;
#$_[0]=$child;
return $_[0]->[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.
