Forest::Tree::Pure - An n-ary tree

  use Forest::Tree;

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

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

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

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

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

with qw(MooseX::Clone);

has 'node' => (
    is        => 'ro',
    isa       => 'Item',
    predicate => 'has_node',
);

has 'uid'  => (
    is      => 'rw',
    isa     => 'Value',
    lazy    => 1,
    default => sub { (overload::StrVal($_[0]) =~ /\((.*?)\)$/)[0] },
);

has 'children' => (
    metaclass => 'Collection::Array',
    is        => 'ro',
    isa       => 'ArrayRef[Forest::Tree::Pure]',
    lazy      => 1,
    default   => sub { [] },
    provides  => {
        'get'   => 'get_child_at',
        'count' => 'child_count',
    },
);

has 'size' => (
    traits => [qw(NoClone)],
    is         => 'ro',
    isa        => 'Int',
    lazy_build => 1,
);

sub _build_size {
    my $self = shift;

    if ( $self->is_leaf ) {
        return 1;
    } else {
        return 1 + sum map { $_->size } @{ $self->children };
    }
}

has 'height' => (
    traits => [qw(NoClone)],
    is         => 'ro',
    isa        => 'Int',
    lazy_build => 1,
);

sub _build_height {
    my $self = shift;

    if ( $self->is_leaf ) {
        return 0;
    } else {
        return 1 + max map { $_->height } @{ $self->children };
    }
}

## informational
sub is_leaf { (shift)->child_count == 0 }

## traversal
sub traverse {
    my ($self, @args) = @_;

    $_->visit(@args) for @{ $self->children };
}

sub visit {
    my ( $self, $f, @args ) = @_;

    $self->fmap_cont(sub {
        my ( $tree, $cont, @args ) = @_;
        $tree->$f(@args);
        $cont->();
    });
}

sub fmap_cont {
    my ( $self, @args ) = @_;

    unshift @args, "callback" if @args % 2 == 1;

    my %args = ( depth => 0, path => [], index_path => [], @args );

    my $f = $args{callback};

    (defined($f))
        || confess "Cannot traverse without traversal function";
    (!ref($f) or reftype($f) eq "CODE")
        || confess "Traversal function must be a CODE reference or method name, not: $f";

    $self->$f(
        sub {
            my ( @inner_args ) = @_;
            unshift @inner_args, "callback" if @inner_args % 2 == 1;
            my $children = $args{children} || $self->children;

            my %child_args = ( %args, depth => $args{depth} + 1, path => [ @{ $args{path} }, $self ], parent => $self, @inner_args );

            my @index_path  = @{ $args{index_path} };

            my $i = 0;
            map {
                my $index = $i++;
                $_->fmap_cont(
                    %child_args,
                    index => $index,
                    index_path => [ @index_path, $index ],
                )
            } @$children;
        },
        %args,
    );
}

sub locate {
    my ( $self, @path ) = @_;

    my @nodes = $self->descend(@path);

    return $nodes[-1];
}

sub descend {
    my ( $self, @path ) = @_;

    if ( @path ) {
        my ( $head, @tail ) = @path;

        if ( my $child = $self->get_child_at($head) ) {
            return ( $self, $child->descend(@tail) );
        } else {
            confess "No such child $head";
        }
    } else {
        return $self;
    }
}

sub transform {
    my ( $self, $path, $method, @args ) = @_;

    if ( @$path ) {
        my ( $i, @path ) = @$path;

        my $targ = $self->get_child_at($i);

        my $transformed = $targ->transform(\@path, $method, @args);

        if ( refaddr($transformed) == refaddr($targ) ) {
            return $self;
        } else {
            return $self->set_child_at( $i => $transformed );
        }
    } else {
        return $self->$method(@args);
    }
}

sub set_node {
    my ( $self, $node ) = @_;

    $self->clone( node => $node );
}

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

    return $replacement;
}

sub add_children {
    my ( $self, @additional_children ) = @_;

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

    my @children = @{ $self->children };

    push @children, @additional_children;

    return $self->clone( children => \@children );
}

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

    $self->add_children($child);
}

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') . ")";

    my @children = @{ $self->children };

    $children[$index] = $child;

    $self->clone( children => \@children );
}

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

    my @children = @{ $self->children };

    confess "No child at index '$index'" if @children <= $index;

    splice @children, $index, 1;

    $self->clone( children => \@children );

}

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

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

    my @children = @{ $self->children };

    confess "'$index' is out of bounds" if @children < $index;

    splice @children, $index, 0, $child;

    $self->clone( children => \@children );
}

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

    my $index = 0;
    foreach my $sibling (@{ $self->children }) {
        (refaddr($sibling) eq refaddr($child)) && return $index;
        $index++;
    }

    return;
}

sub reconstruct_with_class {
    my ( $self, $class ) = @_;

    confess "No class provided" unless defined($class);

    return $class->new(
        node => $self->node,
        children => [
            map { $_->reconstruct_with_class($class) } @{ $self->children },
        ],
    );
}

sub to_pure_tree {
    my $self = shift;

    return $self;
}

sub to_mutable_tree {
    my $self = shift;

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

__PACKAGE__->meta->make_immutable;

no Moose; 1;

__END__