view release on metacpan or  search on metacpan

lib/Astro/Coord/ECI/VSOP87D/_Inferior.pm  view on Meta::CPAN

package Astro::Coord::ECI::VSOP87D::_Inferior;

use 5.008;

use strict;
use warnings;

use base qw{ Astro::Coord::ECI };

use Astro::Coord::ECI::Mixin qw{
    almanac almanac_hash
    next_quarter_hash
};
use Astro::Coord::ECI::Utils qw{ PI find_first_true mod2pi };
use Astro::Coord::ECI::VSOP87D qw{ :mixin };
use Carp;

our $VERSION = '0.008';

sub new {
    my ( $class, %arg ) = @_;
    $class->__default( \%arg );
    return $class->SUPER::new( %arg );
}

sub __almanac_event_type_iterator {
    my ( $self, $station ) = @_;

    my $inx = 0;

    my $horizon = $station->__get_almanac_horizon();

    my @events = (
	[ $station, next_elevation => [ $self, $horizon, 1 ],
	    horizon	=> '__horizon_name' ],
	[ $station, next_meridian => [ $self ],
	    transit	=> '__transit_name' ],
	[ $self, next_quarter => [], 'quarter', '__quarter_name' ],
    );

    return sub {
	$inx < @events
	    and return @{ $events[$inx++] };
	return;
    };
}

{
    my $get = sub {
	my ( $self, $name ) = @_;
	return $self->__get_attr()->{$name};
    };

    my %accessor = (
	elongation_in_longitude	=> $get,
	model_cutoff		=> $get,
	nutation_cutoff		=> $get,
    );

    sub attribute {
	my ( $self, $name ) = @_;
	exists $accessor{$name}
	    and return __PACKAGE__;
	return $self->SUPER::attribute( $name );
    }

    sub get {
	my ( $self, @arg ) = @_;
	my @rslt;
	foreach my $name ( @arg ) {
	    if ( my $code = $accessor{$name} ) {
		push @rslt, $code->( $self, $name );
	    } else {
		push @rslt, $self->SUPER::get( $name );
	    }
	    wantarray
		or return $rslt[0];
	}
	return @rslt;
    }
}

# NOTE that the %opt arguments are UNSUPPORTED and can be changed or
# removed without notice. Caveat codor.
sub next_quarter {
    my ( $self, $quarter, %opt ) = @_;

    my $time = $self->universal();

    my $elong_method = $self->get( 'elongation_in_longitude' ) ?
	'__longitude_from_sun' :
	'__angle_subtended_from_earth';

    my $increment = $self->synodic_period() / 16;

    my @checker = (
	sub {	# 0 = superior conjunction
	    my ( $time ) = @_;
	    $self->__longitude_from_sun( $time ) > 0 ? 4 : 0;
	},
	sub {	# 1 = elongaton east
	    my ( $time ) = @_;
	    return $self->$elong_method( $time ) <
		$self->$elong_method( $time - 1 ) ? 1 : 0;
	},
	sub {	# 2 = inferior conjunction
	    my ( $time ) = @_;
	    $self->__longitude_from_sun( $time ) < 0 ? 2 : 0;
	},
	sub {	# 3 = elongaton west
	    my ( $time ) = @_;
	    return $self->$elong_method( $time ) >
		$self->$elong_method( $time - 1 ) ? 3 : 0;
	},
    );

    if ( defined $opt{checker_result} ) {
	return $checker[$opt{checker_result}]->( $time );
    }

    my $test;
    if ( defined $quarter ) {
	$test = $checker[$quarter];
	while ( $test->( $time ) ) {
	    $time += $increment;
	}
	while ( ! $test->( $time ) ) {
	    $time += $increment;
	}
    } else {
	my @chk = grep { ! $_->( $time ) } @checker
	    or confess 'Programming error - no false checks';
	my $rslt;
	while ( ! $rslt ) {
	    $time += $increment;
	    foreach my $c ( @chk ) {
		$rslt = $c->( $time )
		    and last;
	    }
	}
	$quarter = $rslt % 4;
	$test = $checker[$quarter];
    }

    my $rslt = find_first_true( $time - $increment, $time, $test );

    $self->universal( $rslt );

    wantarray
	or return $rslt;
    return( $rslt, $quarter, $self->__quarter_name( $quarter ) );
}

sub __quarter_name {
    my ( $self, $event, $name ) = @_;
    $name ||= [
	'%s superior conjunction',
	'%s elongation east',
	'%s inferior conjunction',
	'%s elongation west',
    ];
    return sprintf $name->[$event], $self->get( 'name' );
}

{
    my $set = sub {
	my ( $self, $name, $value ) = @_;
	$self->__get_attr()->{$name} = $value;
	return $self;
    };

    my %mutator = (
	elongation_in_longitude	=> $set,
	model_cutoff		=> \&__mutate_model_cutoff,
	nutation_cutoff		=> \&__mutate_nutation_cutoff,
    );

    sub set {
	my ( $self, @arg ) = @_;
	while ( @arg ) {
	    my ( $name, $value ) = splice @arg, 0, 2;
	    if ( my $code = $mutator{$name} ) {
		$code->( $self, $name, $value );
	    } else {
		$self->SUPER::set( $name, $value );
	    }
	}
	return $self;
    }
}

1;

__END__

=head1 NAME

Astro::Coord::ECI::VSOP87D::_Inferior - VSOP87D inferior planets

=head1 SYNOPSIS

This abstract Perl class is not intended to be invoked directly by the
user.

=head1 DESCRIPTION

This abstract Perl class represents the VSOP87D model of an inferior
planet. It is a subclass of L<Astro::Coord::ECI|Astro::Coord::ECI>.

=head1 METHODS

This class supports the following public methods in addition to those
inherited from the superclass.

=head2 model_cutoff_definition

This method reports, creates, and deletes model cutoff definitions.

The first argument is the name of the model cutoff. If this is the only
argument, a reference to a hash defining the named model cutoff is
returned.  This return is a deep clone of the actual definition.

If the second argument is C<undef>, the named model cutoff is deleted.
If the model cutoff does not exist, the call does nothing. It is an
error to try to delete built-in cutoffs C<'none'> and C<'Meeus'>.

If the second argument is a reference to a hash, this defines or
redefines a model cutoff. The keys to the hash are the names of VSOP87D
series (C<'L0'> through C<'L5'>, C<'B0'> through C<'B5'>, and C<'R0'>
through C<'R5'>), and the value of each key is the number of terms of
that series to use. If one of the keys is omitted or has a false value,
that series is not used.

If the second argument is a scalar, it is expected to be a number, and a
model cutoff is generated consisting of all terms whose coefficient
(C<'A'> in Meeus' terminology) is equal to or greater than the number.

If the second argument is a code reference, this code is expected to
return a reference to a valid model cutoff hash as described two
paragraphs previously. Its arguments are the individual series hashes,
extracted from the model. Each hash will have the following keys:

=over

=item series