package ATR::MicePE::MouseTest;

use strict;
use warnings;
use base qw(ATR::DatabaseTestCase);

use ATR::MicePE::Mouse;
use ATR::GTx; # for constants
use ATR::BioTablesTest; # for test constants

# for penned date test
use ATR::DateRange;
use ATR::BioTables;

# for dict access
use ATR::MicePE::Weaning;
use ATR::MicePE::MatingPair;

#----------------------------------------------------------------------------
#
# createNamed and findByName

sub test_MakeMouse_FindMouse {
    my $self = shift;
    my $sess = ATR::DataSession->new;
    my $mousename = ATR::BioTablesTest::MOUSENAME_never_committed;

    my $find1 = ATR::MicePE::Mouse->findByName($mousename, $sess);
    $self->assert_null($find1);

    my $made = ATR::MicePE::Mouse->createNamed($mousename, $sess);
    $self->check_mouse($made,
		       tst => 'made',
		       name => $mousename);

    # Just check the mouse name...  we should get an ID, don't mind what
    $self->assert_is_idnum
      ( ATR::BioTables->getName_idName($mousename, ATR::BioTables::NAMETYPE_MOUSE) );

    my $sess2 = ATR::DataSession->new;
    my $find2 = ATR::MicePE::Mouse->findByName($mousename, $sess2);
    $self->check_mouse($find2,
		       tst => 'found',
		       name => $mousename);

    # Check debug strings
    $self->assert_matches( qr/^mouse \(name='$mousename', peid=\d+\)$/,
			   $find2->debugId );
    $self->assert_matches( qr/^mouse class ATR::MicePE::Mouse$/,
			   ref($find2)->debugId );

    # tear_down rolls back
}


sub test_MouseAttribs {
    my $self = shift;
    my $sess = ATR::DataSession->new;

    # How a fresh mouse should look
    my %fresh = (
		 sex => 'Not sexed',
		 genotypes => []);

    # Constants / things we'll check for created and fetched objects
    my %checks = (name => ATR::BioTablesTest::MOUSENAME_never_committed,
		  genotypes => [ "Sv:Sv/Sv", "dn:+/+" ], # XXX:TGTR data dependence
		  DOB => '2004-05-10 15:37:28',
		  DOD => undef,
		  sex => 'Male');

    # Make mouse and set various data
    my $made = ATR::MicePE::Mouse->createNamed($checks{name}, $sess);
    $self->check_mouse($made, tst => 'fresh', %fresh);

# Genotype...
    my $check_geno_count = sub {
	my ($mouse, $want_count) = @_;
	my @geno = $mouse->getGenotype;
	$self->assert_str_equals($want_count, scalar @geno);
    };

    $check_geno_count->($made, 0);
    $made->setGenotype(3, undef, "first = Sv/?");
    $check_geno_count->($made, 1);
    $made->setGenotype(6, undef, "second = dn:+/dn");
    $check_geno_count->($made, 2);
    # replace first; still two genotypes current
    $made->setGenotype(2, undef, "third = Sv/Sv");
    $check_geno_count->($made, 2);

    $made->setGenotype(undef, 4, "fourth = clear dn");
    $check_geno_count->($made, 1);
    $made->setGenotype(5, 4, "second = dn:+/+");
    $check_geno_count->($made, 2);

    $self->assert_dies(qr/locus=1, not 4 /,
		       sub { $made->setGenotype(3, 4) });
    $check_geno_count->($made, 2);

# DOB
    my $dob_date = __gt2date($checks{DOB});
    $self->assert_dies(qr/Found no 'alive' information/,
		       sub { $made->setDateDeath( $dob_date ) });
    $made->setDateBirth($dob_date);

    $made->setSex('M');

    # Check
    $self->check_mouse($made,  tst => 'made',  %checks);

    my @null_locus = $made->getGenotype(2);
    $self->assert_str_equals(0, scalar @null_locus);

    # Find another MicePE on the same PE, check that
    my $sess1 = ATR::DataSession->new;
    my $find1 = ATR::MicePE::Mouse->findByName($checks{name}, $sess1);
    $self->assert_str_not_equals($find1, $made);
    $self->assert_str_equals($find1->_getPE, $made->_getPE);
    $self->check_mouse($find1, tst => 'refound', %checks);

    # Drop it & re-find
    my $made_PE = "#".$made->_getPE;
    undef $made;
    undef $sess;
    undef $sess1;
    undef $find1;

    my $sess2 = ATR::DataSession->new;
    my $find2 = ATR::MicePE::Mouse->findByName($checks{name}, $sess2);
    $self->assert_str_not_equals($made_PE, "#".$find2->_getPE);

    # Check
    $self->check_mouse($find2, tst => 'adopted', %checks);

# DOD
    $checks{DOD} = '2005-02-18 07:28:15';
    $find2->setDateDeath( __gt2date($checks{DOD}) );
    $self->check_mouse($find2, tst => 'adopted_dead', %checks);
# XXX:UNTESTED undeading a mouse

    # Nuke the BioTables singleton: it caches Dataset dicts and
    # therefore looks a lot like an object leak
    undef $ATR::BioTables::singleton;
}

