package Test::GenOO::GenomicRegion;
use strict;

use base qw(Test::GenOO);
use Test::Moose;
use Test::Most;
use Test::Exception;

#######################################################################
################   Startup (Runs once in the begining  ################
#######################################################################
sub _check_loading : Test(startup => 1) {
	my ($self) = @_;
	use_ok $self->class;
};

#######################################################################
#################   Setup (Runs before every method)  #################
#######################################################################
sub create_new_test_objects : Test(setup) {
	my ($self) = @_;
	
	my $test_class = ref($self) || $self;
	$self->{TEST_OBJECTS} = $test_class->test_objects();
};

#######################################################################
##########################   Initial Tests   ##########################
#######################################################################
sub _isa_test : Test(1) {
	my ($self) = @_;
	isa_ok $self->obj(0), $self->class, "... and the object";
}

sub _role_check : Test(1) {
	my ($self) = @_;
	does_ok($self->obj(0), 'GenOO::Region', '... does the GenOO::Region role');
}

#######################################################################
#######################   Class Interface Tests   #####################
#######################################################################
sub name : Test(2) {
	my ($self) = @_;
	
	has_attribute_ok($self->obj(0), 'name', "... test object has the 'name' attribute");
	is $self->obj(0)->name, 'test_object_0', "... and returns the correct value";
}

sub species : Test(2) {
	my ($self) = @_;
	
	has_attribute_ok($self->obj(0), 'species', "... test object has the 'species' attribute");
	is $self->obj(0)->species, 'human', "... and returns the correct value";
}

sub strand : Test(2) {
	my ($self) = @_;
	
	has_attribute_ok($self->obj(0), 'strand', "... test object has the 'strand' attribute");	
	is $self->obj(0)->strand, 1, "... and returns the correct value";
}

sub chromosome : Test(2) {
	my ($self) = @_;
	
	has_attribute_ok($self->obj(0), 'chromosome', "... test object has the 'chromosome' attribute");	
	is $self->obj(0)->chromosome, 'chr1', "... and returns the correct value";
}

sub start : Test(2) {
	my ($self) = @_;
	
	has_attribute_ok($self->obj(0), 'start', "... test object has the 'start' attribute");
	is $self->obj(0)->start, 3, "... and returns the correct value";
}

sub stop : Test(2) {
	my ($self) = @_;
	
	has_attribute_ok($self->obj(0), 'stop', "... test object has the 'stop' attribute");	
	is $self->obj(0)->stop, 10, "... and returns the correct value";
}

sub copy_number : Test(2) {
	my ($self) = @_;
	
	has_attribute_ok($self->obj(0), 'copy_number', "... test object has the 'copy_number' attribute");
	is $self->obj(0)->copy_number, 7, "... and returns the correct value";
}

sub sequence : Test(2) {
	my ($self) = @_;
	
	has_attribute_ok($self->obj(0), 'sequence', "... test object has the 'sequence' attribute");
	is $self->obj(0)->sequence, 'AGCTAGCU', "... and returns the correct value";
}

sub rname : Test(2) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'rname';
	is $self->obj(0)->rname, 'chr1', "... and returns the correct value";
}

sub id : Test(2) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'id';
	is $self->obj(0)->id, 'chr1:3-10:1', "... and returns the correct value";
}

#######################################################################
#######################   Role Interface Tests   ######################
#######################################################################
sub length : Test(2) {
	my ($self) = @_;
	
	has_attribute_ok($self->obj(0), 'length', "... test object has the 'length' attribute");
	is $self->obj(0)->length, 8, "... and returns the correct value";
}

sub location : Test(2) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'location';
	is $self->obj(0)->location, 'chr1:3-10:1', "... and returns the correct value";
}

sub strand_symbol : Test(2) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'strand_symbol';
	is $self->obj(0)->strand_symbol, '+', "... and returns the correct value";
}

sub head_position : Test(3) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'head_position';
	is $self->obj(0)->head_position, 3, "... and returns the correct value";
	is $self->obj(6)->head_position, 30, "... and returns the correct value";
}

sub tail_position : Test(3) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'tail_position';
	is $self->obj(0)->tail_position, 10, "... and returns the correct value";
	is $self->obj(6)->tail_position, 21, "... and returns the correct value";
}

