Tree::Binary - An implementation of a binary tree

  my $tree = Tree::Binary->new( 'root' );

  my $left = Tree::Binary->new( 'left' );
  $tree->left( $left );

  my $right = Tree::Binary->new( 'left' );
  $tree->right( $right );

  my $right_child = $tree->right;

  $tree->right( undef ); # Unset the right child.

  my @nodes = $tree->traverse( $tree->POST_ORDER );

  my $traversal = $tree->traverse( $tree->IN_ORDER );
  while ( my $node = $traversal->() ) {
      # Do something with $node here
  }

package Tree::Binary;

use 5.006;

use strict;
use warnings FATAL => 'all';

use Scalar::Util qw( blessed );

use base qw( Tree );

our $VERSION = '1.01';

sub _init {
    my $self = shift;
    $self->SUPER::_init( @_ );

    # Make this class a complete binary tree,
    # filling in with Tree::Null as appropriate.
    $self->{_children}->[$_] = $self->_null
        for 0 .. 1;

    return $self;
}

sub left {
    my $self = shift;
    return $self->_set_get_child( 0, @_ );
}

sub right {
    my $self = shift;
    return $self->_set_get_child( 1, @_ );
}

sub _set_get_child {
    my $self = shift;
    my $index = shift;

    if ( @_ ) {
        my $node = shift;
        $node = $self->_null unless $node;

        my $old = $self->children->[$index];
        $self->children->[$index] = $node;

        if ( $node ) {
            $node->_set_parent( $self );
            $node->_set_root( $self->root );
            $node->_fix_depth;
        }

        if ( $old ) {
            $old->_set_parent( $old->_null );
            $old->_set_root( $old->_null );
            $old->_fix_depth;
        }

        $self->_fix_height;
        $self->_fix_width;

        return $self;
    }
    else {
        return $self->children->[$index];
    }
}

sub _clone_children {
    my ($self, $clone) = @_;

    @{ $clone->{_children} } = ();
    $clone->add_child({}, map { $_->clone } @{ $self->{_children} });
}

sub children {
    my $self = shift;
    if ( @_ ) {
        my @idx = @_;
        return @{$self->{_children}}[@idx];
    }
    else {
        if ( caller->isa( __PACKAGE__ ) || $self->isa( scalar(caller) ) ) {
            return wantarray ? @{$self->{_children}} : $self->{_children};
        }
        else {
            return grep { $_ } @{$self->{_children}};
        }
    }
}

use constant IN_ORDER => 4;

# One of the things we have to do in a traversal is to remove all of the
# Tree::Null elements that are appended to the tree to make this a complete
# binary tree. The user isn't going to expect them, because they're an
# internal nicety.

sub traverse {
    my $self = shift;
    my $order = shift;
    $order = $self->PRE_ORDER unless $order;

    if ( wantarray ) {
        if ( $order == $self->IN_ORDER ) {
            return grep { $_ } (
                $self->left->traverse( $order ),
                $self,
                $self->right->traverse( $order ),
            );
        }
        else {
            return grep { $_ } $self->SUPER::traverse( $order );
        }
    }
    else {
        my $closure;

        if ( $order eq $self->IN_ORDER ) {
            my @list = $self->traverse( $order );

            $closure = sub {
                return unless @list;
                return shift @list;
            };
        }
        elsif ( $order eq $self->PRE_ORDER ) {
            my $next_node = $self;
            my @stack = ( $self );
            my @next_meth = ( 0 );

            my @meths = qw( left right );
            $closure = sub {
                my $node = $next_node;
                return unless $node;
                $next_node = undef;

                while ( @stack && !$next_node ) {
                    while ( @next_meth && $next_meth[0] == 2 ) {
                        shift @stack;
                        shift @next_meth;
                    }

                    if ( @stack ) {
                        my $meth = $meths[ $next_meth[0]++ ];
                        $next_node = $stack[0]->$meth;
                        next unless $next_node;
                        unshift @stack, $next_node;
                        unshift @next_meth, 0;
                    }
                }

                return $node;
            };
        }
        elsif ( $order eq $self->POST_ORDER ) {
            my @list = $self->traverse( $order );

            $closure = sub {
                return unless @list;
                return shift @list;
            };
            #my @stack = ( $self );
            #my @next_idx = ( 0 );
            #while ( @{ $stack[0]->{_children} } ) {
            #    unshift @stack, $stack[0]->{_children}[0];
            #    unshift @next_idx, 0;
            #}
            #
            #$closure = sub {
            #    my $node = $stack[0] || return;
            #
            #    shift @stack; shift @next_idx;
            #    $next_idx[0]++;
            #
            #    while ( @stack && exists $stack[0]->{_children}[ $next_idx[0] ] ) {
            #        unshift @stack, $stack[0]->{_children}[ $next_idx[0] ];
            #        unshift @next_idx, 0;
            #    }
            #
            #    return $node;
            #};
        }
        elsif ( $order eq $self->LEVEL_ORDER ) {
            my @nodes = ($self);
            $closure = sub {
                my $node = shift @nodes;
                return unless $node;
                push @nodes, grep { $_ } @{$node->{_children}};
                return $node;
            };
        }
        else {
            return $self->error( "traverse(): '$order' is an illegal traversal order" );
        }

        return $closure;
    }
}

1;
__END__