Math-Vector-Real-kdTree-0.09/0000755000175000017500000000000012157567104014676 5ustar salvasalvaMath-Vector-Real-kdTree-0.09/lib/0000755000175000017500000000000012157567104015444 5ustar salvasalvaMath-Vector-Real-kdTree-0.09/lib/Math/0000755000175000017500000000000012157567104016335 5ustar salvasalvaMath-Vector-Real-kdTree-0.09/lib/Math/Vector/0000755000175000017500000000000012157567104017577 5ustar salvasalvaMath-Vector-Real-kdTree-0.09/lib/Math/Vector/Real/0000755000175000017500000000000012157567104020462 5ustar salvasalvaMath-Vector-Real-kdTree-0.09/lib/Math/Vector/Real/kdTree.pm0000644000175000017500000003241312157566677022257 0ustar salvasalvapackage Math::Vector::Real::kdTree; our $VERSION = '0.09'; use 5.010; use strict; use warnings; use Carp; use Math::Vector::Real; use Sort::Key::Top qw(nkeypartref ntop); our $max_per_pole = 12; our $recommended_per_pole = 6; sub new { my $class = shift; my @v = map Math::Vector::Real::clone($_), @_; my @ix = (0..$#v); my $tree = _build(\@v, \@ix); my $self = { vs => \@v, tree => $tree }; bless $self, $class; } sub clone { my $self = shift; require Storable; my $clone = { vs => [@{$self->{vs}}], tree => Storable::dclone($self->{tree}) }; $clone->{hidden} = { %{$self->{hidden}} } if $self->{hidden}; bless $clone, ref $self; } sub _build { my ($v, $ix) = @_; if (@$ix > $recommended_per_pole) { my ($b, $t) = Math::Vector::Real->box(@$v[@$ix]); my $axis = ($t - $b)->max_component_index; my $bstart = @$ix >> 1; my ($l, $r) = nkeypartref { $v->[$_][$axis] } $bstart => @$ix; my $lc = ntop -1 => map $v->[$_][$axis], @$l; my $rc = ntop 1 => map $v->[$_][$axis], @$r; my $median = 0.5 * ($lc + $rc); [$axis, _build($v, $l), _build($v, $r), $median, $b->[$axis], $t->[$axis], scalar(@$l), scalar(@$r)]; } else { [undef, @$ix]; } } sub size { scalar @{shift->{vs}} } sub at { my ($self, $ix) = @_; Math::Vector::Real::clone($self->{vs}[$ix]); } sub insert { my $self = shift; return undef unless @_; my $vs = $self->{vs}; my $ix = @$vs; for (@_) { my $v = Math::Vector::Real::clone($_); push @$vs, $v; _insert($vs, $self->{tree}, $#$vs) } $ix; } # _insert does not return anything but modifies its $t argument in # place. This is really ugly, done to improve performance. sub _insert { my ($vs, $t, $ix) = @_; if (defined $t->[0]) { my ($axis, undef, undef, $median, $min, $max, $nl, $nr) = @$t; my $c = $vs->[$ix][$axis]; my $pole; if ($c < $median) { if (2 * $nr + $max_per_pole >= $nl) { $t->[6]++; $t->[4] = $c if $c < $min; _insert($vs, $t->[1], $ix); return; } } else { if (2 * $nl + $max_per_pole >= $nr) { $t->[7]++; $t->[5] = $c if $c > $max; _insert($vs, $t->[2], $ix); return; } } my @store; $#store = $nl + $nr; # preallocate space @store = ($ix); _push_all($t, \@store); $_[1] = _build($vs, \@store); } elsif ($#$t< $max_per_pole) { push @$t, $ix; } else { $t->[0] = $ix; $_[1] = _build($vs, $t); } } sub move { my ($self, $ix, $v) = @_; my $vs = $self->{vs}; ($ix >= 0 and $ix < @$vs) or croak "index out of range"; _delete($vs, $self->{tree}, $ix); $vs->[$ix] = Math::Vector::Real::clone($v); _insert($vs, $self->{tree}, $ix); } sub _delete { my ($vs, $t, $ix) = @_; if (defined $t->[0]) { my ($axis, $l, $r, $median) = @$t; #print "axis: $axis, ix: $ix\n"; my $c = $vs->[$ix][$axis]; if ($c <= $median and _delete($vs, $l, $ix)) { #--($t->[6]); @$t = @$r unless --($t->[6]); return 1; } elsif ($c >= $median and _delete($vs, $r, $ix)) { #--($t->[7]); @$t = @$l unless --($t->[7]); return 1; } return 0; } else { my $l = scalar @$t; @$t = grep { not (defined($_) and ($_ == $ix)) } @$t; return @$t < $l; } } sub hide { my ($self, $ix) = @_; my $vs = $self->{vs}; ($ix >= 0 and $ix < @$vs) or croak "index out of range"; _delete($vs, $self->{tree}, $ix); ($self->{hidden} //= {})->{$ix} = 1; } sub _push_all { my ($t, $store) = @_; if (defined $t->[0]) { _push_all($t->[1], $store); _push_all($t->[2], $store); } else { push @$store, @$t[1..$#$t] } } sub path { my ($self, $vix) = @_; use Data::Dumper; # print Dumper $self->{tree}; my $p = _path($self->{tree}, $vix); # print "path length: ", scalar(@$p), "\n"; my $l = 1; $l = (($l << 1) | $_) for @$p; $l } sub _path { my ($t, $vix) = @_; if (defined $t->[0]) { for (0, 1) { my $p = _path($t->[1+$_], $vix); return [$_, @$p] if $p; } return undef; } #print "is $vix in @$t[1..$#$t]?\n"; ((grep $_ == $vix, @$t[1..$#$t]) ? [] : ()); } sub find { my ($self, $v) = @_; _find($self->{vs}, $self->{tree}, $v) } sub _find { my ($vs, $t, $v) = @_; while (1) { if (defined $t->[0]) { my ($axis, $l, $r, $median, $min, $max) = @$t; my $c = $v->[$axis]; return if ($min > $c or $c > $max); if ($c < $median) { $t = $l; } else { if ($c == $median) { my $ix = _find($vs, $l, $v); return $ix if defined $ix; } $t = $r; } } else { for (@$t[1..$#$t]) { return $_ if $v == $vs->[$_]; } return undef; } } } sub find_nearest_neighbor { my ($self, $v, $d, @but) = @_; my $vs = $self->{vs}; my $but; if (@but) { if (@but == 1 and ref $but[0] eq 'HASH') { $but = $but[0]; } else { my %but = map { $_ => 1 } @but; $but = \%but; } } my ($start, $d2); if (defined $d) { $d2 = $d * $d; } else { my $hidden = $self->{hidden}; for ($start = 0; $start < @$vs or return; $start++) { last unless ( ( $hidden and $hidden->{$start} ) or ( $but and $but->{$start} ) ); } $d2 = $vs->[$start]->dist2($v); } my ($rix, $rd2) = _find_nearest_neighbor($vs, $self->{tree}, $v, $start, $d2, $but); $rix // return; wantarray ? ($rix, sqrt($rd2)) : $rix; } sub find_nearest_neighbor_internal { my ($self, $vix, $d) = @_; $vix >= 0 or croak "index out of range"; $self->find_nearest_neighbor($self->{vs}[$vix], $d, $vix); } sub _find_nearest_neighbor { my ($vs, $t, $v, $ix, $d2, $but) = @_; while (1) { if (defined $t->[0]) { my ($axis, $l, $r, $median) = @$t; my $c = $v->[$axis]; my $cm = $c - $median; (my ($first), $t) = (($cm <= 0) ? ($l, $r) : ($r, $l)); ($ix, $d2) = _find_nearest_neighbor($vs, $first, $v, $ix, $d2, $but); return ($ix, $d2) if $d2 <= $cm * $cm; } else { for (@$t[1..$#$t]) { next if $but and $but->{$_}; my $p = $vs->[$_]; my $d21 = $p->dist2($v); if ($d21 < $d2) { $d2 = $d21; $ix = $_; } } return ($ix, $d2) } } } sub find_nearest_neighbor_all_internal { my $self = shift; my $vs = $self->{vs}; return unless @$vs > 1; my @best = ((0) x @$vs ); my $first = $vs->[0]; my @d2 = map $first->dist2($_), @$vs; $best[0] = 1; $d2[0] = $d2[1]; _find_nearest_neighbor_all_internal($vs, $self->{tree}, \@best, \@d2); if ($self->{hidden}) { $best[$_] = undef for keys %{$self->{hidden}}; } return @best; } sub _find_nearest_neighbor_all_internal { my ($vs, $t, $best, $d2) = @_; if (defined $t->[0]) { my ($axis, $l, $r, $median) = @$t; my @r; for my $side (0, 1) { my @poles = _find_nearest_neighbor_all_internal($vs, $t->[1 + $side], $best, $d2); push @r, @poles; my $other = $t->[2-$side]; for my $pole (@poles) { for my $ix (@$pole[1..$#$pole]) { my $v = $vs->[$ix]; my $md = $v->[$axis] - $median; if ($d2->[$ix] > $md * $md) { ($best->[$ix], $d2->[$ix]) = _find_nearest_neighbor($vs, $other, $v, $best->[$ix], $d2->[$ix]); } } } } return @r; } else { for my $i (2..$#$t) { my $ix = $t->[$i]; my $iv = $vs->[$ix]; for my $jx (@$t[1..$i-1]) { my $d21 = $iv->dist2($vs->[$jx]); if ($d21 < $d2->[$ix]) { $d2->[$ix] = $d21; $best->[$ix] = $jx; } if ($d21 < $d2->[$jx]) { $d2->[$jx] = $d21; $best->[$jx] = $ix; } } } return $t; } } sub find_in_ball { my ($self, $z, $d, $but) = @_; _find_in_ball($self->{vs}, $self->{tree}, $z, $d * $d, $but); } sub _find_in_ball { my ($vs, $t, $z, $d2, $but) = @_; if (defined $t->[0]) { my ($axis, $l, $r, $median) = @$t; my $c = $z->[$axis]; my $dc = $c - $median; my ($f, $s) = (($dc < 0) ? ($l, $r) : ($r, $l)); if ($dc * $dc <= $d2) { if (wantarray) { return (_find_in_ball($vs, $f, $z, $d2, $but), _find_in_ball($vs, $s, $z, $d2, $but)) } else { return (_find_in_ball($vs, $f, $z, $d2, $but) + _find_in_ball($vs, $s, $z, $d2, $but)); } } else { return _find_in_ball($vs, $f, $z, $d2, $but); } } elsif ($but) { return grep { !$but->{$_} and $vs->[$_]->dist2($z) <= $d2 } @$t[1..$#$t] } else { return grep { $vs->[$_]->dist2($z) <= $d2 } @$t[1..$#$t] } } sub ordered_by_proximity { my $self = shift; my @r; $#r = $#{$self->{vs}}; $#r = -1; # preallocate _ordered_by_proximity($self->{tree}, \@r); return @r; } sub _ordered_by_proximity { my $t = shift; my $r = shift; if (defined $t->[0]) { _ordered_by_proximity($t->[1], $r); _ordered_by_proximity($t->[2], $r); } else { push @$r, @{$t}[1..$#$t]; } } 1; __END__ =head1 NAME Math::Vector::Real::kdTree - kd-Tree implementation on top of Math::Vector::Real =head1 SYNOPSIS use Math::Vector::Real::kdTree; use Math::Vector::Real; use Math::Vector::Real::Random; my @v = map Math::Vector::Real->random_normal(4), 1..1000; my $tree = Math::Vector::Real::kdTree->new(@v); my $ix = $tree->find_nearest_neighbor(V(0, 0, 0, 0)); say "nearest neighbor is $ix, $v[$ix]"; =head1 DESCRIPTION This module implements a kd-Tree data structure in Perl and some related algorithms. The following methods are provided: =over 4 =item $t = Math::Vector::Real::kdTree->new(@points) Creates a new kd-Tree containing the given points. =item $t2 = $t->clone Creates a duplicate of the tree. The two trees will share internal read only data so this method is more efficient in terms of memory usage than others performing a deep copy. =item my $ix = $t->insert($p0, $p1, ...) Inserts the given points into the kd-Tree. Returns the index assigned to the first point inserted. =item $s = $t->size Returns the number of points inside the tree. =item $p = $t->at($ix) Returns the point at the given index inside the tree. =item $t->move($ix, $p) Moves the point at index C<$ix> to the new given position readjusting the tree structure accordingly. =item ($ix, $d) = $t->find_nearest_neighbor($p, $max_d, @but_ix) =item ($ix, $d) = $t->find_nearest_neighbor($p, $max_d, \%but_ix) Find the nearest neighbor for the given point C<$p> and returns its index and the distance between the two points (in scalar context the index is returned). If C<$max_d> is defined, the search is limited to the points within that distance Optionally, a list of point indexes to be excluded from the search can be passed or, alternatively, a reference to a hash containing the indexes of the points to be excluded. =item @ix = $t->find_nearest_neighbor_all_internal Returns the index of the nearest neighbor for every point inside the tree. It is equivalent to (though, internally, it uses a better algorithm): @ix = map { scalar $t->nearest_neighbor($t->at($_), undef, $_) } 0..($t->size - 1); =item @ix = $t->find_in_ball($z, $d, $but) =item $n = $t->find_in_ball($z, $d, $but) Finds the points inside the tree contained in the hypersphere with center C<$z> and radius C<$d>. In scalar context returns the number of points found. In list context returns the indexes of the points. If the extra argument C<$but> is provided. The point with that index is ignored. =item @ix = $t->ordered_by_proximity Returns the indexes of the points in an ordered where is likely that the indexes of near vectors are also in near positions in the list. =back =head1 SEE ALSO L L =head1 COPYRIGHT AND LICENSE Copyright (C) 2011-2013 by Salvador FandiEo Esfandino@yahoo.comE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.12.3 or, at your option, any later version of Perl 5 you may have available. =cut Math-Vector-Real-kdTree-0.09/sample/0000755000175000017500000000000012157567104016157 5ustar salvasalvaMath-Vector-Real-kdTree-0.09/sample/boxes.pl0000644000175000017500000000377611577640037017653 0ustar salvasalva#!/usr/bin/perl use 5.010; use strict; use warnings; use GD; use Math::Vector::Real; use Math::Vector::Real::Random; use Math::Vector::Real::kdTree; my $p = 10000; my $w = 1024; my $im = GD::Image->new($w, $w); my $white = $im->colorAllocate(255,255,255); my $black = $im->colorAllocate(0, 0, 0); # $im->transparent($white); $im->interlaced('true'); sub scl { my $p = shift; @{$w * (0.3 * $p + [0.5, 0.5])}[0, 1]; } sub sscl { my $s = shift; $w * (0.3*$s); } my @p; while () { s/\s//g; push @p, V($1, $2) if /\{(-?[\d\.]+)\,(-?[\d\.]+)}/; } if (@p < $p) { @p = map Math::Vector::Real->random_normal(2, 0.6), 1..$p; } # @p = @p[0..$#p]; my $tree = Math::Vector::Real::kdTree->new(@p); my %path; for (0..$#p) { push @{$path{$tree->path($_)}}, $_; } my @colors; for my $set (values %path) { my $color = $im->colorAllocate(map int $_, @{Math::Vector::Real->random_versor(3, 255.9)}); if ($color >= 0) { push @colors, $color; } else { $color = $colors[rand @colors]; } my ($b, $t) = Math::Vector::Real->box(@p[@$set]); $im->rectangle(scl($b), scl($t), $color); $im->filledEllipse(scl($_), 3, 3, $color) for @p[@$set]; } open my $fh, ">output.png"; print $fh $im->png; __DATA__ {0.360273672659563, 0.681459947082673} {0.176663207393249, 0.404644066772445} {1.05728054075933, 0.14704076332749} {0.553760099403691, 0.0547824407714363} {0.0479743023870717, 0.963824108595659} {0.776144419292398, 0.10956787723834} {1.0209388373113, 0.971510537877524} {0.0706926934034146, -0.114056543099417} {0.515397128075519, 0.612716041689772} {0.26975413715681, 1.03607341990943} {0.402473337889129, 0.292854432427144} {0.502995986052089, 0.713098206321628} {0.654221365535431, 0.413225433599031} {0.809595420704002, 0.23428087884566} {0.727126702840134, 0.589085324802046} {0.495470529749333, 0.16063680625426} {0.290835931539363, 1.06150585371687} {0.159456912007944, 0.897423580738299} {0.160445827140042, 0.503289145929537} {0.26744213070957, 0.147348345161297} Math-Vector-Real-kdTree-0.09/t/0000755000175000017500000000000012157567104015141 5ustar salvasalvaMath-Vector-Real-kdTree-0.09/t/pods.t0000644000175000017500000000047211577640037016300 0ustar salvasalva#!/usr/bin/perl use strict; use Test::More; plan skip_all => "Only the author needs to check that POD docs are right" unless eval "no warnings; getlogin eq 'salva'"; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok( all_pod_files( qw(blib) ) ); Math-Vector-Real-kdTree-0.09/t/Math-Vector-Real-kdTree.t0000644000175000017500000000462512157546335021566 0ustar salvasalva#!/usr/bin/perl use strict; use warnings; use Test::More tests => 6617; use_ok('Math::Vector::Real::kdTree'); use Math::Vector::Real; sub neighbors_bruteforce { my ($bottom, $top) = Math::Vector::Real->box(@_); my $box = $top - $bottom; my $v = [map $_ - $bottom, @_]; my $ixs = [0..$#_]; my $dist2 = [($box->abs2 * 10 + 1) x @_]; my $neighbors = [(undef) x @_]; _neighbors_bruteforce($v, $ixs, $dist2, $neighbors, $box, 0); return @$neighbors; } sub _neighbors_bruteforce { my ($v, $ixs, $dist2, $neighbors) = @_; my $ixix = 0; for my $i (@$ixs) { $ixix++; my $v0 = $v->[$i]; for my $j (@$ixs[$ixix..$#$ixs]) { my $d2 = $v0->dist2($v->[$j]); if ($dist2->[$i] > $d2) { $dist2->[$i] = $d2; $neighbors->[$i] = $j; } if ($dist2->[$j] > $d2) { $dist2->[$j] = $d2; $neighbors->[$j] = $i; } } } } sub test_neighbors { my ($o, $n1, $n2, $msg) = @_; my (@d1, @d2); for my $ix (0..$#$o) { my $eo = $o->[$ix]; my $ixn1 = $n1->[$ix]; my $ixn2 = $n2->[$ix]; my $en1 = $o->[$ixn1]; my $en2 = $o->[$ixn2]; push @d1, $eo->dist2($en1); push @d2, $eo->dist2($en2); } is "@d1", "@d2", $msg; } my %gen = ( num => sub { rand }, int => sub { int rand(10) } ); diag "srand: " . srand; for my $g (keys %gen) { for my $d (1, 2, 3, 10) { for my $n (2, 10, 50, 250, 500) { my $id = "gen: $g, d: $d, n: $n"; my @o = map V(map $gen{$g}->(), 1..$d), 1..$n; my @nbf = neighbors_bruteforce(@o); my $t = Math::Vector::Real::kdTree->new(@o); my @n = $t->find_nearest_neighbor_all_internal; is ($#n, $#o, "find_nearest_neighbor_all_internal - build - $id"); test_neighbors(\@o, \@n, \@nbf, "find_nearest_neighbor_all_internal - build - $id"); $t = Math::Vector::Real::kdTree->new; for my $ix (0..$#o) { $t->insert($o[$ix]); my @obp = $t->ordered_by_proximity; is ($ix, $#obp, "ordered_by_proxymity - count - $id, ix: $ix"); } @n = $t->find_nearest_neighbor_all_internal; test_neighbors(\@o, \@n, \@nbf, "find_nearest_neighbor_all_internal - insert - $id"); } } } Math-Vector-Real-kdTree-0.09/t/count.t0000644000175000017500000000054312157546335016463 0ustar salvasalva#!/usr/bin/perl use strict; use warnings; use Test::More tests => 40; use Math::Vector::Real::kdTree; my $tree = Math::Vector::Real::kdTree->new(); my @is; for my $i (0..39) { push @is, $i; $tree->insert(Math::Vector::Real->new($i)); my @all = sort { $a <=> $b } $tree->ordered_by_proximity; is ("@all", "@is", "count indexes - $i"); } Math-Vector-Real-kdTree-0.09/Changes0000644000175000017500000000163612157565136016202 0ustar salvasalvaRevision history for Perl extension Math::Vector::Real::kdTree. 0.09 Jun 17, 2013 - add support for excluding more than one point in neighbor searching methods 0.08 Feb 16, 2013 - add test for RT but #83330 0.07 Feb 15, 2013 - insert method was broken (bug report by Greg Bronevetsky) - add test suite 0.06 Oct 22, 2012 - add a clone method 0.05 Sep 21, 2012 - insert now accepts several points and returns the index of the first element inserted 0.04 Jun 19, 2012 - add hide method - move and _delete methods were broken - add ordered_by_proximity method 0.03 Jun 22, 2011 - solve bug on find_nearest_neighbor when distance is limited 0.02 Jun 16, 2011 - add find_in_ball method 0.01 Wed Jun 15 18:09:43 2011 - original version; created by h2xs 1.23 with options -AXn Math::Vector::Real::kdTree Math-Vector-Real-kdTree-0.09/MANIFEST0000644000175000017500000000045212157567104016030 0ustar salvasalvaChanges Makefile.PL MANIFEST README t/Math-Vector-Real-kdTree.t t/pods.t t/count.t lib/Math/Vector/Real/kdTree.pm sample/boxes.pl META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Math-Vector-Real-kdTree-0.09/Makefile.PL0000644000175000017500000000070711577640037016656 0ustar salvasalvause 5.010; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Math::Vector::Real::kdTree', VERSION_FROM => 'lib/Math/Vector/Real/kdTree.pm', PREREQ_PM => { 'Math::Vector::Real' => '0.06', 'Sort::Key::Top' => '0.06' }, ABSTRACT_FROM => 'lib/Math/Vector/Real/kdTree.pm', AUTHOR => 'Salvador Fandiño ' ); Math-Vector-Real-kdTree-0.09/README0000644000175000017500000000116612157546335015565 0ustar salvasalvaMath-Vector-Real-kdTree ======================= k-d Trees in Perl INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: Math::Vector::Real Sort::Key::Top COPYRIGHT AND LICENCE Put the correct copyright and licence information here. Copyright (C) 2011-2013 by Salvador Fandiño This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.12.3 or, at your option, any later version of Perl 5 you may have available. Math-Vector-Real-kdTree-0.09/META.yml0000664000175000017500000000106512157567104016153 0ustar salvasalva--- abstract: 'kd-Tree implementation on top of Math::Vector::Real' author: - 'Salvador Fandiño ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Math-Vector-Real-kdTree no_index: directory: - t - inc requires: Math::Vector::Real: 0.06 Sort::Key::Top: 0.06 version: 0.09 Math-Vector-Real-kdTree-0.09/META.json0000664000175000017500000000170712157567104016326 0ustar salvasalva{ "abstract" : "kd-Tree implementation on top of Math::Vector::Real", "author" : [ "Salvador Fandiño " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Math-Vector-Real-kdTree", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Math::Vector::Real" : "0.06", "Sort::Key::Top" : "0.06" } } }, "release_status" : "stable", "version" : "0.09" }