sub __gt2date {
    my @gt_text_date = @_;
    my @ret;
    foreach my $d (@gt_text_date) {
	push @ret, (defined $d ? ATR::Date->newGT($d) : undef);
    }
    return wantarray ? @ret : $ret[0];
}


# XXX: getFreeRemark / setFreeRemark checker XXX:MOVE belongs on MicePE
sub test_FCremarks { # XXX: Test deletion
    my $self = shift;
    my $sess = ATR::DataSession->new;

    my %remarks = ( abc => "defghi"x100,
		    numstr => "0.000",
		    multiput => "final value",
		  );
    my @many_remarks = qw(eeny meeny miny mo);

    my $made = ATR::MicePE::Mouse->createNamed(ATR::BioTablesTest::MOUSENAME_never_committed, $sess);

    $made->setFreeRemark("multiput", 1, "first value");
    $made->setFreeRemark("multiput", 1, "second value");
    $made->setFreeRemark("multiput", 1, "third value");
    foreach my $remarkType (keys %remarks) {
	$made->setFreeRemark($remarkType, 1, $remarks{$remarkType});
    }

    foreach my $remark (@many_remarks) {
	$made->setFreeRemark("many", 0, $remark);
    }

    # Drop it, reload and check
    my $made_PE = "#".$made->_getPE;
    my $sess2 = ATR::DataSession->new;
    undef $made;
    undef $sess;

    my $found = ATR::MicePE::Mouse->findByName(ATR::BioTablesTest::MOUSENAME_never_committed, $sess2);
    # if same, then not reloaded; see ATR::GTTest->test_symtable_leak
    $self->assert_str_not_equals($made_PE, "#".$found->_getPE);

    foreach my $remarkType (keys %remarks) {
	my $expect = $remarks{$remarkType};
	my $actual = $found->getFreeRemark($remarkType);
	$self->{annotate}->{type} = $remarkType;
	$self->assert_str_equals($expect, $actual);
	delete $self->{annotate}->{type};
    }

    $self->assert_dies( qr/Multiple values found for remark type/,
			sub { $found->getFreeRemark("many") });

    # XXX: Fetching multiple getFreeRemark values: check they're in time order?
    my @many_actual = $found->getFreeRemark("many");
    $self->assert_deep_equals([ sort @many_remarks ],
			      [ sort @many_actual  ]);

    $self->fail("XXX:UNTESTED check attributes have endDate set when first cancelled, not updated later... many of these");
    $self->fail("XXX:UNTESTED ensure writing blank (and/or undef) will just cancel the current value");
}


sub check_mouse {
    my ($self, $mouse, %checks) = @_;

    # Let the tester know what we're checking
    my @c = caller();
    my $caller = join ":", $c[1], $c[2], delete $checks{tst};
    $self->{annotate}->{caller} = $caller;

    # Check Mouse-ness
    $self->assert_str_equals('ATR::MicePE::Mouse', ref($mouse));

    # Check name
    if (exists $checks{name}) {
	my $mousename = delete $checks{name};
	$self->assert_str_equals($mousename, scalar $mouse->getMouseName);
	my @name = $mouse->getMouseName;
	$self->assert_str_equals($mousename, $name[0]);
	$self->assert_str_equals(1, scalar @name);
    }

    # Check genotypes
    if (exists $checks{genotypes}) {
	my @genos = delete $checks{genotypes};
	@genos = @{ $genos[0] } if ref($genos[0]); # allow one string, or list of strings
	my $want_genos = join ", ", sort @genos;

	@genos = ();
	foreach my $geno_info ($mouse->getGenotype) {
	    push @genos, join ":", $geno_info->{locus}->{short_name}, $geno_info->{name};
	}
	my $got_genos = join ", ", sort @genos;

	$self->assert_str_equals($want_genos, $got_genos);
    }

    # Check DOB, DOD
    if (exists $checks{DOB}) {
	my $expect = delete $checks{DOB};
	my $actual = $mouse->getDateBirth->getGT;
	$self->assert_str_equals($expect, $actual);
    }
    if (exists $checks{DOD}) {
	my $expect = delete $checks{DOD};
	my $actual = $mouse->getDateDeath;
	$actual = $actual->getGT if $actual;
	if (defined $expect) {
	    $self->assert_str_equals($expect, $actual); # won't accept null expect
	} else {
	    $self->assert_null($actual);
	}
    }

    # Check sex
    if (exists $checks{sex}) {
	my $expect = delete $checks{sex};
	my @actual = $mouse->getSex;
	my $actual = $mouse->getSex;
	$self->assert_str_equals(2, scalar @actual);
	$self->assert_str_equals($actual, $actual[0]);
	$self->assert_str_equals($expect, $actual[1]);
    }

    # Check we've done all the checks
    my @checks_remain = keys %checks;
    local $" = ", ";
    $self->fail("Checks not done: @checks_remain") if @checks_remain;

    # Tidy up
    delete $self->{annotate}->{caller};
}

