use v6-alpha;
class Tree-0.0.2;
## ----------------------------------------------------------------------------
## attributes
has $.node is rw;
has $.depth;
has $.height;
has $.width;
has $!parent;
has @!children;
## ----------------------------------------------------------------------------
## constructors
submethod BUILD ($node?) {
$.depth = -1;
$.height = 1;
$.width = 1;
$.node = $node if $node.defined;
}
## ----------------------------------------------------------------------------
## accessors and mutators
method parent ($self:) returns Tree {
return $!parent;
}
## ----------------------------------------------------------------------------
## private methods
my method set_height ($self: Tree $child) returns Void {
my $child_height = $child.height();
return if $.height >= $child_height + 1;
$.height = $child_height + 1;
# and now bubble up to the parent (unless we are the root)
$self.parent()!set_height($self) unless $self.is_root();
}
my method set_width ($self: Tree $child) returns Void {
return if $.width > $self.child_count();
my $child_width = $child.width();
$.width += $child_width;
# and now bubble up to the parent (unless we are the root)
$self.parent()!set_width($self) unless $self.is_root();
}
my method set_depth ($self: Int $depth) returns Void { $.depth = $depth }
my method remove_parent returns Void { $!parent = undef }
my method set_parent ($self: Tree $parent) returns Void {
$!parent = $parent;
$.depth = $parent.depth() + 1;
}
## ----------------------------------------------------------------------------
## informational methods
method is_root returns Bool { $!parent.defined ?? 0 !! 1 }
method is_leaf returns Bool { +@!children == 0 }
method child_count returns Int { +@!children }
method size ($self:) returns Int {
my $size = 1;
for @!children -> $child {
$size += $child.size();
}
return $size;
}
## ----------------------------------------------------------------------------
## adding children
method add_child ($self: Tree $child) returns Tree {
$child!set_parent($self);
$self!set_height($child);
$self!set_width($child);
$child.fix_depth() unless $child.is_leaf();
@!children.push($child);
$self;
}
method add_children ($self: *@children) returns Tree {
for @children -> $child {
$self.add_child($child);
}
$self;
}
## ----------------------------------------------------------------------------
## getting children
method get_child ($self: Int $index) returns Tree { @!children[$index] }
method get_all_children returns Array of Tree { @!children }
## ----------------------------------------------------------------------------
## inserting children
method insert_children ($self: Int $index, *@trees) returns Void {
# check the bounds of our children
# against the index given
($index <= $self.child_count())
|| die "Index Out of Bounds : got ($index) expected no more than (" ~ $self.child_count() ~ ")";
(@trees)
|| die "Insufficient Arguments : no tree(s) to insert";
for @trees -> $tree {
$tree!set_parent($self);
$self!set_height($tree);
$self!set_width($tree);
$tree.fix_depth() unless $tree.is_leaf();
}
# if index is zero, use this optimization
if ($index == 0) {
@!children.unshift(@trees);
}
# otherwise do some heavy lifting here
else {
@!children = (
@!children[0 .. ($index - 1)],
@trees,
@!children[$index .. (@!children - 1)],
);
}
}
# insert_child is really the same as
# insert_children, you are just inserting
# and array of one tree
our &Tree::insert_child ::= &Tree::insert_children;
## ----------------------------------------------------------------------------
## removing children
method remove_child_at ($self: Int $index) returns Tree {
($self.child_count() != 0)
|| die "Illegal Operation : There are no children to remove";
# check the bounds of our children
# against the index given
($index < $self.child_count())
|| die "Index Out of Bounds : got ($index) expected no more than (" ~ $self.child_count() ~ ")";
my $removed_child;
# if index is zero, use this optimization
if ($index == 0) {
$removed_child = @!children.shift;
}
# if index is equal to the number of children
# then use this optimization
elsif ($index == +@!children) {
$removed_child = @!children.pop();
}
# otherwise do some heavy lifting here
else {
$removed_child = @!children[$index];
@!children = (
@!children[0 .. ($index - 1)],
@!children[($index + 1) .. (@!children - 1)],
);
}
# make sure we fix the height
$self.fix_height();
$self.fix_width();
# make sure that the removed child
# is no longer connected to the parent
# so we change its parent to ROOT
$removed_child!remove_parent();
# and now we make sure that the depth
# of the removed child is aligned correctly
$removed_child.fix_depth() unless $removed_child.is_leaf();
# return ths removed child
# it is the responsibility
# of the user of this module
# to properly dispose of this
# child (and all its sub-children)
return $removed_child;
}
method remove_child ($self: Tree $child_to_remove) returns Tree {
my $index = 0;
for @!children -> $child {
($child === $child_to_remove) && return $self.remove_child_at($index);
$index++;
}
die "Child Not Found : cannot find object ($child_to_remove) in self";
}
## ----------------------------------------------------------------------------
## sibling methods
method get_sibling ($self: Int $index) returns Tree {
(!$self.is_root())
|| die "Insufficient Arguments : cannot get siblings to a ROOT tree";
$self.parent().get_child($index);
}
method get_all_siblings ($self:) returns Array {
(!$self.is_root())
|| die "Insufficient Arguments : cannot get siblings to a ROOT tree";
$self.parent().get_all_children();
}
method add_sibling ($self: Tree $sibling) returns Tree {
(!$self.is_root())
|| die "Insufficient Arguments : cannot add a sibling to a ROOT tree";
$self.parent().add_child($sibling);
}
method add_siblings ($self: *@siblings) returns Tree {
(!$self.is_root())
|| die "Insufficient Arguments : cannot add siblings to a ROOT tree";
$self.parent().add_children(@siblings);
}
method insert_siblings ($self: Int $index, *@siblings) returns Tree {
(!$self.is_root())
|| die "Insufficient Arguments : cannot insert siblings to a ROOT tree";
$self.parent().insert_children($index, @siblings);
}
# insertSibling is really the same as
# insertSiblings, you are just inserting
# and array of one tree
our &Tree::insert_sibling ::= &Tree::insert_siblings;
# I am not permitting the removal of siblings
# as I think in general it is a bad idea
## ----------------------------------------------------------------------------
## traversal
method traverse ($self: Code $func, Str $traversal_order?) returns Void {
if !$traversal_order.defined || $traversal_order.lc() eq 'pre_order' {
$self.pre_order_traverse($func)
}
else {
$self.post_order_traverse($func)
}
}
method pre_order_traverse ($self: Code $func) returns Void {
for @!children -> $child is rw {
$func($child);
$child.traverse($func);
}
}
method post_order_traverse ($self: Code $func) returns Void {
for @!children -> $child is rw {
$child.traverse($func);
$func($child);
}
}
method traverse_iter($self: Str $traversal_order?) returns Code {
return coro {
$self.traverse(sub { yield $^node }, $traversal_order);
};
}
## ----------------------------------------------------------------------------
## utility methods
# NOTE:
# Occasionally one wants to have the
# depth available for various reasons
# of convience. Sometimes that depth
# field is not always correct.
# If you create your tree in a top-down
# manner, this is usually not an issue
# since each time you either add a child
# or create a tree you are doing it with
# a single tree and not a hierarchy.
# If however you are creating your tree
# bottom-up, then you might find that
# when adding hierarchies of trees, your
# depth fields are all out of whack.
# This is where this method comes into play
# it will recurse down the tree and fix the
# depth fields appropriately.
# This method is called automatically when
# a subtree is added to a child array
method fix_depth ($self:) returns Void {
# make sure the tree's depth
# is up to date all the way down
$self.traverse(-> $t {
$t!set_depth($t.parent().depth() + 1);
});
}
# NOTE:
# This method is used to fix any height
# discrepencies which might arise when
# you remove a sub-tree
method fix_height ($self:) returns Void {
# we must find the tallest sub-tree
# and use that to define the height
my $max_height = 0;
unless ($self.is_leaf()) {
for @!children -> $child is rw {
my $child_height = $child.height();
$max_height = $child_height if $max_height < $child_height;
}
}
# if there is no change, then we
# need not bubble up through the
# parents
return if $.height == ($max_height + 1);
# otherwise ...
$.height = $max_height + 1;
# now we need to bubble up through the parents
# in order to rectify any issues with height
$self.parent().fix_height() unless $self.is_root();
}
method fix_width ($self:) {
my $fixed_width = 0;
for @!children -> $child is rw {
$fixed_width += $child.width();
}
$.width = $fixed_width;
$self.parent().fix_width() unless $self.is_root();
}
method get_index ($self:) returns Int {
return -1 if $self.is_root();
my $index = 0;
for $self.parent().get_all_children() -> $sibling {
($sibling === $self) && return $index;
$index++;
}
}
=pod
=head1 NAME
Tree - A basic I<n>-ary tree
=head1 SYNOPSIS
use Tree;
my $root = Tree.new(:node<0>).add_children(
Tree.new(:node<1>).add_children(
Tree.new(:node<1.1>),
Tree.new(:node<1.2>),
Tree.new(:node<1.3>),
),
Tree.new(:node<2>).add_children(
Tree.new(:node<2.1>).add_children(
Tree.new(:node<2.1.1>).add_children(
Tree.new(:node<2.1.1.1)
),
Tree.new(:node<2.1.2>),
)
)
);
$root.traverse(-> $t {
say((' ' x $t.depth()) ~ $t.node())
});
=head1 DESCRIPTION
=head1 METHODS
=over 4
=item B<new ($node?) returns Tree>
=item B<node ($self: $node?)>
=item B<depth returns Int>
=item B<parent ($self: Tree $parent?) returns Tree>
=item B<is_root returns Bool>
=item B<is_leaf returns Bool>
=item B<child_count returns Int>
=item B<add_child ($self: Tree $child) returns Tree>
=item B<add_children ($self: *@children) returns Tree>
=item B<get_child ($self: Int $index) returns Tree>
=item B<get_all_children returns Array>
=item B<traverse ($self: Code $func) returns Void>
=back
=head1 TODO
=over 4
=item Write more docs
=item Convert more tests
A good amount of Tree::Simple's test will not be relevant though.
=item Create a Visitor class
This would also be a good use for Roles.
=back
=head1 AUTHOR
stevan little, E<lt>stevan@iinteractive.comE<gt>
=head1 COPYRIGHT
Copyright (c) 2005. Stevan Little. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut