view release on metacpan or  search on metacpan

NCA.pm  view on Meta::CPAN

# 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 ($) {