package ATR::MicePE::Weaning;

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::MicePE::PennedMouse;
use ATR::Util;

=head1 NAME

ATR::MicePE::Weaning - "AniTrack mouse weaning card" object wrapper of
GT:P:E

=head1 CLASS METHODS

=cut


use constant FCREM_INTSEX => "_SEX_intended";


# $Id: Weaning.pm,v 1.30 2005/02/28 01:18:39 mca Exp $
our $VERSION = (qw$Revision: 1.30 $)[1];

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

=head2 idEntityType()

Method for the benefit of superclass' methods.

=cut

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

# findByName: the name is calculated and distinctly not atomic, so we have no search method yet


=head2 createBlank()

Create a new Mouse Weaning Card PE with

=over 4

=item state = Created

=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.

=cut

sub createBlank {
    my ($proto) = @_;
    die "Class method needs 0 args" unless @_ == 1;

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

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

    $self->_flush;

    return $self;
}


=head2 listForLitter($litterName)

Return list of [$type, $peId] pairs for weaning cards containing specified litter.

Currently $type can be
 1 = weaning card intended to contain that litter
 3 = virtual weaning card for the litter

Note that this can work as a bitfield if/when I extend it to
find mice of the litter which happen to be on the card.  XXX: missing feature in various places

...or another field, for the count of the relevant mice on the card...?

=cut

sub listForLitter {
    my ($pkg, $litterName) = @_;
    my $id_littername = ATR::BioTables->getName_idName($litterName, ATR::BioTables::NAMETYPE_MLITTER);
    return () if !$id_littername; # litter name not found

    # Search for (v-)weaning cards intended to hold litter
    my @answer;
    foreach my $reason (GTx::REASON_CONTAINS, # v-wean
			ATR::GTx::REASON_DERIVED_FROM, # plain wean
		       ) {
	my @id_pair = ATR::GTx->listEntitiesWith
	  (-peType => ATR::MicePE::Weaning->idEntityType,
	   -infoReason => $reason,
	   -infoType => ATR::GTx::CONT_TYPE_ATR_NAME,
	   -value => $id_littername,
	  );
	my @peid = map { $_->[0] } @id_pair; # chuck the subentIds
	push @answer, map {[ ($reason == GTx::REASON_CONTAINS) ? 3 : 1, $_ ]} @peid;
    }
    return @answer;
}

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

=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 ($litterName, $virtual) = eval {( $self->getIntendedLitter )};
    ($litterName, $virtual) = ('[unknown]', '?') if !defined $litterName;
    # Don't use getCardName, it has to adopt litters and get their names
    return "mouse weaning card (intLitter=$litterName, virtual=$virtual, barcode=$barcode, peid=$peid)"; # XXX: ENTITY_TYPE.DESCRIPTION
}


=head2 getIntendedSex

Returns C<M>, C<F> or C<U> for male, female, unsexed.

In list context, also returns the long name matching the letter.

=cut

sub getIntendedSex {
    my $self = shift;
    my $sex = scalar $self->getFreeRemark(FCREM_INTSEX);
    return(wantarray
	   ? ($sex, {qw{M Male F Female U Unsexed}}->{$sex} || undef)
	   : $sex);
}

=head2 setIntendedSex($sex)

Accepts anything L<getIntendedSex> can return, as a letter or the string.

=cut

sub setIntendedSex {
    my ($self, $sex) = @_;
    $sex = uc(substr($sex,0,1)) if $sex =~ /^(male|female|unsexed|[mfu])$/i;
    die "Intended sex should be (M)ale, (F)emale or (U)nsexed" unless $sex =~ /^[MFU]$/;
    $self->setFreeRemark(FCREM_INTSEX, 1, $sex);
}


=head2 getIntendedLitter

Returns littername in scalar context or (littername, is_virtual) in
list context.  Returns an empty list if the intended litter has not
been set.

=cut

sub getIntendedLitter {
    my $self = shift;
    my ($id_name, $virtual) = $self->_getIntendedLitterId;
    return () if !defined $id_name;
    my $litterName = ATR::BioTables->getName_forId($id_name);
    return wantarray ? ($litterName, $virtual) : $litterName;
}

