Tree-Ops
view release on metacpan or search on metacpan
lib/Tree/Ops.pm view on Meta::CPAN
return undef unless my $parent = $child->parent; # Parent
my $c = $parent->children; # Siblings
return undef if @$c == 0 or $$c[-1] == $child; # No next child
$$c[+1 + indexOfChildInParent $child] # Next child
}
sub prev($) # Get the previous sibling of the specified child.
{my ($child) = @_; # Child
return undef unless my $parent = $child->parent; # Parent
my $c = $parent->children; # Siblings
return undef if @$c == 0 or $$c[0] == $child; # No previous child
$$c[-1 + indexOfChildInParent $child] # Previous child
}
sub firstMost($) # Return the first most descendant child in the tree starting at this parent or else return B<undef> if this parent has no children.
{my ($parent) = @_; # Parent
my $f;
for(my $p = $parent; $p; $p = $p->first) {$f = $p} # Go first most
$f
}
sub nextMost($) # Return the next child with no children, i.e. the next leaf of the tree, else return B<undef> if there is no such child.
{my ($child) = @_; # Current leaf
return firstMost $child if $child->children->@*; # First most child if we are not starting on a child with no children - i.e. on a leaf.
my $p = $child; # Traverse upwards and then right
$p = $p->parent while $p->isLast; # Traverse upwards
return undef unless $p = $p->next; # Traverse right else we are at the root
firstMost $p # First most child
}
sub prevMost($) # Return the previous child with no children, i.e. the previous leaf of the tree, else return B<undef> if there is no such child.
{my ($child) = @_; # Current leaf
my $p = $child; # Traverse upwards and then left
$p = $p->parent while $p->isFirst; # Traverse upwards
return undef unless $p = $p->prev; # Traverse left else we are at the root
lastMost $p # Last most child
}
sub lastMost($) # Return the last most descendant child in the tree starting at this parent or else return B<undef> if this parent has no children.
{my ($parent) = @_; # Parent
my $f;
for(my $p = $parent; $p; $p = $p->last) {$f = $p} # Go last most
$f
}
sub topMost($) # Return the top most parent in the tree containing the specified child.
{my ($child) = @_; # Child
for(my $p = $child; $p;) {return $p unless my $q = $p->parent; $p = $q} # Go up
confess "Child required";
}
sub mostRecentCommonAncestor($$) # Find the most recent common ancestor of the specified children.
{my ($first, $second) = @_; # First child, second child
return $first if $first == $second; # Same first and second child
my @f = context $first; # Context of first child
my @s = context $second; # Context of second child
my $c; $c = pop @f, pop @s while @f and @s and $f[-1] == $s[-1]; # Remove common ancestors
$c
}
sub go($@) # Return the child at the end of the path starting at the specified parent. A path is a list of zero based children numbers. Return B<undef> if the path is not valid.
{my ($parent, @path) = @_; # Parent, list of zero based children numbers
my $p = $parent; # Start
my $q; defined($q = $p->children->[$_]) ? $p = $q : return undef for @path; # Down # Same first and second child
$p
}
#D1 Location # Verify the current location.
sub context($) # Get the context of the current child.
{my ($child) = @_; # Child
my @c; # Context
for(my $c = $child; $c; $c = $c->parent) {push @c, $c} # Walk up
@c
}
sub isFirst($) # Return the specified child if that child is first under its parent, else return B<undef>.
{my ($child) = @_; # Child
return undef unless my $parent = $child->parent; # Parent
$parent->children->[0] == $child ? $child : undef # There will be at least one child
}
sub isLast($) # Return the specified child if that child is last under its parent, else return B<undef>.
{my ($child) = @_; # Child
return undef unless my $parent = $child->parent; # Parent
my $c = $parent->children;
$parent->children->[-1] == $child ? $child : undef # There will be at least one child
}
sub isTop($) # Return the specified parent if that parent is the top most parent in the tree.
{my ($parent) = @_; # Parent
$parent->parent ? undef : $parent
}
sub singleChildOfParent($) # Return the only child of this parent if the parent has an only child, else B<undef>
{my ($parent) = @_; # Parent
$parent->children->@* == 1 ? $parent->children->[0] : undef # Return only child if it exists
}
sub empty($) # Return the specified parent if it has no children else B<undef>
{my ($parent) = @_; # Parent
$parent->children->@* == 0 ? $parent : undef
}
#D1 Put # Insert children into a tree.
sub putFirst($$) # Place a new child first under the specified parent and return the child.
{my ($parent, $child) = @_; # Parent, child
unshift $parent->children->@*, $child; # Place child
setParentOfChild $child, $parent # Parent child
}
sub putLast($$) # Place a new child last under the specified parent and return the child.
{my ($parent, $child) = @_; # Parent, child
push $parent->children->@*, $child; # Place child
setParentOfChild $child, $parent # Parent child
}
sub putNext($$) # Place a new child after the specified child.
{my ($child, $new) = @_; # Existing child, new child
return undef unless defined(my $i = indexOfChildInParent $child); # Locate child within parent
lib/Tree/Ops.pm view on Meta::CPAN
sub unwrap($) # Unwrap the specified child and return that child.
{my ($child) = @_; # Child
return undef unless defined(my $i = indexOfChildInParent $child); # Locate child within parent
my $parent = $child->parent; # Parent
$_->parent = $parent for $child->children->@*; # Reparent unwrapped children of child
delete $child ->{parent}; # Remove parent of unwrapped child
splice $parent->children->@*, $i, 1, $child->children->@*; # Remove child
$parent
}
sub wrap($;$$) # Wrap the specified child with a new parent and return the new parent optionally setting its L[key] and L[value].
{my ($child, $key, $value) = @_; # Child to wrap, optional key, optional value
return undef unless defined(my $i = indexOfChildInParent $child); # Locate child within existing parent
my $parent = $child->parent; # Existing parent
my $new = new $key, $value; # Create new parent
$new->parent = $parent; # Parent new parent
$new->children = [$child]; # Set children for new parent
splice $parent->children->@*, $i, 1, $new; # Place new parent in existing parent
$child->parent = $new # Reparent child to new parent
}
sub wrapChildren($;$$) # Wrap the children of the specified parent with a new intermediate parent that becomes the child of the specified parent, optionally setting the L[key] and the L[value] ...
{my ($parent, $key, $value) = @_; # Child to wrap, optional key for new wrapping parent, optional value for new wrapping parent
my $new = new $key, $value; # Create new parent
$new->children = $parent->children; # Move children;
$parent->children = [$new]; # Grand parent
$new->parent = $parent; # Parent new parent
$_->parent = $new for $new->children->@*; # Reparent new children
$new # New parent
}
sub merge($) # Unwrap the children of the specified parent with the whose L[key] fields L<smartmatch> that of their parent. Returns the specified parent regardless.
{my ($parent) = @_; # Merging parent
for my $c($parent->children->@*) # Children of parent
{unwrap $c if $c->key ~~ $parent->key; # Unwrap child if like parent
}
$parent
}
sub mergeLikePrev($) # Merge the preceding sibling of the specified child if that sibling exists and the L[key] data of the two siblings L<smartmatch>. Returns the specified child regardless...
{my ($child) = @_; # Child
return $child unless my $prev = $child->prev; # No merge possible if child is first
$child->putFirst($prev->cut)->unwrap # Children to be merged
}
sub mergeLikeNext($) # Merge the following sibling of the specified child if that sibling exists and the L[key] data of the two siblings L<smartmatch>. Returns the specified child regardless...
{my ($child) = @_; # Child
return $child unless my $next = $child->next; # No merge possible if child is last
$child->putLast($next->cut)->unwrap # Children to be merged
}
sub split($) # Make the specified parent a grandparent of each of its children by interposing a copy of the specified parent between the specified parent and each of its children. Ret...
{my ($parent) = @_; # Parent to make into a grand parent
wrap $_, $parent->key for $parent->children->@*; # Grandparent each child
$parent
}
#D1 Traverse # Traverse a tree.
sub by($;$) # Traverse a tree in post-order to process each child with the specified sub and return an array of the results of processing each child. If no sub sub is specified, the ...
{my ($tree, $sub) = @_; # Tree, optional sub to process each child
$sub //= sub{@_}; # Default sub
my @r; # Results
sub # Traverse
{my ($child) = @_; # Child
__SUB__->($_) for $child->children->@*; # Children of child
push @r, &$sub($child); # Process child saving result
}->($tree); # Start at root of tree
@r
}
sub select($$) # Select matching children in a tree in post-order. A child can be selected via named value, array of values, a hash of values, a regular expression or a sub reference.
{my ($tree, $select) = @_; # Tree, method to select a child
my $ref = ref $select; # Selector type
my $sel = # Selection method
$ref =~ m(array)i ? sub{grep{$_[0] eq $_} @$select} : # Array
$ref =~ m(hash)i ? sub{$$select{$_[0]}} : # Hash
$ref =~ m(exp)i ? sub{$_[0] =~ m($select)} : # Regular expression
$ref =~ m(code)i ? sub{&$select($_[0])} : # Sub
sub{$_[0] eq $select}; # Scalar
my @s; # Selection
sub # Traverse
{my ($child) = @_; # Child
push @s, $child if &$sel($child->key); # Select child if it matches
__SUB__->($_) for $child->children->@*; # Each child
}->($tree); # Start at root
@s
}
#D1 Partitions # Various partitions of the tree
sub leaves($) # The set of all children without further children, i.e. each leaf of the tree.
{my ($tree) = @_; # Tree
my @leaves; # Leaves
sub # Traverse
{my ($child) = @_; # Child
if (my @c = $child->children->@*) # Children of child
{__SUB__->($_) for @c; # Process children of child
}
else
{push @leaves, $child; # Save leaf
}
}->($tree); # Start at root of tree
@leaves
}
sub parentsOrdered($$$) #P The set of all parents in the tree, i.e. each non leaf of the tree, i.e the interior of the tree in the specified order.
{my ($tree, $preorder, $reverse) = @_; # Tree, pre-order if true else post-order, reversed if true
my @parents; # Parents
sub # Traverse
{my ($child) = @_; # Child
if (my @c = $child->children->@*) # Children of child
{@c = reverse @c if $reverse; # Reverse if requested
push @parents, $child if $preorder; # Pre-order
__SUB__->($_) for @c; # Process children of child
( run in 2.684 seconds using v1.01-cache-2.11-cpan-524268b4103 )