package ATR::MicePE::MatingPair;

use strict;
use warnings;

# Base class provides class methods to get the GTx object and store
# non-mouse info that we will need but aren't interested in.
use base 'ATR::MicePE::Card';

use Carp;
use ATR::BioTables;
use ATR::MicePE::Mouse;
use ATR::Util;

=head1 NAME

ATR::MicePE::MatingPair - "AniTrack mouse mating pair" object wrapper
of GT:P:E

=head1 CLASS METHODS

=cut


# $Id: MatingPair.pm,v 1.23 2005/05/23 16:04:56 mca Exp $

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


=head2 idEntityType()

Method for the benefit of superclass' methods.

=cut

sub idEntityType { return ATR::GTx::ENT_TYPE_ATR_MOUSE_MATING }


=head2 getNextName($colony)

Pick a name for the next mating in this colony.  Note that the name is
not claimed, so we may yet lose a race to get an ATR_NAME.ID_NAME
value.

Returns name of the form C<$colony$serial_num> .

=cut

sub getNextName {
    my ($self, $colony) = @_;
    return ATR::BioTables->getName_NextSerial(ATR::BioTables::NAMETYPE_MMATING, $colony);
}


=head2 createBlank($colony, $cardname)

Create a new Mouse Mating Pair PE with

=over 4

=item state = Created

=item colony = $colony XXX: no bio colony yet

=item name = $cardname

=item parents = 0

=item barcode will be assigned

=back

This happens immediately (is flushed to GT and bio tables) but the
caller must commit or rollback.

Errors propagate.

Error generated if name is already in use.  XXX: name re-use issue again

=cut

sub createBlank {
    my ($proto, $colony, $cardname) = @_;
    croak "Need 2 args: colony, mousename" unless @_ == 3 && defined $cardname;

# Set names: one-time operation

    # Allocate card name
    $cardname =~ s/^\s*|\s*$//g; # XXX: Canonicalisation rules should be defined; link to UpdateEntry(-finish) code
    my $id_name = ATR::BioTables->newName_idName($cardname, ATR::BioTables::NAMETYPE_MMATING);
    if (!defined $id_name) {
	# XXX:USRTHROW
	die "A mating named '$cardname' exists already.  Please use another.\n";
    }

    # Get hold of colony name by one means or another
    my $id_colony;
    my $tries = 0;
    while (!defined $id_colony) {
	$id_colony ||= ATR::BioTables->getName_idName($colony, ATR::BioTables::NAMETYPE_MCOLONY);
	$id_colony ||= ATR::BioTables->newName_idName($colony, ATR::BioTables::NAMETYPE_MCOLONY);
	# Slightly icky avoidance of possible race
	sleep 1 unless defined $id_colony;
	$tries ++;
	die "Failed to get ID for colony name '$colony' after $tries attempts" if $tries > 5;
    }

    # Make entity
    my $class = ref($proto) || $proto;
    my $self = bless {}, $class;
    my $gtx = $self->getGTx;
    $self->{_PE} = $gtx->createPhysicalEntity(-entityType => idEntityType);

    # Add mating group
    $gtx->createSubEntity(-pe => $self->_getPE,
			  -idEntityContentsType => ATR::GTx::ENT_CONT_TYPE_ATR_MATING);

    # Set names
    foreach my $content ($id_name, $id_colony) {
	$gtx->addInfo(-pe => $self->_getPE,
		      -idContentType => ATR::GTx::CONT_TYPE_ATR_NAME,
		      -idContent => $content,
		      -reason => ATR::GTx::REASON_IDENTIFIED_BY);
    }

    # Set barcode (intId)
    $self->_addBarcode;

    $self->_flush;

    return $self;
}


=head2 findByName($card_name)

Class method: find a "mouse mating pair card" by its name.

Returns one new object, or undef if not found.

Errors propagate, also errors if multiple matches found.

=cut

