File Coverage

blib/lib/Algorithm/Tree/NCA.pm

Criterion	Covered	Total	%
statement	111	121	91.7
branch	18	26	69.2
condition	6	6	100.0
subroutine	23	24	95.8
pod	0	3	0.0
total	158	180	87.7

# Copyright 2002 by Mats Kindahl. All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.

package Algorithm::Tree::NCA::Data;

use 5.006;
use strict;
use warnings;

use fields qw(_run _magic _number _parent _leader _max _node);

sub new ($%) {
    my $class = shift;
    # Default values first, then the provided parameters
    my %args = (_run => 0,        # Corresponds to I(v)
                _magic => 0,      # Corresponds to A_v
                _max => 0,        # Maximum number assigned to subtree
                _number => 0,     # The DFS number assigned to this node
                _parent => undef, # The parent node data for this node
                _leader => undef, # The leader node data for this node
                _node => undef,   # The node that the data is for
                @_);

    my $self = fields::new($class);
    @$self{keys %args} = values %args;
    return $self;
}

package Algorithm::Tree::NCA;

use strict;
use warnings;

use Data::Dumper;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

our @EXPORT_OK = ();
our @EXPORT = ();
our $VERSION = '0.02';

# Preloaded methods go here.

use fields qw(_get _set _data);

sub _set_method {
    my($node,$value) = @_;

    $node->{'_nca_number'} = $value;
}

sub _get_method {
    my($node) = @_;

    return $node->{'_nca_number'};
}


sub new ($%) {
    my($class,%o) = @_;

    $o{-get} = \&_get_method unless defined $o{-get};
    $o{-set} = \&_set_method unless defined $o{-set};

    my $self = fields::new($class);

    $self->{_get} = $o{'-get'}; # Get method to use
    $self->{_set} = $o{'-set'}; # Set method to use
    $self->{_data} = [];	# Array of node data


    # Preprocess the tree if there is one supplied
    $self->preprocess($o{-tree}) if exists $o{-tree};

    return $self;
}

sub _get ($$) {
    my($self,$node) = @_;
    $self->{_get}->($node);
}

sub _set ($$$) {
    my($self,$node,$val) = @_;
    $self->{_set}->($node,$val);
}

sub _lssb ($) {
    my($v) = @_;
    return $v & -$v;
}

sub _mssb ($) {
    my($v) = @_;

    $v |= $v >> 1;
    $v |= $v >> 2;
    $v |= $v >> 4;
    $v |= $v >> 8;
    $v |= $v >> 16;

    return $v - ($v >> 1);
}

sub _data ($$) {
    my($self,$node) = @_;
    return $self->{_data}->[$self->_get($node)];
}

sub preprocess ($$) {
    my($self,$root) = @_;

    # Enumeration phase
    $self->_enumerate($root, 1);

    # Computing magic number and leaders
    $self->_compute_magic($root, $self->_data($root), 0);
}

# Enumerate each node of the tree with a number v and compute the run
# I(v) for each node. Also set the parent for each node.
sub _enumerate ($$$;$) {
    my($self,$node,$number,$parent) = @_;

    my $data = Algorithm::Tree::NCA::Data
	->new(_node => $node,
	      _run => $number,
	      _parent => $parent,
	      _number => $number);

    $self->{_data}->[$number] = $data;

    $self->_set($node,$number);

    my $run = $number++;

    for my $c ($node->children()) {
	($number, $run) = $self->_enumerate($c, $number, $data);
	if (_lssb($run) > _lssb($data->{_run})) {
	    $data->{_run} = $run;
	}
    }
    $data->{_max} = $number;
    return ($number,$data->{_run});
}

