File Coverage

blib/lib/Math/Vector/Real/Neighbors.pm
Criterion Covered Total %
statement 12 90 13.3
branch 0 14 0.0
condition n/a
subroutine 4 13 30.7
pod 1 5 20.0
total 17 122 13.9


line stmt bran cond sub pod time code
1             package Math::Vector::Real::Neighbors;
2              
3             our $VERSION = '0.02';
4              
5 1     1   53449 use strict;
  1         3  
  1         39  
6 1     1   5 use warnings;
  1         2  
  1         31  
7              
8 1     1   1053 use Math::Vector::Real::kdTree;
  1         13354  
  1         49  
9 1     1   1055 use Sort::Key::Radix qw(nkeysort_inplace);
  1         857  
  1         1210  
10              
11             sub neighbors_slow {
12 0     0 0   my $class = shift;
13 0           my ($bottom, $top) = Math::Vector::Real->box(@_);
14 0           my $box = $top - $bottom;
15 0           my $v = [map $_ - $bottom, @_];
16 0           my $ixs = [0..$#_];
17 0           my $dist2 = [($box->abs2 * 10) x @_];
18 0           my $neighbors = [(undef) x @_];
19 0           _neighbors($v, $ixs, $dist2, $neighbors, $box, 0);
20 0           return @$neighbors;
21             }
22              
23             sub neighbors_bruteforce {
24 0     0 1   my $class = shift;
25 0           my ($bottom, $top) = Math::Vector::Real->box(@_);
26 0           my $box = $top - $bottom;
27 0           my $v = [map $_ - $bottom, @_];
28 0           my $ixs = [0..$#_];
29 0           my $dist2 = [($box->abs2 * 10) x @_];
30 0           my $neighbors = [(undef) x @_];
31 0           _neighbors_bruteforce($v, $ixs, $dist2, $neighbors, $box, 0);
32 0           return @$neighbors;
33             }
34              
35             sub neighbors_kdtree {
36 0     0 0   shift;
37 0           my $tree = Math::Vector::Real::kdTree->new(@_);
38 0           map scalar($tree->find_nearest_neighbor_internal($_)), 0..$#_
39             }
40              
41             sub neighbors_kdtree2 {
42 0     0 0   shift;
43 0           ( Math::Vector::Real::kdTree
44             -> new(@_)
45             -> find_nearest_neighbor_all_internal );
46             }
47              
48             *neighbors = \&neighbors_kdtree2;
49              
50             sub _neighbors_bruteforce {
51 0     0     my ($v, $ixs, $dist2, $neighbors) = @_;
52 0           my $ixix = 0;
53 0           for my $i (@$ixs) {
54 0           $ixix++;
55 0           my $v0 = $v->[$i];
56 0           for my $j (@$ixs[$ixix..$#$ixs]) {
57 0           my $d2 = $v0->dist2($v->[$j]);
58 0 0         if ($dist2->[$i] > $d2) {
59 0           $dist2->[$i] = $d2;
60 0           $neighbors->[$i] = $j;
61             }
62 0 0         if ($dist2->[$j] > $d2) {
63 0           $dist2->[$j] = $d2;
64 0           $neighbors->[$j] = $i;
65             }
66             }
67             }
68             }
69              
70             sub _neighbors {
71 0 0   0     if (@{$_[1]} < 6) {
  0            
72 0           _neighbors_bruteforce(@_);
73             }
74             else {
75 0           my ($v, $ixs, $dist2, $neighbors, $box) = @_;
76 0           my $dim = $box->max_component_index;
77 0     0     nkeysort_inplace { $v->[$_][$dim] } @$ixs;
  0            
78              
79 0           my $bfirst = @$ixs >> 1;
80 0           my $alast = $bfirst - 1;
81              
82 0           my $abox = $box->clone;
83 0           $abox->[$dim] = $v->[$ixs->[$alast]][$dim] - $v->[$ixs->[0]][$dim];
84 0           my $bbox = $box->clone;
85 0           $bbox->[$dim] = $v->[$ixs->[$#$ixs]][$dim] - $v->[$ixs->[$bfirst]][$dim];
86              
87 0           _neighbors($v, [@$ixs[0..$alast]], $dist2, $neighbors, $abox);
88 0           _neighbors($v, [@$ixs[$bfirst..$#$ixs]], $dist2, $neighbors, $bbox);
89              
90 0           for my $i (@$ixs[0..$alast]) {
91 0           my $vi = $v->[$i];
92 0           my $mind2 = $dist2->[$i];
93 0           for my $j (@$ixs[$bfirst..$#$ixs]) {
94 0           my $vj = $v->[$j];
95 0           my $dc = $vj->[$dim] - $vi->[$dim];
96 0 0         last unless ($mind2 > $dc * $dc);
97 0           my $d2 = $vi->dist2($vj);
98 0 0         if ($d2 < $mind2) {
99 0           $mind2 = $dist2->[$i] = $d2;
100 0           $neighbors->[$i] = $j;
101             }
102             }
103             }
104              
105 0           for my $i (@$ixs[$bfirst..$#$ixs]) {
106 0           my $vi = $v->[$i];
107 0           my $mind2 = $dist2->[$i];
108 0           for my $j (reverse @$ixs[0..$alast]) {
109 0           my $vj = $v->[$j];
110 0           my $dc = $vj->[$dim] - $vi->[$dim];
111 0 0         last unless ($mind2 > $dc * $dc);
112 0           my $d2 = $vi->dist2($vj);
113 0 0         if ($d2 < $mind2) {
114 0           $mind2 = $dist2->[$i] = $d2;
115 0           $neighbors->[$i] = $j;
116             }
117             }
118             }
119              
120             # my @dist2_cp = @$dist2;
121             # my @neighbors_cp = @$neighbors;
122             # _neighbors_bruteforce($v, $ixs, $dist2, $neighbors, $abox);
123             # use 5.010;
124             # say "ixs : @$ixs";
125             # say "neighbors_cp: @neighbors_cp[@$ixs]";
126             # say "neighbors : @$neighbors[@$ixs]";
127             }
128             }
129              
130             sub neighbors_bubble {
131 0     0 0   my $class = shift;
132 0           my @v = @_;
133 0           my $n = sqrt(@v);
134 0           my (@c, @r, @p); # bubbles centers, radius and points
135             }
136              
137 0     0     sub _neighbors_bubble {}
138              
139             1;
140             __END__