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 nodes # 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 parent # of E and the left parent of G. The right parent of D, F and G is undef # 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 node # 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 middle # of the tree, 'left' which holds the leftmost element in the tree, 'right' # which holds the rightmost element, and 'itor' which holds the next element # we will visit on a call to each() (it is also used when keys() or values() # are called). We also keep track of the count explicitly. # # In order to provide for more use values than simply numbers as the default 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 () { if ( my ( \$lhs, \$no ) = /^\s*(\S+\s*)*#\s*(no\s*)?import\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_eval\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(\$pack);/; if ( defined *Test::More::diag{CODE} ) { Test::More::diag("Evaling>>\n\$eval\n<<\n") if DEBUG || \$opts{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 that # 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 exist # Used by FETCH and EXISTS as these routines dont need the path returned by # the similar find_path_to_node() and thus the overhead of building the 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->[VALUE] ) ) { 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 rotated # down to the bottom of the tree regardless of the heap ordering of the 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 Lheap_lt( \$node->[LEFT][VALUE], \$node->[RIGHT][VALUE] ) ) { # L < R print "L < R \$self->heap_lt(\$node->[VALUE],\$node->[LEFT][VALUE] )\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; } } else { # R < L print "L > R \$self->heap_lt(\$node->[VALUE],\$node->[RIGHT][VALUE] )\n" if Treap::DEBUG >= 2; unless ( !\$sink && \$self->heap_lt( \$node->[VALUE], \$node->[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][VALUE] )\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][VALUE] )\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, undef, 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==root, 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, undef, 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], \$self->{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], \$self->{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, undef ); \$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[ KEY, 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 hand # branches. (One trip down a continuous branch will produce inorder elements) # 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 ) if \$node->[LEFT]; } if ( \$node->[RIGHT] ) { print "R" if Treap::DEBUG >= 2; my \$right = \$self->_heap_order_recurse( \$node->[RIGHT], [] ) if \$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][VALUE] ) ) ? 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 wantarray || 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 \$visited{\$n}++; \$sub->( \$n->[LEFT], \$d + 1 ) if \$n->[LEFT]; my \$cell = sprintf "%s%s=%d%s", \$n->[LEFT] ? "-" : " ", \$n->[KEY], 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[\$col], \$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][RIGHT] == \$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][RIGHT] == \$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][RIGHT] == \$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 it # 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__ ##```## 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->key > \$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); ```