# Compute the magic number A_v and the leader L(v) for each node v.
sub _compute_magic ($$$$) {
    my($self,$node,$ldata,$magic) = @_;

    my $ndata = $self->_data($node);

    $ndata->{_magic} = $magic | _lssb($ndata->{_run});

    if ($ndata->{_run} != $ldata->{_run}) {
	$ndata->{_leader} = $ndata;
    } else {
	$ndata->{_leader} = $ldata;
    }

    foreach my $c ($node->children()) {
	$self->_compute_magic($c,
			      $ndata->{_leader},
			      $ndata->{_magic});
    }
}

sub _display_data ($) {
    my($self) = @_;

    my(@L,@I,@A);
    foreach my $d (@{$self->{_data}}) {
	push(@L, defined $d ? $d->{_leader}->{_number} : "*");
	push(@I, defined $d ? $d->{_run} : "*");
	push(@A, defined $d ? $d->{_magic} : "*");
    }

    print STDERR "L = (@L)\n";
    print STDERR "I = (@I)\n";
    print STDERR "A = (@A)\n";
}

# Compute the nearest common ancestor of nodes I(x) and I(y)
sub _bin_nca ($$$) {
    my($self,$xd,$yd)= @_;

    if ($xd->{_number} <= $yd->{_number} && $yd->{_number} < $xd->{_max}) {
	return $xd->{_run};
    }

    if ($yd->{_number} <= $xd->{_number} && $xd->{_number} < $yd->{_max}) {
	return $yd->{_run};
    }

    my $k = _mssb($xd->{_run} ^ $yd->{_run});
    my $m = $k ^ ($k - 1);	# Mask off the k-1 most significant bits
    my $r = ~$m & $xd->{_run};	# Take the k-1 most significant bits

    # Return k-1 least significant bits of I(x) with a 1 in position k
    return ($r | $k);

}

# Find the node closest to 'x' but on the same run as the NCA.
sub _closest ($$$) {
    my($self,$xd,$j) = @_;

    # a. Find the position l of the right-most 1-bit in A_x
    my $l = _lssb($xd->{_magic});

    # b. If l == j then nx is x (since x and z are on the same run)
    if ($l == $j) {
        return $xd;
    }

    # c. Find the position k of the left-most 1-bit in A_x that is to
    #    the right of position j.
    my $k = _mssb(($j - 1) & $xd->{_magic});

    #    Form the number u consisting of the bits of I(x) to the left
    #    of position k, followed by a 1-bit in position k, followed by
    #    all zeroes. (u will be I(w))
    my $u = ~(($k - 1) | $k) & $xd->{_run} | $k;

    #    Look up node L(I(w)), which must be node w. nx is then the parent
    #    of node w.
    my $wd = $self->{_data}->[$u]->{_leader};

    return $wd->{_parent};

}

sub nca ($$$) {
    my($self,$x,$y) = @_;
    my $xd = $self->_data($x);
    my $yd = $self->_data($y);

    if ($xd->{_number} == $yd->{_number}) {
	return $x;
    }

    # 1. Find the [nearest] common ancestor b in B of nodes I(x) and I(y).
    my $b = $self->_bin_nca($xd,$yd);

    # 2. Find the smallest position j greater than or equal to h(b) such
    #    that both numbers A_x and A_y have 1-bits in position j. j is
    #    then h(I(z)).
    my $m = ~$b & ($b - 1);	# Mask for the h(b)-1 least significant bits
    my $c = $xd->{_magic} & $yd->{_magic};
				# The common set bits in A_x and A_y
    my $u = $c & ~$m;		# The upper bits of the common set bits
    my $j = _lssb($u);		# Isolate the rightmost 1-bit of u

    # 3a. Find node nx, the closest node to x on the same run as z.
    my $nxd = $self->_closest($xd,$j);
    # 3b. Find node ny, the closest node to y on the same run as z.
    my $nyd = $self->_closest($yd,$j);

    # 4. If nx < ny then z is nx, else z is ny
    if ($nxd->{_number} < $nyd->{_number}) {
	return $nxd->{_node};
    } else {
	return $nyd->{_node};
    }
}

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__