sub findByName {
    my ($proto, $cardname) = @_;
    croak "Need 1 arg: cardname" unless @_ == 2 && defined $cardname;

    return $proto->_findByName($cardname, ATR::BioTables::NAMETYPE_MMATING);
}


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

=head1 OBJECT METHODS

=cut

sub debugId {
    my $self = shift;
    return "mouse card class $self" unless ref($self);
    # Hardened against objects evaporating (becoming undef) during global destruction...
    my $peid = eval { $self->getPeID } || '[lost card ref]';
    my $barcode = eval { join "", $self->getBarcode } || "[unknown]";
    my $name = eval { "'".$self->getMatingName."'" } || "[unknown]";
    return "mouse mating pair card (name=$name, barcode=$barcode, peid=$peid)"; # XXX: ENTITY_TYPE.DESCRIPTION
}

=head2 getColonyName()

Returns names of type C<ID_NAME_TYPE = COLONY> for this item.  There
should always be exactly one such name.  This method will deal with
any number but B<see SUPER::_getName for return details>.

=head2 getMatingName()

Returns names of type C<ID_NAME_TYPE = MATING> for this item.  There
should always be exactly one such name.  This method will deal with
any number but B<see SUPER::_getName for return details>.

=cut

sub getColonyName { return scalar $_[0]->_getName(ATR::BioTables::NAMETYPE_MCOLONY) }
sub getMatingName { return scalar $_[0]->_getName(ATR::BioTables::NAMETYPE_MMATING) }

sub getCardName { return "Mating ".$_[0]->getMatingName }

#----------------------------------------------------------------------------
#
# Deal with the Pair

=head2 addParent(%args)

Accepts

 -mouse => L<ATR::MicePE::Mouse>   (required)
 -since => $start_date             (default = undef, i.e. mouse absent from its mating)
 -until => $end_date               (default = undef, i.e. open-ended range)
 -slot => 'M' or 'F'               (required: which parent this mouse shall be)

XXX: Used to accept mouse PeID, may be better choice with C<make_args> setup

Adds the mouse to both the (one) Mating Group on the card and a new
Penned Animal to represent the visit.
XXX: Need new methods: control the addition date, presence of mouse, stay duration...

=cut

sub addParent {
    my $self = shift;
    my %args = make_args(\@_,
			 [
			  -mouse => undef,
			  -slot  => undef, # require: 'M' or 'F'
			  -since => undef, # default: absent
			  -until => undef, # default: (if present) present indefinitely
			  # -remark => undef, # old code supported this, nothing used it
			 ]);

    croak "Need a -mouse object" unless $args{-mouse} && $args{-mouse}->can('getMouseName');

 # XXX: Other parenting checks: feasibility, availability ...
    croak "Need -slot => (M|F)" unless $args{-slot} && $args{-slot} =~ /^(male|female|[mf])$/i;
    $args{-slot} = uc(substr($args{-slot}, 0, 1));
    my $mouseSex = $args{-mouse}->getSex; # M, F, N...
    my $mouseName = $args{-mouse}->getMouseName;
    warn ">>> Mouse $mouseName ($mouseSex) does not match card slot ($args{-slot})"
      unless $mouseSex eq $args{-slot};

    foreach my $key (qw(-since -until)) {
	croak "Need $key to be undef or ATR::Date, got $args{$key}"
	  if defined $args{$key} && !UNIVERSAL::isa($args{$key}, 'ATR::Date');
    }

    my $mategroup = $self->_getMatingGroup;

    my @pair = $self->_getAttr_Parents; # XXX:LOCK Race here unless we lock - could have a three-mouse pair
    croak "Mating pair already contains two mice" if @pair >= 2;

    my $gtx = $self->getGTx;
    $gtx->addAttribute(-pe => $mategroup,
		       -attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
		       -value => $args{-mouse}->getPeID,
#		       -remark => $args{-remark},
		       -reason => GTx::REASON_CONTAINS,
		       -idRole => $self->getIdRole,
		       -sessionId => $self->getSessionId);

    if (defined $args{-since}) {
	my ($penned, $pennedSubEnt) = ATR::MicePE::PennedMouse
	  ->create($self, $args{-mouse}, $args{-since}, $args{-until});
warn "$mouseName:$mouseSex on card since ".$args{-since}->getGT;
    }
else { warn "No presence-start on $mouseName" }

    $self->_flush;
}