sub mid_position : Test(5) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'mid_position';
	is $self->obj(0)->mid_position, 6.5, "... and returns the correct value";
	is $self->obj(1)->mid_position, 6, "... and returns the correct value";
	is $self->obj(6)->mid_position, 25.5, "... and returns the correct value";
	is $self->obj(7)->mid_position, 26, "... and returns the correct value";
}

sub mid_mid_distance_from : Test(6) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'mid_mid_distance_from';
	is $self->obj(1)->mid_mid_distance_from($self->obj(0)), -0.5, "... and returns the correct value";
	is $self->obj(0)->mid_mid_distance_from($self->obj(1)), 0.5, "... and returns the correct value";
	is $self->obj(9)->mid_mid_distance_from($self->obj(12)), 24.5, "... and returns the correct value";
	is $self->obj(12)->mid_mid_distance_from($self->obj(9)), -24.5, "... and returns the correct value";
	dies_ok {$self->obj(6)->mid_mid_distance_from($self->obj(9))} "... and dies when comparing regions on different reference";
}

sub mid_head_distance_from : Test(6) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'mid_head_distance_from';
	is $self->obj(1)->mid_head_distance_from($self->obj(0)), 3, "... and returns the correct value";
	is $self->obj(0)->mid_head_distance_from($self->obj(1)), 4.5, "... and returns the correct value";
	is $self->obj(9)->mid_head_distance_from($self->obj(12)), 32, "... and returns the correct value";
	is $self->obj(12)->mid_head_distance_from($self->obj(9)), -22.5, "... and returns the correct value";
	dies_ok {$self->obj(6)->mid_head_distance_from($self->obj(9))} "... and dies when comparing regions on different reference";
}

sub head_head_distance_from : Test(6) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'head_head_distance_from';
	is $self->obj(1)->head_head_distance_from($self->obj(0)), -1, "... and returns the correct value";
	is $self->obj(0)->head_head_distance_from($self->obj(1)), 1, "... and returns the correct value";
	is $self->obj(12)->head_head_distance_from($self->obj(9)), -30 , "... and returns the correct value";
	is $self->obj(9)->head_head_distance_from($self->obj(12)), 30 , "... and returns the correct value";
	dies_ok {$self->obj(6)->head_head_distance_from($self->obj(9))} "... and dies when comparing regions on different reference";

}

sub head_tail_distance_from : Test(6) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'head_tail_distance_from';
	is $self->obj(1)->head_tail_distance_from($self->obj(0)), -8, "... and returns the correct value";
	is $self->obj(0)->head_tail_distance_from($self->obj(1)), -7, "... and returns the correct value";
	is $self->obj(6)->head_tail_distance_from($self->obj(7)), -8, "... and returns the correct value";
	is $self->obj(12)->head_tail_distance_from($self->obj(9)), -34, "... and returns the correct value";
	dies_ok {$self->obj(6)->head_tail_distance_from($self->obj(9))} "... and dies when comparing regions on different reference";
}

sub tail_head_distance_from : Test(6) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'tail_head_distance_from';
	is $self->obj(0)->tail_head_distance_from($self->obj(2)), 9, "... and returns the correct value";
	is $self->obj(2)->tail_head_distance_from($self->obj(0)), 7, "... and returns the correct value";
	is $self->obj(6)->tail_head_distance_from($self->obj(7)), 9, "... and returns the correct value";
	is $self->obj(7)->tail_head_distance_from($self->obj(6)), 8, "... and returns the correct value";
	dies_ok {$self->obj(0)->tail_head_distance_from($self->obj(3))} "... and dies when comparing regions on different reference";
}

sub tail_tail_distance_from : Test(6) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'tail_tail_distance_from';
	is $self->obj(3)->tail_tail_distance_from($self->obj(4)), -1, "... and returns the correct value";
	is $self->obj(4)->tail_tail_distance_from($self->obj(3)), 1, "... and returns the correct value";
	is $self->obj(6)->tail_tail_distance_from($self->obj(7)), 1, "... and returns the correct value";
	is $self->obj(7)->tail_tail_distance_from($self->obj(6)), -1, "... and returns the correct value";
	dies_ok {$self->obj(0)->tail_tail_distance_from($self->obj(3))} "... and dies when comparing regions on different reference";
}

sub to_string : Test(2) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'to_string';
	is $self->obj(0)->to_string, 'chr1:3-10:1', "... and returns the correct value";
}

