package ATR::MicePE::LitterGroup;

use strict;
use warnings;

use Carp;
use ATR::BioTables;
use ATR::Util;

use base 'ATR::MiceSubPE';


=head1 NAME

ATR::MicePE::LitterGroup - litter sub-entity object wrapper of GT:P:E

=head1 DESCRIPTION

Object represents a litter within a mating, so the litter methods
don't all need to specify the litter and the action to perform.

=cut


# $Id: LitterGroup.pm,v 1.21 2005/02/25 14:07:41 mca Exp $
our $VERSION = (qw$Revision: 1.21 $)[1];

use constant FCREM_LDOB => '_Date_LitterBirth';
use constant FCREM_LWEANDATE => '_Date_LitterWean';

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


=head2 construct($matingPair, $litterSubEntity)

Create wrapper object from existing litter.  To be called by the
containing ATR::MicePE::* object.

=cut

sub construct {
    my ($proto, $matingPair, $litterSubEntity) = @_;
    croak "Need 2 args: matingpair, subentity" if @_ != 3;
    croak "Need a MatingPair card, got $matingPair" if !UNIVERSAL::isa($matingPair, 'ATR::MicePE::MatingPair');
    croak "Need a litter sub-entity, got ".$litterSubEntity->getIdEntityContentsType if $litterSubEntity->getIdEntityContentsType != ATR::GTx::ENT_CONT_TYPE_ATR_LITTER;

    my $class = ref($proto) || $proto;
    my $self = bless { pair => $matingPair, litter => $litterSubEntity }, $class; # XXX: ref loop?!

    return $self;
}


=head2 (new)

There is no 'new' method.  Make a litter with
L<ATR::MicePE::MatingPair-E<gt>addLitter>.

=cut


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

=head1 OBJECT METHODS

=cut

sub _pair { $_[0]->{pair} }

sub _getSubPE { $_[0]->{litter} }

sub _flush	 { $_[0]->_pair->_flush }

sub getMating { $_[0]->{pair} }

sub debugId {
    my $self = shift;
    return "litter class $self" unless ref($self);
    # Hardened against objects evaporating (becoming undef) during global destruction...
    my $speid = eval { $self->_getSubPE->getId } || '[no data]';
    my $name = eval { "'".$self->getLitterName."'" } || "[unknown]";
    my $pair = eval { $self->_pair->debugId } || '[lost card ref]';
    return "mouse litter (name=$name, speid=$speid under $pair)";
}


=head2 getStatusInit()

Return string date for when the current litter sub-entity status was
made.

=cut

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

    # List dates
    my ($listref) = $gtx->getAttribute(-pe => $self->_getSubPE,
				       -attributeType => ATR::GTx::ATT_TYPE_SUBENT_STATUS,
				       -reason => GTx::REASON_ATTRIBUTE);
    my @dates = safemap { shift->getInitDate } @$listref;

    # Should be exactly one attribute, but just take the latest
    @dates = sort @dates;
    return $dates[-1];
}


=head2 getLitterName()

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

=cut

sub getLitterName {
    my $self = shift;
    return scalar $self->_getName(ATR::BioTables::NAMETYPE_MLITTER);
}

sub getLitterBirthDate { scalar $_[0]->getFreeRemark(FCREM_LDOB) }
sub setLitterBirthDate { my ($self, $date_string) = @_; $self->setFreeRemark(FCREM_LDOB, 1, $date_string) }

# XXX:DUP x2 two date getter during API change (text to ATR::Date); this one may error; also for mouse getDateBirth
sub getLitterDateBirth {
    my $self = shift;
    my $txt = $self->getLitterBirthDate;
    return undef if !defined $txt;
    my $dob = eval {ATR::Date->new_GuessDate($txt, "00:00:00") };
    my $prob = $@; # debugId uses eval too
    die "Invalid DOB '$txt' for ".$self->debugId.": $prob" if !$dob;
    return $dob;
}
sub setLitterDateBirth {
    my ($self, $date) = @_;
    $date = ATR::Date->new_GuessDate($date, '00:00:00') unless ref($date);
    $self->setLitterBirthDate($date->getGT);
}

# sub setWeanedDate { my ($self, $date_string) = @_; $self->setFreeRemark(FCREM_LWEANDATE, 1, $date_string) }
sub getWeanedDate_OLD { scalar $_[0]->getFreeRemark(FCREM_LWEANDATE) } # XXX: old bogus, remove from ECIA; fix or zap old data; provide $when in AnimalTransfer

