view release on metacpan or  search on metacpan

lib/Geo/DNA.pm  view on Meta::CPAN

        _mod( ( $lat + 90.0 + $dy ), 180.0 ) - 90.0,
        _mod( ( $lon + 180.0 + $dx ), 360.0 )  - 180.0
    );
}


sub normalise {
    my ( $lat, $lon ) = @_;
    return (
        _mod( ( $lat + 90.0 ), 180.0 ) - 90.0,
        _mod( ( $lon + 180.0 ), 360.0 ) - 180.0,
    );
}

# """
# Return the eight neighboring geodna codes

sub neighbours_geo_dna {
    my ( @args ) = @_;
    neighbours( @args );
}

sub neighbours {
    my ( $geodna ) = @_;

    # TODO:kd - this can be optimised
    my ( $lati, $loni ) = bounding_box( $geodna );
    my $width  = abs( $loni->[1] - $loni->[0] );
    my $height = abs( $lati->[1] - $lati->[0] );

    my $neighbours = [];
    foreach my $y ( -1, 0, 1 ) {
        foreach my $x ( -1, 0, 1 ) {
            next unless ( $x || $y );
            push (@$neighbours, encode( add_vector( $geodna, $height * $y, $width * $x ) ) );
        }
    }
    return $neighbours;
}

sub point_from_point_bearing_and_distance {
    my ( $geodna, $bearing, $distance, @opts ) = @_;
    my $options = { @opts };
    my $distance = $distance * 1000; # make it metres instead of kilometres
    my $precision = $options->{precision} || length( $geodna );
    my ( $lat1, $lon1 ) = decode( $geodna, radians => 1 );

    my $lat2 = asin( sin( $lat1 ) * cos( $distance / $RADIUS_OF_EARTH ) +
                     cos( $lat1 ) * sin( $distance / $RADIUS_OF_EARTH ) * cos( $bearing ) );
    my $lon2 = $lon1 + atan2( sin( $bearing ) * sin( $distance / $RADIUS_OF_EARTH ) * cos( $lat1 ),
                      cos( $distance / $RADIUS_OF_EARTH ) - sin( $lat1 ) * sin( $lat2 ));
    return encode( $lat2, $lon2, precision => $precision, radians => 1 );
}

sub distance_in_km {
    my ( $ga, $gb ) = @_;
    my ( $alat, $alon ) = decode( $ga );
    my ( $blat, $blon ) = decode( $gb );

    # if a[1] and b[1] have different signs, we need to translate
    # everything a bit in order for the formulae to work.
    if ( $alon * $blon < 0.0 && abs( $alon - $blon ) > 180.0 ) {
        ( $alat, $alon ) = add_vector( $ga, 0.0, 180.0 );
        ( $blat, $blon ) = add_vector( $gb, 0.0, 180.0 );
    }
    my $x = ( deg2rad( $blon ) - deg2rad( $alon ) ) * cos( ( deg2rad( $alat ) + deg2rad( $blat ) ) / 2 );
    my $y = ( deg2rad( $blat ) - deg2rad( $alat ) );
    my $d = sqrt( $x * $x + $y * $y ) * $RADIUS_OF_EARTH;
    return $d / 1000;
}

# This is experimental!!
# Totally unoptimised - use at your peril!
sub neighbours_within_radius {
    my ( $geodna, $radius, @opts) = @_;
    my $options = { @opts };
    $options->{precision} ||= 12;

    my $neighbours = [];
    my $rh = $radius * sqrt(2);

    my $start = point_from_point_bearing_and_distance( $geodna, -( pi / 4 ), $rh, %$options );
    my   $end = point_from_point_bearing_and_distance( $geodna, pi / 4, $rh, %$options );
    my ( $blat, $blon ) = bounding_box( $start );
    my ( $dummy, $slon ) = decode( $start );
    my ( $dummy, $elon ) = decode( $end );
    my $dheight = abs( $blat->[1] - $blat->[0] );
    my $dwidth  = abs( $blon->[1] - $blon->[0] );
    my ( $nlat, $nlon ) = normalise( 0.0, abs( $elon - $slon ) );
    my $delta = abs( $nlon );
    my $tlat = 0.0;
    my $tlon = 0.0;
    my $current = $start;

    while ( $tlat <= $delta ) {
        while ( $tlon <= $delta ) {
            my ( $clat, $clon ) = add_vector( $current, 0.0, $dwidth );
            $current = encode( $clat, $clon, %$options );
            my $d = distance_in_km( $current, $geodna );
            if ( $d <= $radius ) {
                push @$neighbours, $current;
            }
            $tlon = $tlon + $dwidth;
        }

        $tlat = $tlat + $dheight;
        my ( $rlat, $rlon ) = add_vector( $start, -$tlat , 0.0 );
        $current = encode( $rlat, $rlon, %$options );
        $tlon = 0.0;
    }
    return $neighbours;
}

# This takes an array of GeoDNA codes and reduces it to its
# minimal set of codes covering the same area.
# Needs a more optimal impl.
sub reduce {
    my ( $geodna_codes ) = @_;

    # hash all the codes
    my $codes = {};