t/lib/BinaryTree.pm

   1
   2 package BinaryTree;
   3
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '0.01';
   8
   9 use Class::MOP ':universal';
  10
  11 __PACKAGE__->meta->add_attribute(
  12     Class::MOP::Attribute->new('_uid' => (
  13         reader => 'getUID',
  14         writer => 'setUID',
  15         default => sub {
  16             my $instance = shift;
  17             ("$instance" =~ /\((.*?)\)$/);
  18         }
  19     ))
  20 );
  21
  22 __PACKAGE__->meta->add_attribute(
  23     Class::MOP::Attribute->new('_node' => (
  24         reader   => 'getNodeValue',
  25         writer   => 'setNodeValue',
  26         init_arg => ':node'
  27     ))
  28 );
  29
  30 __PACKAGE__->meta->add_attribute(
  31     Class::MOP::Attribute->new('_parent' => (
  32         reader    => 'getParent',
  33         writer    => 'setParent',
  34         predicate => {
  35             'isRoot' => sub {
  36                 my ($self) = @_;
  37                 return not defined $self->{_parent};
  38             }
  39         }
  40     ))
  41 );
  42
  43 __PACKAGE__->meta->add_attribute(
  44     Class::MOP::Attribute->new('_left' => (
  45         predicate => 'hasLeft',
  46         reader    => 'getLeft',
  47         writer => {
  48             'setLeft' => sub {
  49                 my ($self, $tree) = @_;
  50                 $tree->setParent($self);
  51                 $self->{_left} = $tree;
  52                 $tree->setDepth($self->getDepth() + 1);
  53                 $self;
  54             }
  55        },
  56     ))
  57 );
  58
  59 __PACKAGE__->meta->add_attribute(
  60     Class::MOP::Attribute->new('_right' => (
  61         predicate => 'hasRight',
  62         reader    => 'getRight',
  63         writer => {
  64             'setRight' => sub {
  65                 my ($self, $tree) = @_;
  66                 $tree->setParent($self);
  67                 $self->{_right} = $tree;
  68                 $tree->setDepth($self->getDepth() + 1);
  69                 $self;
  70             }
  71         }
  72     ))
  73 );
  74
  75 __PACKAGE__->meta->add_attribute(
  76     Class::MOP::Attribute->new('_depth' => (
  77         default => 0,
  78         reader  => 'getDepth',
  79         writer  => {
  80             'setDepth' => sub {
  81                 my ($self, $depth) = @_;
  82                 unless ($self->isLeaf()) {
  83                     $self->fixDepth();
  84                 }
  85                 else {
  86                     $self->{_depth} = $depth;
  87                 }
  88             }
  89         }
  90     ))
  91 );
  92
  93 sub new {
  94     my $class = shift;
  95     bless $class->meta->construct_instance(':node' => shift) => $class;
  96 }
  97
  98 sub removeLeft {
  99     my ($self) = @_;
 100     my $left = $self->{_left};
 101     $left->setParent(undef);
 102     $left->setDepth(0);
 103     $self->{_left} = undef;
 104     return $left;
 105 }
 106
 107 sub removeRight {
 108     my ($self) = @_;
 109     my $right = $self->{_right};
 110     $right->setParent(undef);
 111     $right->setDepth(0);
 112     $self->{_right} = undef;
 113     return $right;
 114 }
 115
 116 sub isLeaf {
 117         my ($self) = @_;
 118         return (!$self->hasLeft && !$self->hasRight);
 119 }
 120
 121 sub fixDepth {
 122         my ($self) = @_;
 123         # make sure the tree's depth
 124         # is up to date all the way down
 125         $self->traverse(sub {
 126                         my ($tree) = @_;
 127             unless ($tree->isRoot()) {
 128                 $tree->{_depth} = $tree->getParent()->getDepth() + 1;
 129             }
 130             else {
 131                 $tree->{_depth} = 0;
 132             }
 133                 }
 134         );
 135 }
 136
 137 sub traverse {
 138         my ($self, $func) = @_;
 139     $func->($self);
 140     $self->{_left}->traverse($func) if defined $self->{_left};
 141     $self->{_right}->traverse($func) if defined $self->{_right};
 142 }
 143
 144 sub mirror {
 145     my ($self) = @_;
 146     # swap left for right
 147     my $temp = $self->{_left};
 148     $self->{_left} = $self->{_right};
 149     $self->{_right} = $temp;
 150     # and recurse
 151     $self->{_left}->mirror() if $self->hasLeft();
 152     $self->{_right}->mirror() if $self->hasRight();
 153     $self;
 154 }
 155
 156 sub size {
 157     my ($self) = @_;
 158     my $size = 1;
 159     $size += $self->{_left}->size() if $self->hasLeft();
 160     $size += $self->{_right}->size() if $self->hasRight();
 161     return $size;
 162 }
 163
 164 sub height {
 165     my ($self) = @_;
 166     my ($left_height, $right_height) = (0, 0);
 167     $left_height = $self->{_left}->height() if $self->hasLeft();
 168     $right_height = $self->{_right}->height() if $self->hasRight();
 169     return 1 + (($left_height > $right_height) ? $left_height : $right_height);
 170 }
 171