# Return list of ATR::Date objects when some kind of weaning event may
# have happened.  Currently it's not clear what we want from this method...
sub getWeanedDates {
    my $self = shift;
    my @dates;
    {
	my $old = $self->getWeanedDate_OLD;
	$old = eval { ATR::Date->new_GuessDate($old, "23:59:59") }
	  if (defined $old && $old ne "");
	push @dates, $old if $old;
    }

    # Build list of pups stay on v-wean
    my %visits;
    my $vwean = ATR::MicePE::Weaning->findByPeId($self->getVirtualWeaningId);
    foreach my $v ($vwean->getAllMouseVisits) {
	my $mouseid = $v->getMouseId;
	next if !defined $mouseid; # cancelled, ignore
	push @{ $visits{$mouseid} }, $v;
    }

    # For each litter mouse, find out if/when it left
    foreach my $attr ($self->_getAttr_Pups) {
	my $mouseid = $attr->getValue;
	if (!$visits{$mouseid}) {
	    # Mouse didn't make it onto the v-wean card
	    warn "Note: mouse id $mouseid was never on v-wean card for ".$self->debugId;
	} else {
	    foreach my $v (@{ $visits{$mouseid} }) {
		my $leftWhen = $v->getEndDate;
		push @dates, $leftWhen if defined $leftWhen; # XXX: Mice may leave more than once, this will skew the numbers
	    }
	}
    }

    return @dates;
}

=head2 setPupCount($count)

Add pups to make the litter up to $count.  Refuses to decrease the
count.

=cut

sub setPupCount {
    my ($self, $count) = @_;

    my $oldCount = $self->getPupCount;
    croak "This litter has $oldCount mice already - currently, changing the pup count can only add to the litter"
      if $oldCount >= $count; # XXX:NYI We could cancel/see that mice were cancelled, and we could extend the litter

    $self->_addPups($count - $oldCount);
    $self->_flush;
}


=head2 getPups()

Return list of L<ATR::MicePE::Mouse> objects in no particular order.

=cut

sub getPups {
    my $self = shift;
    my @mice = ( map { ATR::MicePE::Mouse->findByAttribute($_) }
		 $self->_getAttr_Pups );

    return @mice;
}


=head2 getPupCount()

Return the number of individual mice actually created in the database

XXX: ignores status, so including cancelled mice...  may need to change to allow user to deal with mistakes

=cut

sub getPupCount { # was haveCreatedPups
    my $self = shift;
    my @attr = $self->_getAttr_Pups;
    return scalar @attr;
}

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

    my ($listref) = $gtx->getAttribute(-pe => $self->_getSubPE,
				       -attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
				       -reason => GTx::REASON_CONTAINS);
    return @$listref;
}


=head2 _addPups($number)

Create (some) individual mouse entities, link them to the litter and
v-wean card.  Returns list of L<ATR::MicePE::Mouse> objects.

=over 4

=item name

Based on the litter name plus an alphabetic suffix (a to z, then aa to
az, then ba...).  Existing (already used) names are skipped over.

=item birthDate

Set from the C<litterBirthDate>, if that has a value.

=back

Errors propagate from database; also an error if the mice have been
created already, or we don't know how many there should be.

=cut

sub _addPups {
    my ($self, $createNum) = @_;

    my @mice;
    my $nextSuffix = 'a';

    my $litter_dob = $self->getLitterDateBirth;
    die "Cannot add $createNum mice to litter ".$self->getLitterName." - litter's date of birth is not set"
      unless $litter_dob;

    my $vwean = ATR::MicePE::Weaning->findByPeId($self->getVirtualWeaningId);

    while (@mice < $createNum) {
	my $mousename;

	# Find next free name
	do {
	    $nextSuffix ++ if defined $mousename; # bump the suffix if we're going round again
	    $mousename = $self->getLitterName.$nextSuffix;
	} while (defined ATR::BioTables->getName_idName($mousename, ATR::BioTables::NAMETYPE_MOUSE));

	# Create
	my $mouse = ATR::MicePE::Mouse->createNamed($mousename);
	push @mice, $mouse;

	# Set data
	$mouse->setDateBirth($litter_dob);

	$self->addPup($mouse); # XXX: addPup should probably do $vwean->addMouse, but the v-wean uses addPup with before doing its own addMouse...
	$vwean->addMouse(-mouse => $mouse,
			 -since => $litter_dob);
    }

    return @mice;
}


