view release on metacpan or  search on metacpan

lib/Acme/Geo/Whitwell/Name.pm  view on Meta::CPAN

=head1 FUNCTIONS

=head2 to_whitwell($lat, $lon)

Generates a properly-capitalized Whitwell name from a latitude-longitude pair.
Latitude and longitude are truncated to the two digits after the decimal point,
in keeping with Whitwell's original scheme. Zeroes are added after the decimal
point as necessary.

North latitudes are positve, and south latitudes are negative. East longitudes
are positive, west longitudes are negative. Trailing E/W and N/S are converted
into the appropriate sign. If you supply both for some reason, trailing 
sign indicators override signs.

Returns both alternatives for the name (see L<SCHEME>).

=cut

sub to_whitwell {
     my($lat, $lon) = @_;
     return ( _vowel_build($lat)     . ' ' . _consonant_build($lon),
              _consonant_build($lat) . ' ' . _vowel_build($lon)
     );
}

sub _vowel_build     { _gen(shift, [\@vowels, \@consonants], 's') }
sub _consonant_build { _gen(shift, [\@consonants, \@vowels], 'v') }

sub _gen {
    # The coordinate, the letter lists, and the appropriate sign consonant.
    my($coord, $lists, $neg) = @_;

    # Turn the floating-point number into a list of digits.
    # Note that _two_decimal does NOT CARE about sign or sign indicators.
    $coord = uc(my $orig_coord = $coord);
    my @coord = grep {/(\d)/} (split //, _two_decimal($coord));

    my $word = '';
    my $list = 0;
    my $signed = 0;

    my ($is_negative) = ($coord =~ s/[SW]//g);
    my ($is_positive) = ($coord =~ s/[NE]//g);

    croak 
        "Coordinate '$orig_coord' does not look like a proper coordinate"
            if !looks_like_number($coord);

    $is_negative = ($coord < 0) unless $is_negative;

    my $conflicting = ($is_negative and $is_positive) ? 'conflicting ' : '';
    croak "Multiple ${conflicting}sign indicators detected in '$orig_coord'"
      if  $conflicting or $is_negative > 1 or $is_positive > 1;

    foreach my $digit (@coord) {
        # Convert the next digit into a letter from the proper table.
        my $letter = $lists->[$list]->[$digit];
        ### "$letter -> $digit"

        # Decide whether to insert a sign consonant.        
        if (exists $vowel{$letter} and $is_negative and not $signed) {
            # If negative, we have a vowel, and we haven't inserted the sign
            # consonant yet, insert it.
            $letter .= $neg;
            # Now signed.
            $signed = 1;
            $list = !$list;
        }
        # Add new letter(s) to word and continue;
        $word .= $letter;
        $list = !$list;
    }
    return ucfirst $word;
}

sub _two_decimal {
    my ($coord) = @_;
    
    # Discard non-digits except for a decimal point.
    $coord =~ s/[^\d\.]//g;

    # Drop leading zeros.
    $coord =~ s/^0*//g;
    $coord = 0 unless $coord;

    if (abs($coord) > 180) {
        croak "$coord must be between -180 and +180\n";
    }
    unless ($coord =~ /\./) {
        # add decimals
        $coord .= ".";
    }
    # Add two more zeroes; we'll discard them if we don't need them.
    $coord .= "00"; 
    ($coord) = ($coord =~ /^(\d{0,3}\.\d\d)/);
    return $coord;
}

=head2 from_whitwell($whitwell_name, signed => $yes_or_no)

Converts a Whitwell name back into a lat/lon pair, in trailing indicator
format.  Results will be undefined if the string does not match the Whitwell
scheme; if the strings I<is> Whitwell-compatible, but includes extra letters,
these will be assumed to be further digits after the decimal point.

If you supply the 'signed' option with a true value, the returned values are
signed numbers rather than numbers with trailing sign indicators.

=cut

sub from_whitwell {
    my($name, %opts) = @_;
    my ($lat_name, $lon_name) = split(/\s+/, $name);

    my ($value, $negative);
    ($value, $negative) = _coord_for(lc($lat_name)); 
    if ($negative) {
        if ($opts{signed}) {
            $value = -$value;
        }