#----------------------------------------------------------------------------


# Covers part of the scary & hairy "anti-tardissing" code in ATR::MicePE::PennedMouse
sub test_penned__daterangeSubtract { # XXX:UNTESTED my paper diagram covers all possible cases, this test doesn't
    my $self = shift;
    my $R = sub {[ __gt2date( @_ ) ]};

    my %range =
 (#                                                       #  march   1    1    2    2   2   april   1    1    2
  #                                                       # [-3-----90----5----0----5---9-][-3------0----5----0---------]
  A => $R->('2001-03-01 15:00:00','2001-04-01 15:00:00'), # --------------------------------
  a => $R->('2001-03-01 15:00:00', undef               ), # ---------------------------------------------->
  B => $R->('2001-04-03 15:00:00','2001-04-10 15:00:00'), #                                  --------
  C => $R->('2001-04-07 15:00:00', undef               ), #                                      --------->
  D => $R->('2001-03-20 00:00:00','2001-04-08 00:00:00'), #                    [------------------[
  E => $R->('2001-03-06 00:00:00','2001-03-25 00:00:00'), #      [------------------[

  EA1=>$R->('2001-03-01 15:00:00','2001-03-05 23:59:59'), # ----]
  EA2=>$R->('2001-03-25 00:00:00','2001-04-01 15:00:00'), #                         [-------
  Ea2=>$R->('2001-03-25 00:00:00', undef               ), #                         [--------------------->
  DA1=>$R->('2001-03-01 15:00:00','2001-03-19 23:59:59'), # ------------------]
  DB2=>$R->('2001-04-08 00:00:00','2001-04-10 15:00:00'), #                                       [--
  Ca1=>$R->('2001-03-01 15:00:00','2001-04-07 15:00:00'), # --------------------------------------
 );

    my %daterange; # cache for ATR::DateRange objects made, keys match %range

    my @expect;

    my $get_range = sub {
	my $key = shift;
	return $daterange{$key} ||= do {
	    my ($start, $end) = @{ $range{$key} };
	    my $id = ATR::BioTables->newDateRange_Id($start, $end);
	    ATR::DateRange->new_adopt($id);
	};
    };

    my $test = sub {
	my ($usedName, @origNames) = @_;
	$self->dumpnote(test_caller => [caller()]);

	# test plain date-pair ranges
	my @got = ATR::MicePE::PennedMouse::__daterangeSubtract($range{$usedName}, @range{@origNames});
	$self->dumpnote(got => \@got);
	$self->assert_deep_equals(\@expect, \@got);

	# test ATR::DateRange objects
	my @ranges;
	foreach my $key ($usedName, @origNames) {
	    push @ranges, $get_range->($key);
	}
	@got = ATR::MicePE::PennedMouse::__daterangeSubtract(@ranges);
	$self->dumpnote(test_caller => [caller()]);
	$self->assert_deep_equals(\@expect, \@got);
    };


# A minus E
    @expect = ([qw[split]], @range{qw{EA1 EA2}});
    $test->( E => qw(A) );

# a minus C
    @expect = ([qw[close]], @range{qw{Ca1}});
    $test->( C => qw(a) );

# (A,B) minus D
    @expect = ([qw[shrink_R shrink_L]], @range{qw{DA1 DB2}});
    $test->( D => qw(A B) );

# a minus E
    @expect = ([qw[split]],
	       @range{qw{EA1 Ea2}});
    $test->( E => qw(a) );

}


1;