=head2 getDateSetup()

Return L<ATR::Date> of the first time a mouse was present (by
PennedAnimal sub-entity), or undef if no mice have been on the card.

=cut

sub getDateSetup {
    my $self = shift;
    my $gtx = $self->getGTx;

    my @penned = $self->getAllMouseVisits; # any/all remaining current
    return undef if !@penned;

    # Find earliest mouse arrival  XXX: check it's for a mouse in the mating? what if it isn't?
    my $setupDate;
    foreach my $penned (@penned) {
	my ($start) = $penned->getDateRange;
	$setupDate = $start if !defined $setupDate || $setupDate->cmp($start) > 0;
    }
    return $setupDate;
}


# returns one subentity object
sub _getMatingGroup {
    my $self = shift;
    my $gtx = $self->getGTx;
    my ($listref) = $gtx->getSubEntity(-pe => $self->_getPE,
				       -idEntityContentsType => ATR::GTx::ENT_CONT_TYPE_ATR_MATING);

    # XXX:SHAPE check would pick these up
    croak "Expected one mating group in ".$self->debugId.", found ".@$listref  if @$listref != 1;

    return $listref->[0];
}


=head2 getParents()

Should return 0, 1 or 2 adopted mouse objects.  When two, we will
attempt to sort the male first, female second.

Errors from database, or if we have more than one mating group, or
more than two mice.

=cut

sub getParents {
    my $self = shift;
    my @pair = ( safemap { ATR::MicePE::Mouse->findByAttribute(shift) }
		 $self->_getAttr_Parents );

    # If we know we have the female before the male, swap
    my @sex = safemap { scalar shift->getSex } @pair;
    if ((defined $sex[0] && $sex[0] eq 'F') || (defined $sex[1] && $sex[1] eq 'M')) {
	($pair[1], $pair[0]) = @pair;
    }

    return @pair;
}

# return list of current parent attributes
sub _getAttr_Parents {
    my $self = shift;
    my $gtx = $self->getGTx;

    my ($listref) = $gtx->getAttribute(-pe => $self->_getMatingGroup,
				       -attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
				       -reason => GTx::REASON_CONTAINS);
    croak "More than two parents found in mating pair ".$self->debugId.", cannot safely pick two"
      if @$listref > 2; # XXX:SHAPE XXX:LOCK should catch & prevent this
    return @$listref;
}


#----------------------------------------------------------------------------
#
# Deal with litters

=head2 getNextLitterName(@skipNames)

Returns next unallocated name, considering all of C<@skipNames> (if
any) to be already in use.

=cut

sub getNextLitterName {
    my ($self, @skipNames) = @_;
    return ATR::BioTables->
      getName_NextSerial(ATR::BioTables::NAMETYPE_MLITTER, $self->getMatingName.".", \@skipNames);
}


=head2 addLitter($litter_name)

Create a(nother) new litter subentity with

=over 4

=item state = Created

=item litter name = as given

Note that it will allow anything in here, but these names are the
whole litter name not confined within the mating card context.
i.e. GUI should be careful to avoid allowing plain numbers here.

=item group size = not specified

=item linked entities = none

=back

Returns an L<ATR::MicePE::LitterGroup> as from C<getLitter>.

Errors from database, including name conflicts.

=cut

