view release on metacpan or  search on metacpan

lib/Algorithm/ClusterPoints.pm  view on Meta::CPAN

}

sub _touch {
    my ($c1, $c2, $coords, $groups) = @_;
    # print STDERR "touch($c1->[0], $c2->[0])\n";

    for my $coord (@$coords) {
        my $c1_min = min @{$coord}[@$c1];
        my $c2_max = max @{$coord}[@$c2];
        return 0 if $c1_min - $c2_max > 1;

        my $c1_max = max @{$coord}[@$c1];
        my $c2_min = min @{$coord}[@$c2];
        return 0 if $c2_min - $c1_max > 1;
    }

    for my $i (@$c1) {
    J: for my $j (@$c2) {
            for my $group (@$groups) {
                my $sum = 0;
                for (@{$coords}[@$group]) {
                    my $delta = $_->[$i] - $_->[$j];
                    $sum += $delta * $delta;
                }
                next J if $sum > 1;
            }
            # print STDERR "they touch\n";
            return 1;
        }
    }
    0;
}

sub _scaled_coords {
    my $self = shift;
    my @coords = @{$self->{coords}};
    my $scales = $self->{scales};
    my $ir = 1.0 / $self->{radius};
    for my $dimension (0..$#coords) {
        my $scale = abs($ir * $scales->[$dimension]);
        next if $scale == 1;
        $coords[$dimension] = [ map $scale * $_, @{$coords[$dimension]} ];
    }
    @coords;
}

sub _hypercylinder_id { join '|', map join(',', @$_), @_ }

sub _make_clusters_ix {
    my $self = shift;
    # print STDERR Dumper $self;
    _hypercylinder_id($self->dimensional_groups) eq '0,1'
        ? $self->_make_clusters_ix_2
        : $self->_make_clusters_ix_any;
}

sub _make_clusters_ix_2 {
    my $self = shift;

    $self->{dimension} == 2
        or croak 'internal error: _make_clusters_ix_2 called but dimension is not 2';

    my ($ax, $ay) = $self->_scaled_coords;
    @$ax or croak "points have not been added";

    my $xmin = min @$ax;
    my $ymin = min @$ay;
    # my $xmax = max @$ax;
    # my $ymax = max @$ay;

    my $istep = 1.00001*sqr2;
    my @fx = map { floor($istep * ($_ - $xmin)) } @$ax;
    my @fy = map { floor($istep * ($_ - $ymin)) } @$ay;

    my (%ifx, %ify, $c);
    $c = 1; $ifx{$_} ||= $c++ for @fx;
    $c = 1; $ify{$_} ||= $c++ for @fy;
    my %rifx = reverse %ifx;
    my %rify = reverse %ify;

    my %cell;
    # my %cellid;
    my $cellid = 1;
    for my $i (0..$#$ax) {
        my $cell = pack $packing => $ifx{$fx[$i]}, $ify{$fy[$i]};
        push @{$cell{$cell}}, $i;
        # $cellid{$cell} ||= $cellid++;
        # print STDERR "i: $i, x: $ax->[$i], y: $ay->[$i], fx: $fx[$i], fy: $fy[$i], ifx: $ifx{$fx[$i]}, ify: $ify{$fy[$i]}, cellid: $cellid{$cell}\n";
    }

    my %cell2cluster; # n to 1 relation
    my %cluster2cell; # when $cluster2cell{$foo} does not exists

    while(defined (my $cell = each %cell)) {
        my %cluster;
        my ($ifx, $ify) = unpack $packing => $cell;
        my $fx = $rifx{$ifx};
        my $fy = $rify{$ify};
        for my $dx (-2, -1, 0, 1, 2) {
            my $ifx = $ifx{$fx + $dx};
            defined $ifx or next;
            my $filter = 6 - $dx * $dx;
            for my $dy (-2, -1, 0, 1, 2) {
                # next if $dx * $dx + $dy * $dy > 5;
                next if $dy * $dy > $filter;
                my $ify = $ify{$fy + $dy};
                defined $ify or next;
                my $neighbor = pack $packing => $ifx, $ify;
                my $cluster = $cell2cluster{$neighbor};
                if ( defined $cluster and
                     !$cluster{$cluster} and
                     _touch_2($cell{$cell}, $cell{$neighbor}, $ax, $ay) ) {
                    $cluster{$cluster} = 1;
                }
            }
        }
        if (%cluster) {
            my ($to, $to_cells);
            if (keys %cluster > 1) {
                my $max = 0;
                for (keys %cluster) {