Tree::Base - a base class for trees

  package MyTree;
  use base 'Tree::Base';

  sub blah {shift->{blah}}




  use MyTree;
  my $tree = MyTree->new(blah => ...);
  my $child = $tree->create_child(blah => ...);
  $child->create_child(blah => ...);

  my $tree = Tree::Base->new(%data);

  my $child = $tree->create_child(%data);

  $tree->add_child($child);

  my $parent = $tree->parent;

  my @children = $tree->children;

  my $child = $toc->child($i);

  my $root = $tree->root;

  $tree->is_root;

  my @descendants = $toc->descendants;

  my @nodes = $tree->older_siblings;

  my @nodes = $tree->younger_siblings;

  $younger = $toc->next_sibling;

  $older = $tree->prev_sibling;

  my @ancestors = $tree->ancestors;

  my @ans = $tree->rmap(sub {...});

package Tree::Base;
$VERSION = v0.10.2;

use warnings;
use strict;
use Carp;

use Scalar::Util ();

sub new {
  my $package = shift;
  my $class = ref($package) || $package;
  my $self = {@_};
  bless($self, $class);
  # TODO parent
  die "todo" if($self->{parent});
  return($self);
} # new ################################################################

sub create_child {
  my $self = shift;
  my $child = $self->new(@_);

  return($self->add_child($child));
} # create_child #######################################################

sub add_child {
  my $self = shift;
  my $child = shift;

  croak("cannot add rooted child") if($child->{parent});

  $child->{parent} = $self;
  my $root = $self->root;
  $child->{root} = $root;
  Scalar::Util::weaken($child->{parent});
  Scalar::Util::weaken($child->{root});

  foreach my $child ($child->children) {
    $child->rmap(sub {Scalar::Util::weaken(shift->{root} = $root); ()})
  }

  my $kids = $self->{children} ||= [];
  push(@$kids, $child);

  return($child);
} # add_child ##########################################################

sub children {
  my $self = shift;
  return($self->{children} ? @{$self->{children}} : ());
} # children ###########################################################

sub child {
  my $self = shift;
  my ($i) = @_;
  (1 == @_) or croak "wrong number of arguments";

  my @children = $self->children;
  $children[$i] or croak "no child at index $i";
  return($children[$i]);
} # end subroutine child definition
########################################################################

sub root {
  my $self = shift;
  return(exists($self->{parent}) ? $self->{root} : $self);
} # root ###############################################################

sub is_root { return(! exists(shift->{parent})) }
########################################################################

sub descendants {
  my $self = shift;

  return map({$_->rmap(sub {shift})} $self->children);
} # descendants ########################################################

sub older_siblings {
  my $self = shift;

  $self->is_root and return();
  my @siblings = $self->parent->children;

  while(my $s = pop(@siblings)) {($s == $self) and last;}

  return(@siblings);
} # older_siblings #####################################################

sub younger_siblings {
  my $self = shift;

  $self->is_root and return();
  my @siblings = $self->parent->children;

  while(my $s = shift(@siblings)) {($s == $self) and last;}

  return(@siblings);
} # younger_siblings ###################################################

sub next_sibling {
  my $self = shift;

  my @younger = $self->younger_siblings or return();
  return($younger[0]);
} # next_sibling #######################################################

sub prev_sibling {
  my $self = shift;

  my @older = $self->older_siblings or return();
  return($older[-1]);
} # prev_sibling #######################################################

sub ancestors {
  my $self = shift;
  my $node = $self;
  my @ancestors;
  while(my $parent = $node->parent) {
    push(@ancestors, $parent);
    $node = $parent;
  }
  return(@ancestors);
} # ancestors ##########################################################

sub rmap {
  my $self = shift;
  my ($subref, $knob) = @_;
  $knob ||= Tree::Base::Knob->new;

  my @ans; for ($self) { @ans = $subref->($self, $knob); }

  $knob->{pruned} and return(@ans);

  foreach my $child ($self->children) {
    push(@ans, $child->rmap($subref, $knob));
    $knob->{stopped} and last;
  }
  return(@ans);
} # rmap ###############################################################

sub parent { shift->{parent} }

sub DESTROY {
  my $self = shift;
  delete($self->{children});
}

BEGIN {
package Tree::Base::Knob;
sub new {return bless({}, 'Tree::Base::Knob')};
sub prune {shift->{pruned} = 1; return()}
sub stop  {shift->{stopped} = 1; return()}
} # Tree::Base::Knob
########################################################################

# vi:ts=2:sw=2:et:sta
1;