File Coverage

blib/lib/Astro/Coord/ECI/VSOP87D/_Superior.pm

Criterion	Covered	Total	%
statement	77	89	86.5
branch	21	28	75.0
condition	1	2	50.0
subroutine	17	20	85.0
pod	5	5	100.0
total	121	144	84.0

package Astro::Coord::ECI::VSOP87D::_Superior;

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 PIOVER2 find_first_true mod2pi };
use Astro::Coord::ECI::VSOP87D qw{ :mixin };
use Carp;

our $VERSION = '0.006';

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 = (
	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 coder.
sub next_quarter {
    my ( $self, $quarter, %opt ) = @_;

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

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

    my @checker = (
	sub {	# 0 = conjunction
	    my ( $time ) = @_;
	    return $self->__longitude_from_sun( $time ) < 0 ? 4 : 0;
	},
	sub {	# 1 = west quadrature
	    my ( $time ) = @_;
	    return $self->__longitude_from_sun( $time, - PIOVER2 ) < 0 ? 1 : 0;
	},
	sub {	# 2 = opposition
	    my ( $time ) = @_;
	    return $self->__longitude_from_sun( $time, PI ) < 0 ? 2 : 0;
	},
	sub {	# 3 = east quadrature
	    my ( $time ) = @_;
	    return $self->__longitude_from_sun( $time, PIOVER2 ) < 0 ? 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 conjunction',
	'%s west quadrature',
	'%s opposition',
	'%s east quadrature',
    ];
    return sprintf $name->[$event], $self->get( 'name' );
}

{
    my %mutator = (
	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__