sub addLitter {
    my ($self, $name_litter) = @_;
    my $gtx = $self->getGTx;

    my $idname_litter = ATR::BioTables->newName_idName($name_litter, ATR::BioTables::NAMETYPE_MLITTER);
    if (!defined $idname_litter) {
	# Shouldn't happen(tm)
	die "Litter name '$name_litter' exists already, cannot create a litter with this name in ".$self->debugId;
    }

    # Add litter group
    my $litgrp = $gtx->createSubEntity(-pe => $self->_getPE,
				       -idEntityContentsType => ATR::GTx::ENT_CONT_TYPE_ATR_LITTER);

    # Set name
    $gtx->addInfo(-pe => $litgrp,
		  -idContentType => ATR::GTx::CONT_TYPE_ATR_NAME,
		  -idContent => $idname_litter,
		  -reason => ATR::GTx::REASON_IDENTIFIED_BY);

    # Set state (biotable state)
    $gtx->addAttribute(-pe => $litgrp,
		       -attributeType => ATR::GTx::ATT_TYPE_SUBENT_STATUS,
		       -value => ATR::BioTables::SUBSTATUS_MLG_CRE,
		       -reason => GTx::REASON_ATTRIBUTE,
		       -idRole => $self->getIdRole,
		       -sessionId => $self->getSessionId);

    $self->_flush;

    return ATR::MicePE::LitterGroup->construct($self, $litgrp);
}


# returns subentity objects (or count of them), zero or more, no particular order
sub _getLitterGroups {
    my $self = shift;
    my $gtx = $self->getGTx;
    my ($listref) = $gtx->getSubEntity(-pe => $self->_getPE,
				       -idEntityContentsType => ATR::GTx::ENT_CONT_TYPE_ATR_LITTER);

    return @$listref;
}


=head2 getLitterCount()

Returns number of litters currently in this mating pair.

=cut

sub getLitterCount { scalar $_[0]->_getLitterGroups }


=head2 getLitter( -key =E<gt> $value )

Will accept keys

=over 4

=item -idx

C<$value> is an index from 0, litters sorted by the initdate on their
current status, then by string length, then alphabetically [arbitrary
but sensible-sounding rule]. B<nb.> GT versions before 2004-12 set
attribute initdate to program compile time, not attribute creation
time - hence the name sort for same-time litters.

ag4 mail 2004-11-17: want litters on card sorted by "time order".

Note that this means the index needed for a given litter is not
guaranteed stable.  Get an object and hang onto it until you're
finished, or take a different index.

(There are few index schemes guaranteed to be stable...  sorted by
name, sorted by primary key...  all could have another one pushed in
at the start.)

=item -subPeId

C<$value> should be the ID of a litter group 'Content'.

=item -name [not implemented]

C<$value> should be a litter name in this mating pair.

=back

Returns an L<ATR::MicePE::LitterGroup> object, or an error if the key
or C<$value> did not specify a match.  Doesn't return the same object
when called a second time.

Note that this LitterGroup has a reference to its the MatingPair
object from which it originated.

=cut

sub getLitter {
    my ($self, $key, $value) = @_;
    my $gtx = $self->getGTx;

    my @litters = $self->_getLitterGroups;

    # This one is easy, quick return
    if ($key eq '-subPeId') {
	my @found = safegrep { $_[0]->getId == $value } @litters;
	die "LitterGroup id=$value not found in ".$self->debugId if !@found;
	# there will be one, selected by primary key
	return ATR::MicePE::LitterGroup->construct($self, $found[0]);
    }

    # Making the LitterGroup won't take long, gives sane access to properties
    my @litgrp  = safemap { ATR::MicePE::LitterGroup->construct($self, shift) } @litters;

    # Sort as specified in POD
    my %times; # key = stringified litter subent; value = "yyyy-mm-dd hh:mm:ss", which we can sort
    my %names; # key = stringified litter subent; value = littername
    foreach my $l (@litgrp) {
	$times{$l} = $l->getStatusInit;
	$names{$l} = $l->getLitterName;
    }
    @litgrp = sort {( $times{$a} cmp $times{$b} ||
		      length($names{$a}) <=> length($names{$b}) ||
		      $names{$a} cmp $names{$b} )} @litgrp;

    my $chosen;
    if ($key eq '-idx') {
	$chosen = $litgrp[$value];

    } else {
	croak "getLitter with key '$key' was not understood";
    }

    return $chosen;
}

1;
