t/lib/BinaryTree.pm

   1
   2 package BinaryTree;
   3
   4 use strict;
   5 use warnings;
   6 use Carp qw/confess/;
   7
   8 use metaclass;
   9
  10 our $VERSION = '0.02';
  11
  12 BinaryTree->meta->add_attribute('$:uid' => (
  13     reader  => 'getUID',
  14     writer  => 'setUID',
  15     default => sub {
  16         my $instance = shift;
  17         ("$instance" =~ /\((.*?)\)$/)[0];
  18     }
  19 ));
  20
  21 BinaryTree->meta->add_attribute('$:node' => (
  22     reader   => 'getNodeValue',
  23     writer   => 'setNodeValue',
  24     clearer  => 'clearNodeValue',
  25     init_arg => ':node'
  26 ));
  27
  28 BinaryTree->meta->add_attribute('$:parent' => (
  29     predicate => 'hasParent',
  30     reader    => 'getParent',
  31     writer    => 'setParent',
  32     clearer   => 'clearParent',
  33 ));
  34
  35 BinaryTree->meta->add_attribute('$:left' => (
  36     predicate => 'hasLeft',
  37     clearer   => 'clearLeft',
  38     reader    => 'getLeft',
  39     writer => {
  40         'setLeft' => sub {
  41             my ($self, $tree) = @_;
  42             confess "undef left" unless defined $tree;
  43                 $tree->setParent($self) if defined $tree;
  44             $self->{'$:left'} = $tree;
  45             $self;
  46         }
  47    },
  48 ));
  49
  50 BinaryTree->meta->add_attribute('$:right' => (
  51     predicate => 'hasRight',
  52     clearer   => 'clearRight',
  53     reader    => 'getRight',
  54     writer => {
  55         'setRight' => sub {
  56             my ($self, $tree) = @_;
  57             confess "undef right" unless defined $tree;
  58                 $tree->setParent($self) if defined $tree;
  59             $self->{'$:right'} = $tree;
  60             $self;
  61         }
  62     }
  63 ));
  64
  65 sub new {
  66     my $class = shift;
  67     $class->meta->new_object(':node' => shift);
  68 }
  69
  70 sub removeLeft {
  71     my ($self) = @_;
  72     my $left = $self->getLeft();
  73     $left->clearParent;
  74     $self->clearLeft;
  75     return $left;
  76 }
  77
  78 sub removeRight {
  79     my ($self) = @_;
  80     my $right = $self->getRight;
  81     $right->clearParent;
  82     $self->clearRight;
  83     return $right;
  84 }
  85
  86 sub isLeaf {
  87         my ($self) = @_;
  88         return (!$self->hasLeft && !$self->hasRight);
  89 }
  90
  91 sub isRoot {
  92         my ($self) = @_;
  93         return !$self->hasParent;
  94 }
  95
  96 sub traverse {
  97         my ($self, $func) = @_;
  98     $func->($self);
  99     $self->getLeft->traverse($func)  if $self->hasLeft;
 100     $self->getRight->traverse($func) if $self->hasRight;
 101 }
 102
 103 sub mirror {
 104     my ($self) = @_;
 105     # swap left for right
 106     if( $self->hasLeft && $self->hasRight) {
 107       my $left = $self->getLeft;
 108       my $right = $self->getRight;
 109       $self->setLeft($right);
 110       $self->setRight($left);
 111     } elsif( $self->hasLeft && !$self->hasRight){
 112       my $left = $self->getLeft;
 113       $self->clearLeft;
 114       $self->setRight($left);
 115     } elsif( !$self->hasLeft && $self->hasRight){
 116       my $right = $self->getRight;
 117       $self->clearRight;
 118       $self->setLeft($right);
 119     }
 120
 121     # and recurse
 122     $self->getLeft->mirror  if $self->hasLeft;
 123     $self->getRight->mirror if $self->hasRight;
 124     $self;
 125 }
 126
 127 sub size {
 128     my ($self) = @_;
 129     my $size = 1;
 130     $size += $self->getLeft->size  if $self->hasLeft;
 131     $size += $self->getRight->size if $self->hasRight;
 132     return $size;
 133 }
 134
 135 sub height {
 136     my ($self) = @_;
 137     my ($left_height, $right_height) = (0, 0);
 138     $left_height = $self->getLeft->height()   if $self->hasLeft();
 139     $right_height = $self->getRight->height() if $self->hasRight();
 140     return 1 + (($left_height > $right_height) ? $left_height : $right_height);
 141 }
 142
 143 1;