Forest::Tree - An n-ary tree

  use Forest::Tree;

  my $t = Forest::Tree->new(
      node     => 1,
      children => [
          Forest::Tree->new(
              node     => 1.1,
              children => [
                  Forest::Tree->new(node => 1.1.1),
                  Forest::Tree->new(node => 1.1.2),
                  Forest::Tree->new(node => 1.1.3),
              ]
          ),
          Forest::Tree->new(node => 1.2),
          Forest::Tree->new(
              node     => 1.3,
              children => [
                  Forest::Tree->new(node => 1.3.1),
                  Forest::Tree->new(node => 1.3.2),
              ]
          ),
      ]
  );

  $t->traverse(sub {
      my $t = shift;
      print(('    ' x $t->depth) . ($t->node || '\undef') . "\n");
  });

package Forest::Tree;
use Moose;
use MooseX::AttributeHelpers;

use Scalar::Util 'reftype', 'refaddr';
use List::Util   'sum', 'max';

our $VERSION   = '0.09';
our $AUTHORITY = 'cpan:STEVAN';

extends qw(Forest::Tree::Pure);

#has '+node' => ( is => 'rw' );
has 'node' => (
    traits => [qw(StorableClone)],
    is  => 'rw',
    isa => 'Item',
);

sub set_node {
    my ( $self, $new ) = @_;
    $self->node($new);
    $self;
}

has 'parent' => (
    traits    => [qw(NoClone)],
    reader      => 'parent',
    writer      => '_set_parent',
    predicate   => 'has_parent',
    clearer     => 'clear_parent',
    isa         => 'Maybe[Forest::Tree]',
    weak_ref => 1,
    handles     => {
        'add_sibling'       => 'add_child',
        'get_sibling_at'    => 'get_child_at',
        'insert_sibling_at' => 'insert_child_at',
    },
);

#has '+children' => (
#    is        => 'rw',
has 'children' => (
    traits    => [qw(Clone)],
    metaclass => 'Collection::Array',
    is        => 'rw',
    isa       => 'ArrayRef[Forest::Tree]',
    lazy      => 1,
    default   => sub { [] },
    provides  => {
        'get'   => 'get_child_at',
        'count' => 'child_count',
    },
    trigger   => sub {
        my ($self, $children) = @_;
        foreach my $child (@$children) {
            $child->_set_parent($self);
            $self->clear_height if $self->has_height;
            $self->clear_size   if $self->has_size;
        }
    }
);

after 'clear_size' => sub {
    my $self = shift;
    $self->parent->clear_size
        if $self->has_parent && $self->parent->has_size;
};

after 'clear_height' => sub {
    my $self = shift;
    $self->parent->clear_height
        if $self->has_parent && $self->parent->has_height;
};

## informational
sub is_root { !(shift)->has_parent }

## depth
sub depth { ((shift)->parent || return -1)->depth + 1 }

## child management

sub add_child {
    my ($self, $child) = @_;
    (blessed($child) && $child->isa(ref $self))
        || confess "Child parameter must be a " . ref($self) . " not (" . (defined $child ? $child : 'undef') . ")";
    $child->_set_parent($self);
    $self->clear_height if $self->has_height;
    $self->clear_size   if $self->has_size;
    push @{ $self->children } => $child;
    $self;
}

sub replace {
    my ( $self, $replacement ) = @_;

    confess "Can't replace root" if $self->is_root;

    $self->parent->set_child_at( $self->get_index_in_siblings, $replacement );

    return $replacement;
}

sub add_children {
    my ($self, @children) = @_;
    $self->add_child($_) for @children;
    return $self;
}

sub set_child_at {
    my ( $self, $index, $child ) = @_;

    (blessed($child) && $child->isa(ref $self))
        || confess "Child parameter must be a " . ref($self) . " not (" . (defined $child ? $child : 'undef') . ")";

    $self->clear_height if $self->has_height;
    $self->clear_size   if $self->has_size;

    my $children = $self->children;

    $children->[$index]->clear_parent;

    $children->[$index] = $child;
    $child->_set_parent($self);

    $self;
}

sub insert_child_at {
    my ($self, $index, $child) = @_;
    (blessed($child) && $child->isa(ref $self))
        || confess "Child parameter must be a " . ref($self) . " not (" . (defined $child ? $child : 'undef') . ")";
    $child->_set_parent($self);
    $self->clear_height if $self->has_height;
    $self->clear_size   if $self->has_size;
    splice @{ $self->children }, $index, 0, $child;
    $self;
}

sub remove_child_at {
    my ($self, $index) = @_;
    $self->clear_height if $self->has_height;
    $self->clear_size   if $self->has_size;
    my $child = splice @{ $self->children }, $index, 1;
    $child->clear_parent;
    $child;
}

##siblings

sub siblings {
    my $self = shift;
    return [] unless $self->has_parent;
    [ grep { $self->uid ne $_->uid } @{ $self->parent->children } ];
}

sub get_index_in_siblings {
    my ($self) = @_;
    return -1 if $self->is_root;

    $self->parent->get_child_index($self);
}

## cloning

sub clone_and_detach { shift->clone(@_) }

sub to_pure_tree {
    my $self = shift;

    $self->reconstruct_with_class("Forest::Tree::Pure");
}

sub to_mutable_tree {
    my $self = shift;

    return $self;
}

__PACKAGE__->meta->make_immutable;

no Moose; 1;

__END__