package CLR::Tree::Binary;

# This is a basic module implementing a binary search tree.
# For a description of binary search trees, see:
#   Thomas H. Corman, Charles E. Leiserson and Ronald L. Rivest:
#   "Introduction to Algorithms". MIT Press/McGraw-Hill, 1990.
#   Chapter 13.

# Trees are unbalanced; this package is assumed to be a basic 
# package; balanced trees can inherit this and mask the appropriate
# functions (insert/delete will often be enough).

# Public methods:
#   new ():                  create an empty tree.
#   insert (key):            insert key.
#   delete (key):            delete a key.
#   is_empty ():             true if tree is empty.
#   query (key):             true if key exists.
#   range_query (from, to):  return all keys in range.
#   keys ():                 return all keys.
#   maximum ():              return maximum of the tree.
#   minimum ():              return minimum of the tree.
#   successor (key):         return smallest key larger than the query key.
#   predecessor (key):       return largest key smaller than the query key.

# Keys are assumed to be numeric. To deal with keys of different types,
# the function CMP can be masked. CMP takes three arguments, the object
# itself, and two arguments. It should return -1, 0, 1 in the same way
# <=> and cmp do.

use strict;
use Carp;

# Redefinable functions. 
# First returns the info fields of the node, second the structure fields.
sub FIELDS () {qw /key/;}
sub CHILDS () {qw /left right/;}

# Create a node.
# Probably not a good idea to mask.
sub new ($;$) {
    my $proto = shift;
    my $class = ref ($proto) || $proto;
    my $copy  = shift;

    my $self  = bless {}, $class;

    if ($copy && ref $proto) {
        map {$self -> {$_} = $proto -> {$_};} keys %$proto;
    }
    else {
        map {$self -> {$_} = undef;} $self -> FIELDS (), $self -> CHILDS ();
    }

    $self -> initialize ($copy) unless $copy;

    $self;
}

# Further setup of the node. Maskable.
sub initialize ($) {}

# Tree modifying functions.

# $status = $tree -> insert (key);
sub insert ($$) {
    my $self  = shift;
    my $key   = shift;

    if ($self -> is_empty ()) {
        $self -> {key}   = $key;
        $self -> {left}  = $self -> new ();
        $self -> {right} = $self -> new ();
        return 1;
    }

    return 0 if $self -> eq ($key);
    $self -> {$self -> lt ($key) ? "left" : "right"} -> insert ($key);
}

# $status = $tree -> delete (key);
sub delete ($$) {
    my $self = shift;
    my $key  = shift;

    return 0 if $self -> is_empty ();   # Key isn't there.

    # If unequal, go into recursion.
    return $self -> {left}  -> delete ($key) if $self -> lt ($key);
    return $self -> {right} -> delete ($key) if $self -> gt ($key);

    # So now we have to delete this node.
    # Easy cases, we only have one kid.
    if ($self -> {left}  -> is_empty ()) {
        $self -> _copy ($self -> {right});
        return 1;
    }
    if ($self -> {right}  -> is_empty ()) {
        $self -> _copy ($self -> {left});
        return 1;
    }

    # Else, both subtrees are filled. Find the minimum of the right subtree.
    my $min = $self -> {right} -> _tree_minimum ();

    # Copy the content, but not the structure.
    $self -> _copy_fields ($min);

    # Delete the minimum from right subtree.
    # We could have called $min -> delete (), but this allows
    # for a cleaner "cleanup from recursion" when masked.
    $self -> {right} -> delete ($min -> {key});

    1;
}

# Query functions.

# Return true if the tree is empty.
# $empty = $tree -> is_empty ();
sub is_empty ($) {!defined shift -> {key};}

# Return whether a key exists.
# $exists = $tree -> query (key);
sub query ($$) {
    my $self = shift;
    my $key  = shift;

    return 0 if $self -> is_empty ();
    return 1 if $self -> eq ($key);

    $self -> {$self -> lt ($key) ? "left" : "right"} -> query ($key);
}

# Return keys in a range.
# @keys = $tree -> range_query (from, to);
# from == undef  ->  -infinity.
# to   == undef  ->  +infinity.
sub range_query ($$$) {
    my $self = shift;
    my $from = shift;
    my $to   = shift;

    return () if $self -> is_empty ();
    my @out  = ();
    if (!defined $from || $self -> lt ($from)) {
        push @out, $self -> {left} -> range_query ($from, $to);
    }
    if ((!defined $from || $self -> le ($from)) &&
        (!defined $to   || $self -> ge ($to))) {
        push @out, $self -> {key};
    }
    if (!defined $to   || $self -> gt ($to)) {
        push @out, $self -> {right} -> range_query ($from, $to);
    }

    @out;
}

