File Coverage

blib/lib/Tree/VP.pm

Criterion	Covered	Total	%
statement	6	8	75.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	9	11	81.8

package Tree::VP;
use v5.8;
our $VERSION = "0.05";

use Moo;
use List::Priority;
use Tree::DAG_Node;

has distance => (
    is => "ro",
    required => 1,
);

has tree => (
    is => "rw",
);

sub build {
    my ($self, $values) = @_;
    $self->tree( $self->_build_tree_maybe($values) ) if @$values;
    return $self;
}

sub _build_tree_maybe {
    my ($self, $values) = @_;
    my $node;
    if (@$values) {
        my $vp = shift @$values;
        my @v = ($vp);

        $node = Tree::DAG_Node->new({
            name => "$vp",
            attributes => { vp => $vp }
        });

        return $node unless @$values;

        my @dist = sort { $a->[1] <=> $b->[1] } map {[$_, $self->distance->($_, $vp)]} @$values;

        my $center = int( $#dist/2 );
        my (@left, @right, $min, $max);

        my $median = (@dist == 1)
        ? $dist[0][1] : (@dist % 2 == 1)
        ? $dist[$center][1] : ($dist[$center][1] + $dist[$center+1][1])/2;

        for (@dist) {
            if ($_->[1] == 0) {
                push @v, $_->[0];
            } elsif ($_->[1] < $median) {
                $min = $_->[1] if !defined($min);
                push @left, $_->[0];
            } else {
                push @right, $_->[0];
                $max = $_->[1];
            }
        }

        $node->attributes->{mu} = $median;
        $node->attributes->{distance_min} = $min;
        $node->attributes->{distance_max} = $max || $min || 0;

        if (@left) {
            if (my $node_left = $self->_build_tree_maybe(\@left)) {
                $node_left->attributes->{is_left_daughter} = 1;
                $node->add_daughter( $node_left );
            }
        }
        if (@right) {
            if (my $node_right = $self->_build_tree_maybe(\@right)) {
                $node_right->attributes->{is_right_daughter} = 1;
                $node->add_daughter( $node_right );
            }
        }
    }
    return $node;
}

sub search {
    my ($self, %args) = @_;
    $args{size} ||= 2;
    return $self->_search_tree( $self->tree, %args );
}

sub _search_tree {
    my ($self, $tree, %args)= @_;
    my $result = { values => [] };

    my ($left, $right) = $tree->daughters;
    if (!$right && $left && $left->{attributes}{is_right_daughter}) {
        $right = $left;
        $left = undef;
    }

    my $is_top_level = !defined($args{__pq});
    my $pq = $args{__pq} ||= List::Priority->new;

    my $v = $tree->attributes->{vp};
    my $d = $self->distance->($v, $args{query});

    $args{tau} = $tree->attributes->{distance_max} unless defined $args{tau};
    if ($d < $args{tau}) {
        $pq->insert($d, $v);
        if ($pq->size() > $args{size}) {
            $pq->pop();
            $args{tau} = $pq->highest_priority;
        }
    }

    if (defined($tree->attributes->{mu})) {
        my $mu = $tree->attributes->{mu};
        if ($d < $args{tau}) {
            if ($left && $tree->attributes->{distance_min} - $args{tau} < $d) {
                $self->_search_tree($left, %args);
                $args{tau} = $pq->highest_priority;
            }
            if ($right && $mu - $args{tau} < $d && $d < $tree->attributes->{distance_max} + $args{tau}) {
                $self->_search_tree($right, %args);
            }
        } else {
            if ($right && $d < $tree->attributes->{distance_max} + $args{tau}) {
                $self->_search_tree($right, %args);
                $args{tau} = $pq->highest_priority;
            }
            if ($left && $tree->attributes->{distance_min} - $args{tau} < $d && $d < $mu + $args{tau}) {
                $self->_search_tree($left, %args);
            }
        }
    }

    if ($is_top_level) {
        my @results;
        while ($pq->size() > 0) {
            my $d = $pq->lowest_priority;
            my $x = $pq->shift();
            push @results, {
                distance => $d,
                value    => $x,
            }
        }
        $result->{results} = \@results;
    }
    return $result;
}


1;

__END__