File Coverage

blib/lib/Tree/BK.pm

Criterion	Covered	Total	%
statement	56	58	96.5
branch	16	18	88.8
condition	2	3	66.6
subroutine	10	10	100.0
pod	5	5	100.0
total	89	94	94.6

#
# This file is part of Tree-BK
#
# This software is copyright (c) 2014 by Nathan Glenn.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package Tree::BK;
$Tree::BK::VERSION = '0.01';
use strict;
use warnings;
use Text::Levenshtein::XS qw(distance);
use Carp;

# ABSTRACT: Structure for efficient fuzzy matching


sub new {
	my ($class, $metric) = @_;
	if(defined $metric){
		if((ref $metric) ne 'CODE'){
			croak 'argument to new() should be ' .
				'a code reference implementing a metric';
		}
	}else{
		$metric = \&Text::Levenshtein::XS::distance;
	}
	my $tree = bless {
		metric => $metric,
		root => undef,
		size => 0,
	}, $class;
	return $tree;
}


sub insert {
	my ($self, $object) = @_;
	if(!defined $self->{root}){
		$self->{root} = { object=>$object };
		$self->{size}++;
		return $object;
	}

	my $current = $self->{root};
	my $dist = $self->{metric}->($current->{object}, $object);
	while(exists $current->{$dist}){
		# object was already in the tree
		if($dist == 0){
			return;
		}
		$current = $current->{$dist};
		$dist = $self->{metric}->($current->{object}, $object);
	}
	# prevent adding the root node multiple times
	if($dist == 0){
		return;
	}
	$current->{$dist} = {object => $object};
	$self->{size}++;
	return $object;
}

sub insert_all {
	my ($self, @objects) = @_;
	if(@objects < 1){
		croak 'Must pass at least one object to insert_all method';
	}
	my $size_before = $self->size;
	$self->insert($_) for @objects;
	return $self->size - $size_before;
}

sub find {
	my ($self, $target, $threshold) = @_;
	my @return;
	$self->_find($self->{root}, \@return, $target, $threshold);
	return \@return;
}

sub _find {
	my ($self, $node, $current_list, $target, $threshold) = @_;
	my $distance = $self->{metric}->($node->{object}, $target);
	my $min_dist = $distance - $threshold;
	my $max_dist = $distance + $threshold;
	if($distance <= $threshold){
		push @$current_list, $node->{object};
	}
	# recursively search the children where nodes with the threshold
	# distance might reside
	for(keys %$node){
		next if $_ eq 'object';
		next unless $_ >= $min_dist && $_ <= $max_dist;
		$self->_find($node->{$_}, $current_list, $target, $threshold);
	}
}

sub size {
	my ($self) = @_;
	return $self->{size};
}

1;

__END__