Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??

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

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

package Algorithm::Treap; @ISA=(Treap); *import=\&Treap::import; #import package Treap; use strict; use warnings; use base qw(Tie::Hash); use constant DEBUG =>0; use constant ROOT => 0; use constant KEY => 0; use constant VALUE => 1; use constant LEFT => 2; use constant RIGHT => 3; use constant L_PAR => 4; use constant R_PAR => 5; use constant UVAL => 6; use Data::Dumper; # no import # # 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.

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);

:-)


---
demerphq

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

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

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



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others pondering the Monastery: (7)
    As of 2014-07-10 10:19 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      When choosing user names for websites, I prefer to use:








      Results (206 votes), past polls