# Return all the keys of a tree. 
# This is a redundant function, $tree -> range_query (undef, undef)
# does the same.
# @keys = $trees -> keys ();
sub keys ($) {
    my $self   = shift;

    return () if $self -> is_empty ();

   ($self -> {left}  -> keys (), $self -> {key}, $self -> {right} -> keys ());
}

# Maximum and minimum of a tree.
# $max = $tree -> maximum ();
# $min = $tree -> minimum ();
sub maximum ($) {shift -> _tree_maximum () -> {key};}
sub minimum ($) {shift -> _tree_minimum () -> {key};}

# Successor and predecessor of keys (don't need to be present).
# $succ = $tree -> successor (key);
# $pred = $tree -> predecessor (key);
sub successor   ($$) {shift -> _tree_successor   (shift) -> {key};}
sub predecessor ($$) {shift -> _tree_predecessor (shift) -> {key};}

# Compare values with keys. 
# If you want some other order, mask this function:
sub CMP ($$$) {shift; (shift) <=> (shift);}

# Internal functions:
# PRECONDITION for all these functions: !$self -> is_empty ();
sub lt   ($$) {my $self = shift; $self -> CMP (shift, $self -> {key}) <  0;}
sub le   ($$) {my $self = shift; $self -> CMP (shift, $self -> {key}) <= 0;}
sub eq   ($$) {my $self = shift; $self -> CMP (shift, $self -> {key}) == 0;}
sub ge   ($$) {my $self = shift; $self -> CMP (shift, $self -> {key}) >= 0;}
sub gt   ($$) {my $self = shift; $self -> CMP (shift, $self -> {key}) >  0;}
sub cmp  ($$) {my $self = shift; $self -> CMP (shift, $self -> {key});}

# Internal functions. Functions starting with _tree return trees.
# Return the maximum of a tree.
sub _tree_maximum ($) {
    my $self = shift;
    return $self if $self -> is_empty ();   # Empty trees don't have maxima.
    $self -> {right} -> is_empty () ? $self
                                    : $self -> {right} -> _tree_maximum ();
}

# Return the minimum of a tree.
sub _tree_minimum ($) {
    my $self = shift;
    return $self if $self -> is_empty ();   # Empty trees don't have minima.
    $self -> {left} -> is_empty ()  ? $self
                                    : $self -> {left} -> _tree_minimum ();
}

# Return the successor of a key.
sub _tree_successor ($$) {
    my $self = shift;
    my $key  = shift;

    # Return a leaf if tree is empty.
    return $self if $self -> is_empty ();

    # If $key is larger or equal, go into recursion on the right subtree.
    return $self -> {right} -> _tree_successor ($key) if $self -> ge ($key);

    my $succ;
    # If $key is smaller, find the successor in the left subtree (may fail).
    $succ = $self -> {left} -> _tree_successor ($key) if $self -> lt ($key);

    # If left tree didn't find an answer, return self.
    $succ -> is_empty () ? $self : $succ;
}

# Return the predecessor of a key.
sub _tree_predecessor ($$) {
    my $self = shift;
    my $key  = shift;

    # Return a leaf if tree is empty.
    return $self if $self -> is_empty ();

    # If $key is smaller or equal, go into recursion on the left subtree.
    return $self -> {left} -> _tree_predecessor ($key) if $self -> le ($key);

    my $pred;
    # If $key is larger, find the predecessor in the right subtree (may fail).
    $pred = $self -> {right} -> _tree_predecessor ($key) if $self -> gt ($key);

    # If right tree didn't find an answer, return self.
    $pred -> is_empty () ? $self : $pred;
}

# Copy the content of a node to me.
sub _copy_fields ($$) {
    my $self  = shift;
    my $other = shift;

    map {$self -> {$_} = $other -> {$_};} $self -> FIELDS ();
}

# Copy the content of a node to me.
sub _copy_kids ($$) {
    my $self  = shift;
    my $other = shift;

    map {$self -> {$_} = $other -> {$_};} $self -> CHILDS ();
}

# Copy the content of a node to me.
sub _copy ($$) {
    my $self  = shift;
    my $other = shift;
    $self -> _copy_fields ($other);
    $self -> _copy_kids   ($other);
}

1;