sub setIntendedLitter {
    my ($self, $litterName, $virtual) = @_;
    my $id_name = ATR::BioTables->getName_idName($litterName, ATR::BioTables::NAMETYPE_MLITTER);
# XXX:USRTHROW x2
    die "Can't assign intended litter '$litterName' to card ".$self->debugId.", litter does not exist"
      unless defined $id_name;
    die "Can't assign multiple intended litters to one weaning card, please make another"
      if $self->_getIntendedLitterId;
# XXX:LOCK check no existing info
    my $gtx = $self->getGTx;
    $gtx->addInfo(-pe => $self->_getPE,
		  -idContentType => ATR::GTx::CONT_TYPE_ATR_NAME,
		  -reason => ($virtual
			      ? GTx::REASON_CONTAINS
			      : ATR::GTx::REASON_DERIVED_FROM),
		  -idContent => $id_name);
    $self->_flush;
}

# Returns ($id_name, $virtualFlag), or empty list if no info set
sub _getIntendedLitterId {
    my $self = shift;
    my $gtx = $self->getGTx;

    my ($contains, $derived_from) = # two listrefs
      safemap { $gtx->getInfo(-pe => $self->_getPE,
			      -idContentType => ATR::GTx::CONT_TYPE_ATR_NAME,
			      -reason => (shift))
	    } (GTx::REASON_CONTAINS, ATR::GTx::REASON_DERIVED_FROM);

    my ($c_num, $d_num) = (scalar @$contains, scalar @$derived_from);
    if ($c_num + $d_num == 0) {
	return ();
    } elsif ($c_num + $d_num > 1) {
	die "Found multiple intended litter info (contains=$c_num, derived=$d_num), cannot safely pick one";
    } else {
	# There can be only one item in the two lists - the way we like it
	my $id_name = (@$contains, @$derived_from)[0]->getIdContent;
	return ($id_name, $c_num);
    }
}


=head2 getCardName

Looks up intended and actual litters for card, build a name.

Currently involves adopting and forgetting the mice on the card.

=cut

sub getCardName { # XXX: gives no hints about card sex or other cards for the same litter
    my $self = shift;
    my @mice = $self->getCurrentMice;
    my %litters;
    foreach my $mouse (@mice) {
	my $name = $mouse->getMouse->getMouseName; # XXX:WASTEDADOPT Can we get the litter names without adopting the mice?
	$name=~s/[a-z]+$//; # XXX: Need litter lookup!
	$litters{$name} ++;
    }

    my $baseName;
    my ($litterName, $virtual) = $self->getIntendedLitter;
    if (!defined $litterName) {
	$baseName = "[unspecified]";
    } else {
	$baseName = $litterName;
	$baseName .= " (unweaned)" if $virtual;
	delete $litters{$litterName};
    }

    my @litters = sort { $litters{$a} <=> $litters{$b} || $a cmp $b } keys %litters;
    my $extra = join ", ", @litters;
    return @litters ? "$baseName + $extra" : $baseName;
}


=head2 getLitterGroup4Virtual

Return the L<ATR::MicePE::LitterGroup> which points to this card as
its virtual weaning card, or undef if there is none.

Value will be cached if defined.  It's supposed to be a permanent single value, XXX: but this can't be enforced by constraint.

=cut

sub getLitterGroup4Virtual { # XXX:DUP very similar to Mouse->getLitterGroup
    my $self = shift;
    return $self->{_littergroup} if defined $self->{_littergroup};

    my ($litterName, $virtual) = $self->getIntendedLitter;
    return undef if !$virtual;

    my $gtx = $self->getGTx;
    my @id_pairs = $gtx->listEntitiesWith
      (-peType => ATR::GTx::ENT_TYPE_ATR_MOUSE_MATING,
       -subPeType => ATR::GTx::ENT_CONT_TYPE_ATR_LITTER,
       -attributeType => ATR::GTx::ATT_TYPE_ATR_WEANING,
       -value => $self->getPeID);

    # XXX: Deal with multiple and/or cancelled LitterGroups found
    return undef if !@id_pairs; # XXX: none found, though there should be
    die $self->debugId." appears to be in multiple litters" if @id_pairs > 1;

    my ($pe, $subpe) = @{ $id_pairs[0] };
    my $mating = ATR::MicePE::MatingPair->findByPeId($pe); # XXX:MULTIADOPT we can easily have several of these adopted for various mice in a litter, and they will get out of sync!  Maybe better not to cache?  But then the problem is hidden until the API user steps on it
    my $litterGroup = $mating->getLitter(-subPeId => $subpe);

    return $self->{_littergroup} = $litterGroup;
}