sub overlaps : Test(6) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'overlaps';
	is $self->obj(0)->overlaps($self->obj(1)), 1, "... and returns the correct value";
	is $self->obj(0)->overlaps($self->obj(6)), 0, "... and returns the correct value";
	is $self->obj(6)->overlaps($self->obj(7)), 1, "... and returns the correct value";
	is $self->obj(12)->overlaps($self->obj(13)), 0, "... and returns the correct value"; # strand sensitive
	is $self->obj(12)->overlaps($self->obj(13), 0), 1, "... and returns the correct value"; # strand insensitive
}

sub overlaps_with_offset : Test(6) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'overlaps_with_offset';
	is $self->obj(0)->overlaps_with_offset($self->obj(1)), 1, "... and returns the correct value";
	is $self->obj(11)->overlaps_with_offset($self->obj(12)), 0, "... and returns the correct value"; # without span
	is $self->obj(11)->overlaps_with_offset($self->obj(12), 1, 10), 1, "... and returns the correct value"; # with span
	is $self->obj(12)->overlaps_with_offset($self->obj(13)), 0, "... and returns the correct value"; # strand sensitive
	is $self->obj(12)->overlaps_with_offset($self->obj(13), 0), 1, "... and returns the correct value"; # strand insensitive
}

sub overlap_length : Test(5) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'overlap_length';
	is $self->obj(0)->overlap_length($self->obj(1)), 8, "... and returns the correct value";
	is $self->obj(0)->overlap_length($self->obj(6)), 0, "... and returns the correct value";
	is $self->obj(6)->overlap_length($self->obj(7)), 9, "... and returns the correct value";
	is $self->obj(12)->overlap_length($self->obj(13)), 0, "... and returns the correct value";
}

sub contains : Test(7) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'contains';
	is $self->obj(0)->contains($self->obj(1)), 0, "... and returns the correct value";
	is $self->obj(1)->contains($self->obj(0)), 1, "... and returns the correct value";
	is $self->obj(0)->contains($self->obj(6)), 0, "... and returns the correct value";
	is $self->obj(6)->contains($self->obj(7)), 1, "... and returns the correct value";
	is $self->obj(7)->contains($self->obj(6)), 0, "... and returns the correct value";
	is $self->obj(12)->contains($self->obj(13)), 0, "... and returns the correct value";
}

sub contains_position : Test(5) {
	my ($self) = @_;
	
	can_ok $self->obj(0), 'contains_position';
	is $self->obj(0)->contains_position(5), 1, "... and returns the correct value";
	is $self->obj(0)->contains_position(1), 0, "... and returns the correct value";
	is $self->obj(6)->contains_position(22), 1, "... and returns the correct value";
	is $self->obj(6)->contains_position(20), 0, "... and returns the correct value";
}

#######################################################################
##########################   Helper Methods   #########################
#######################################################################
sub obj {
	my ($self, $index) = @_;
	
	return $self->{TEST_OBJECTS}->[$index];
}

sub objs {
	my ($self) = @_;
	
	return @{$self->{TEST_OBJECTS}};
}


#######################################################################
###############   Class method to create test objects   ###############
#######################################################################
sub test_objects {
	my ($test_class) = @_;
	
	eval "require ".$test_class->class;
	
	my @test_objects;
	
	push @test_objects, $test_class->class->new(
		name        => 'test_object_0',
		species     => 'human',
		strand      => '+',
		chromosome  => 'chr1',
		start       => 3,
		stop        => 10,
		copy_number => 7,
		sequence    => 'AGCTAGCU'
	);
	push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr1', start => 2, stop => 10);
	push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr1', start => 1, stop => 10);
	push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr2', start => 11, stop => 20);
	push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr2', start => 12, stop => 21);
	push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr2', start => 13, stop => 20);
	push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr3', start => 21, stop => 30); # No 6
	push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr3', start => 22, stop => 30);
	push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr3', start => 23, stop => 30);
	push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr4', start => 31, stop => 35);
	push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr4', start => 33, stop => 40);
	push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr4', start => 32, stop => 40);
	push @test_objects, $test_class->class->new(strand => '-', chromosome => 'chr4', start => 50, stop => 65);
	push @test_objects, $test_class->class->new(strand => '+', chromosome => 'chr4', start => 50, stop => 65); # No 13
	
	
	return \@test_objects;
}

1;
