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__
[download]

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;
diag scalar $obj->breadth_first;

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);
[download]