#----------------------------------------------------------------------------
#
# The contained mice


=head2 addMouse(%args)

Will accept either of

 -mouse => L<ATR::MicePE::Mouse>
 -name  => $mousename

but not both; if C<-name> is given then a mouse may be created if
allowed below.  C<%args> also accepts any or none of

 -since => $start_date     (default = now for wean card,
                                      mouse DOB for v-wean) XXX: describe and check complications here
 -until => $end_date       (default = undef, i.e. open-ended range)
 -create => $allow_create  (default = 0)

An open-ended range means the mouse is still contained.

Dates may be GT format text or an L<ATR::Date> object.

If a mouse name is given and that mouse is not found, this will be an
error unless $allow_create.  In this case various checks are made.
XXX: Specify checks for creating mouse & result of disagreements!

When a mouse is created we will set the DOB to $start_date.  If this
is a v-wean card, we also add the mouse to the card's LitterGroup.

Returns the new L<ATR::MicePE::PennedMouse> object.

XXX: Add by peid? Include remark?  Require start_date?

XXX: Creating mice belongs in Mouse; adding to litter (which is usually necessary) belongs in LitterGroup

=cut

sub addMouse { # XXX: Far too much going on in here!
    my $self = shift;
    my %args = make_args(\@_,
			 [
			  -mouse => undef,
			  -name => undef,
			  -since => undef, # calculate default later
			  -until => undef,
			  -create => 0,
			 ]);

    if (defined $args{-mouse} && defined $args{-name}) {
	die "Confused to be given both a mouse and a mouse name";
    } elsif ($args{-mouse}) {
	die "mouse parameter should be ATR::MicePE::Mouse"
	  unless UNIVERSAL::isa($args{-mouse}, 'ATR::MicePE::Mouse');
	$args{-name} = $args{-mouse}->getMouseName;
    } else {
	$args{-mouse} = ATR::MicePE::Mouse->findByName($args{-name});
    }

    my ($cardLitterName, $virtualWean) = $self->getIntendedLitter;

    # Provide default value for -since before making mouse, in case we error
    if (!defined $args{-since}) {
	if ($virtualWean && $args{-mouse}) {
	    # V-wean card - default is mouse DOB
	    $args{-since} = $args{-mouse}->getDateBirth; # ATR::Date
	}

	if (!defined $args{-since} && $virtualWean) {
	    # V-wean card and (no mouse, or mouse with no DOB) - default is litter DOB
	    my $litterGroup = $self->getLitterGroup4Virtual;
	    warn "Cannot find litter group for ".$self->debugId."\n" if !$litterGroup;
	    $args{-since} = $litterGroup->getLitterDateBirth if $litterGroup;
	    warn "Litter ".$litterGroup->debugId." has no DOB" if !$args{-since} && $litterGroup;
	    die "Failed to find '-since' date, cannot add mouse to card"
	      if !$args{-since};

	} else {
	    # Normal weaning card - default 'now'
	    $args{-since} = $self->getGTx->makeDate();
	}
    }
    # We now have a -since value...


    # XXX: ask LitterGroup for name substring match?  This is business logic that may belong elsewhere.
    my $litterNameMatch = (substr($args{-name}, 0, length($cardLitterName)) eq $cardLitterName &&
			   substr($args{-name},    length($cardLitterName)) =~ /^[a-z]+$/);

    # Make the mouse, if we have none
    if (!$args{-mouse}) {
	die "Mouse named '$args{-name}' not found, cannot add to ".$self->debugId
	  unless $args{-create};
	# Need to make the mouse before we add it
	#  - check the mouse fits getIntendedLitter

	$args{-mouse} = ATR::MicePE::Mouse->createNamed($args{-name});
	$args{-mouse}->setDateBirth($args{-since});

	my $litterGroup;
	$litterGroup = $self->getLitterGroup4Virtual if $virtualWean;
	if ($virtualWean && !$litterGroup) {
	    warn ">>> Cannot find litter for this virtual weaning card!  Creating orphaned mouse named '$args{-name}'\n";
	} elsif ($virtualWean) {
# XXX: warnings: is name next in litter sequence, are we near the DOB
	    warn ">>> Creating new mouse named '$args{-name}' and adding to litter $cardLitterName\n";
	    warn ">>> Mouse name '$args{-name}' does not match card litter '$cardLitterName'\n"
	      if !$litterNameMatch;
	    $litterGroup->addPup($args{-mouse});
	} else {
	    warn ">>> This is not a virtual weaning card!  Creating orphaned mouse named '$args{-name}'\n";
	}
    }


    # Re-check mouse's litter membership, now we have all available data
    my $mname = $args{-mouse}->getMouseName;
    my $mouseLitterGroup = $args{-mouse}->getLitterGroup;
    my $mouseLitterName = undef;
    $mouseLitterName = $mouseLitterGroup->getLitterName if $mouseLitterGroup;
    if (defined $cardLitterName && defined $mouseLitterName) {
	warn ">>> Mouse '$mname' of litter '$mouseLitterName' does not belong on card for litter '$cardLitterName'\n"
	  unless $mouseLitterName eq $cardLitterName;
    }
    warn ">>> Card litter not set, cannot tell whether mouse belongs\n"
      unless defined $cardLitterName;
    if (!defined $mouseLitterName) {
	my $match = $litterNameMatch ? "name matches OK" : "name does not match";
	warn ">>> Mouse litter is unknown (mouse did not come from a litter, $match), cannot tell whether mouse belongs\n";
    }

    # Check intended sex
    my ($cardSex, $csLong) = $self->getIntendedSex;
    my ($mouseSex, $msLong) = $args{-mouse}->getSex;
    # Look up correctness of match by letter pair
    my $errcode = { MM => 1, FF => 1, # correct sex
		    UM => 1, UF => 1, UN => 1, # unsexed card
		    MN => 2, FN => 2, # may be wrong, we can't tell
		    MF => 3, FM => 3, # wrong sex
		  }->{$cardSex.$mouseSex} || 0;
    my $error = { 1 => "",
		  2 => "mouse sex not yet set", # XXX: option, "will set it to $cardSex now"?
		  3 => "wrong sex for single-sex card",
		}->{$errcode};
    if ($error || !defined $error) {
	$error ||= "unknown combination/problem, please file a bug"; # XXX: more noise!
	warn ">>> Mouse '$mname' ($msLong) placed on $csLong card: $error\n";
    }

    # Add mouse to card
    my @dateRange;
    foreach my $d ($args{-since}, $args{-until}) {
	if (!defined $d) {
	    push @dateRange, undef;
	} elsif (ref($d)) {
	    push @dateRange, $d;
	} else {
	    push @dateRange, ATR::Date->newGT($d);
	}
    }

    # XXX: Checks on the mouse, before adding...  alive,  not currently on the card...

    # The PennedMouse class does the database work.  Cache via _getPenned
    my ($penned, $pennedSubEnt) = ATR::MicePE::PennedMouse->create($self, $args{-mouse}, @dateRange);
    return $self->_getPenned($pennedSubEnt, $penned);
}


=head2 getCurrentMice

Returns info about mice currently contained in the cage.

In scalar context, returns number of mice without adopting them.

In list context, returns list of GT wrappers of type
L<ATR::MicePE::PennedMouse> in no particular order.

These objects are cached in the object, indexed by the attribute.
This means from one L<ATR::MicePE::Weaning> object, for one mouse and
for one time period on the card, you will get the same object back.
XXX:CACHE same-object guarantee was needed, is it still?

Errors propagate from database.

=cut

sub getCurrentMice {
    my ($self, $when) = @_;
    $when ||= ATR::Date->now(); # default: now

    return safegrep { (shift)->cmpDate($when) == 0 } $self->getAllMouseVisits;
}


1;