=head2 addPup($mouse)

Add the L<ATR::MicePE::Mouse> to this LitterGroup.

=cut

sub addPup {
    my ($self, $mouse) = @_;

    my $gtx = $self->getGTx;

    # Link mouse to littergroup
    $gtx->addAttribute(-pe => $self->_getSubPE,
		       -attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
		       -value => $mouse->getPeID,
		       -reason => GTx::REASON_CONTAINS,
		       -idRole => $self->getIdRole,
		       -sessionId => $self->getSessionId);

    # XXX:MULTIFLUSH Many flushes.  May be unnecessary, but protects against
    # errors in later mice.
    $self->_flush;
}


#----------------------------------------------------------------------------
#
# Virtual Weaning Card (for containing pups before they're weaned)

=head2 getVirtualWeaningId

Returns PEid of this litter's virtual weaning card.

Errors from database or if the v-wean card has not yet been made.

It doesn't adopt for you because adopting is nice and easy, and you
may prefer to defer it until your existing card has been safely put
away...

 my $peid = $self->getVirtualWeaningId;
 return ATR::MicePE::Weaning->findByPeId($peid);

=cut

sub getVirtualWeaningId {
    my $self = shift;
    my ($attr, $madeFlag) = $self->_getAttr_VirtWean;
    return $attr->getValue;
}


# Returns ($attribute, $madeFlag)
sub _getAttr_VirtWean {
    my $self = shift;
    my $gtx = $self->getGTx;

    my ($listref) = $gtx->getAttribute(-pe => $self->_getSubPE,
				       -attributeType => ATR::GTx::ATT_TYPE_ATR_WEANING,
				       -reason => GTx::REASON_ATTRIBUTE);

    if (@$listref == 0) {
	my $attr = $self->_makeAttr_VirtWean;
	return ($attr, 1);
# XXX: when they all exist...	die "Could not find virtual weaning card for litter ".$self->debugId;
    } elsif (@$listref > 1) {
	die "Found multiple virtual weaning cards (@$listref) for litter ".
	  $self->debugId.", cannot safely pick one";
    }

    return ($listref->[0], 0);
}


# Make a virtual-weaning card; should only be called from _getAttr_VirtWean
# Will die if there are mice with no DOB: a date is needed for the
# PennedSince attribute.
sub _makeAttr_VirtWean {
    my $self = shift;
    my $litterName = $self->getLitterName;

    # Get info about mice in litter, before we start
    my @miceInfo;
    foreach my $mouse ($self->getPups) {
	my ($name, $dob, $dod) = ($mouse->getMouseName,
				  $mouse->getDateBirth,
				  undef); # XXX: $mouse->getDeathDate);
	die "Cannot create $litterName virtual weaning card: Mouse $name in litter $litterName has no valid DOB"
	  unless $dob;
	push @miceInfo, [ $mouse, $dob, $dod ];
    }

    # XXX:LOCK check it doesn't exist already

    # Create v-wean card
    my $card = ATR::MicePE::Weaning->createBlank();
    $card->setIntendedSex('U');
    $card->setIntendedLitter($litterName, 1);

    # Copy licence info over
    foreach my $licfield (qw(PPL PIL 19b User)) {
	my $getter = "getLicence$licfield";
	my $setter = "setLicence$licfield";
	my $value = $self->_pair->$getter;
	$card->$setter($value);
    }

    # Add to card any existing litter members
    foreach my $data (@miceInfo) {
	my ($mouse, $start, $end) = @$data;
	$card->addMouse(-mouse => $mouse,
			-since => $start, # DOB
			-until => $end, # DOD or undef
		       );
    }

    # Create link attribute
    my $gtx = $self->getGTx;
    my $attr = $gtx->addAttribute(-pe => $self->_getSubPE,
				  -attributeType => ATR::GTx::ATT_TYPE_ATR_WEANING,
				  -reason => GTx::REASON_ATTRIBUTE,
				  -value => $card->getPeID,
				  -idRole => $self->getIdRole,
				  -sessionId => $self->getSessionId);
    $self->_flush;
    return $attr;
}


1;
