package ATR::MicePE::Mouse;

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';

use Carp;
use ATR::BioTables;


=head1 NAME

ATR::MicePE::Mouse - "AniTrack mouse" object wrapper of GT:P:E

=head1 CLASS METHODS

=cut


my %VALID_SEX = (M => 'Male', F => 'Female', N => 'Not sexed');
use constant FCREM_SEX => "_SEX";
use constant FCREM_DOB => "_Date_Birth";

# $Id: Mouse.pm,v 1.33 2005/02/02 14:36:38 mca Exp $

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

=head2 idEntityType()

Method for the benefit of superclass' methods.

=cut

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


=head2 findByName($mouse_name)

Class method: find a mouse by its mouse name.

Returns one new object, or undef if not found.

Errors propagate, also errors if multiple matches found.

=cut

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

    return $proto->_findByName($mousename, ATR::BioTables::NAMETYPE_MOUSE);
}


=head2 findByAttribute($gt_attrib)

Adopt the mouse specified by the given attribute.

Returns one new object.

Errors propagate, also error if type doesn't match or object not
found.

=cut

sub findByAttribute {
    my ($proto, $attr) = @_;
    croak "Need 1 arg: GT attribute" unless @_ == 2 && $attr
      && UNIVERSAL::isa($attr, 'GT::Physical::Entity::Contents::Attribute');

    if ($attr->getIdAttributeType != ATR::GTx::ATT_TYPE_ATR_MOUSE) {
	croak "Attribute is not an ATR_MOUSE";
    }

    my $mouse = $proto->findByPeId($attr->getValue);
    if (!$mouse) {
	croak "Cannot find ATR Mouse with idPe=".$attr->getValue." from idAttribute=".$attr->getId;
    }
    return $mouse;
}

=head2 createNamed($mouse_name)

Create a new Mouse PE with

=over 4

=item state = Created

=item sex = Unknown

=item XXX: colony? newly created mouse has no implicit colony until put in litter

...so we could be left with a mouse that doesn't belong to a colony if
we commit part way through.  Clearly the next layer up has
coordination to do.

...but we can cheat and get the colony from the mouse name, if it
wasn't set.  This assumes the mouse name is non-atomic: works for
C<DN56.23f> but not for C<Mickey>.

=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:NOTYET Allow re-use when all other mice have been cancelled

[Hmmm, racing again.  Can check for a double re-use on cancel, then
cancel the new one too... if our attribute id greater than the newly
offending one? No...]

=cut

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

    # Set name: one-time operation for mouse
    my $id_name = ATR::BioTables->newName_idName($mousename, ATR::BioTables::NAMETYPE_MOUSE);
    if (!defined $id_name) {
	# XXX:USRTHROW Class::Throwable subclass for user-significant error?  Extra field for suggested workaround, urgency of problem, unstashable data and place to send it?  Name of extra parameter to pass in to force an otherwise questionable operation (e.g. mouse named 'Mickey' instead of 'MK23.45f')
	# XXX: May block use a valid name here if the name was committed without the GT flush+commit; since GT & Bio commits are not atomic with each other, we would require GT to commit before the bio in order to find a name and be sure it was not about to be referenced from a new GT:P:E
	die "A mouse named '$mousename' exists already.  Re-using this name is possible but currently not supported, sorry.  Un-cancelling the other mouse may be an appropriate alternative.\n";
    }

# XXX:GTR would I need to politely dismiss an unwanted not-flushed PE, or just let it go?
    my $class = ref($proto) || $proto;
    my $self = bless {}, $class;
    my $gtx = $self->getGTx;
    $self->{_PE} = $gtx->createPhysicalEntity(-entityType => ATR::GTx::ENT_TYPE_ATR_MOUSE);
    my $name_info = $gtx->addInfo(-pe => $self->_getPE,
				  -idContentType => ATR::GTx::CONT_TYPE_ATR_NAME,
				  -idContent => $id_name,
				  -reason => ATR::GTx::REASON_IDENTIFIED_BY);

    $self->_flush;

    return $self;
}

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

=head1 OBJECT METHODS

=cut

sub _getPE { $_[0]->{_PE} }

# This flush is called by the main data method(s), nobody else needs it
sub _flush {
    my $self = shift;
# XXX: $self->_getPE->checkPattern [GTx method?] before flushes
# $self->_getPE->makePattern(-idConcreteIo => ?)
    $self->_getPE->flush;
}

# sub _readopt { my $self = shift; $self->{_PE} = $gtx->getPhysicalEntity(-idPe => $self->{_PE}->getId, -entityType => $self->{_PE}->getIdEntityType ) }

# some kind of ... re-adopt but compare the old & new, to see whether
# the item changed in the DB while we weren't looking..?


=head2 getMouseName()

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 getMouseName {
    return $_[0]->_getName(ATR::BioTables::NAMETYPE_MOUSE);
}


sub debugId {
    my $self = shift;
    return "mouse class $self" unless ref($self);
    # Hardened against objects evaporating (becoming undef) during global destruction...
    my $peid = eval { $self->getPeID } || '[lost card ref]';
    my $name = eval { "'".$self->getMouseName."'" } || "[unknown]";
    return "mouse (name=$name, peid=$peid)"; # XXX: this is ENTITY_TYPE.DESCRIPTION, get it from DB
}


=head2 setGenotype($genotype, $remark);

C<$genotype> is handled by C<ATR::BioTables-E<gt>getGenotypeId> and
friends.  Currently this is the RAW_NAME genotype name.

C<$remark> is optional.

Likely to be more complex later.

=cut

sub setGenotype {
    my ($self, $raw_name, $remark) = @_;
    my $gtx = $self->getGTx;

    my $id_geno = ATR::BioTables->getGenotypeId(-raw => $raw_name);

    # invalidate old attributes .. there should be at most one
    foreach my $old ($self->_getAttr_Genotype) {
	$gtx->cancelAttribute($old) if $old->getIsCurrent;
    }

    $gtx->addAttribute(-pe => $self->_getPE,
		       -attributeType => ATR::GTx::ATT_TYPE_GENOTYPE,
		       -value => $id_geno,
		       -remark => $remark,
		       -reason => GTx::REASON_ATTRIBUTE,
		       -idRole => $self->getIdRole,
		       -sessionId => $self->getSessionId);

    $self->_flush;
}

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

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

    return () unless $listref;
    return @$listref;
}


=head2 getGenotype

Returns undef if the mouse has no defined genotype (XXX: or the bio data got lost somehow - no warning)

If found, returns the RAW_NAME of the genotype.  If you need to do
comparisons on this, it's time to fix up a genotype class and use this
from L<ATR::BioTables>.

=cut

sub getGenotype {
    my $self = shift;
    my $gtx = $self->getGTx;
    my @geno_attr = $self->_getAttr_Genotype;

    if (!@geno_attr) {
	return undef;
    } elsif (@geno_attr > 1) {
	# XXX:SHAPE XXX:USRTHROW Bad shape could be a result of race additions, shape check will not save us
	# Could check whether the rows do in fact conflict
	confess "Conflicting genotype data for ".$self->debugId;
    }

    my $genotype;
    $genotype = ATR::BioTables->getGenotypeInfo(-id => $geno_attr[0]->getValue);

    return $genotype ? $genotype->{raw} : undef;
}


=head2 getState

Return C<$statusName> in scalar context, C<($statusName, $remark)> in
list context.

=cut

sub getState {
    my $self = shift;
    my $gtx = $self->getGTx;
    return $gtx->getStatus(-pe => $self->_getPE);
}

=head2 getStateId

Return a value suitable for comparison with an
C<ATR::GTx::STATUS_MOUSE_*> constant.

=cut

sub getStateId { # XXX:WASTEFUL Probably looks up the id, then id2name, then get all names and ids and hash lookup the id
    my $self = shift;
    my $stateName = $self->getState;
    return $self->getEntityStatusDict->{ $stateName };
}

=head2 setState($key =E<gt> $state, $remark)

C<$key> must be C<-id> or C<-name>.

C<$remark> is optional.

Dies if C<$key =E<gt> $stateId> is not in our statusdict.

=cut

sub setState {
    my ($self, $key, $state, $remark) = @_;
    my $gtx = $self->getGTx;

    my $stateName;
    if ($key eq '-id') {
	# Numbers just seem so much safer...  let's see how I use it
	my $state_dict = $self->getEntityStatusDict;
	my %rev = reverse %$state_dict;
	$stateName = $rev{$state};
    } elsif ($key eq '-name') {
	$stateName = $state;
    }
    croak "Invalid mouse status $key => $state" unless $stateName;

    $gtx->changeStatus(-pe => $self->_getPE,
		       -status => $stateName,
		       -remark => $remark,
		       -idRole => $self->getIdRole,
		       -sessionId => $self->getSessionId);
    $self->_flush;
}



=head2 setSex($sex)

Set sex to a string, which must be one of C<qw(M F N)> .

A better enum of possible sexes is likely to follow later.

XXX: Can't set a remark (needed for re-sex?), until we have a proper attribute & bio table

=cut

sub setSex {
    my ($self, $sex) = @_;
    croak "Unknown sex identifier '$sex'" unless defined $VALID_SEX{$sex};
    $self->setFreeRemark(FCREM_SEX, 1, $sex);
}

=head2 getSex

Returns C<($letter, $descr)> in list context, C<$letter> in scalar
context.

If a sex had not been stored, returns C<N =E<gt> 'Not sexed'>.

Errors propagate, generated if we have conflicting or ambiguous sex
attributes.

=cut

sub getSex {
    my $self = shift;
    my @attr = $self->getFreeRemark(FCREM_SEX);
    my $sex;

    if (@attr > 1) {
	confess "Found conflicting mouse sex indicators on ".$self->debugId;
    } elsif (!@attr) {
	$sex = 'N';
    } else {
	$sex = $attr[0];
    }

    my $descr = $VALID_SEX{$sex};
    if (!defined $descr) {
	$sex = '[undef]' unless defined $sex;
	confess "Found unknown or ambiguous sex indicator '$sex' on ".$self->debugId;
    }
    return wantarray ? ($sex, $descr) : $sex;
}


sub setBirthDate {
    my ($self, $date) = @_;
    $self->setFreeRemark(FCREM_DOB, 1, $date);
}
sub setDateBirth {
    my ($self, $date) = @_;
    $date = ATR::Date->new_GuessDate($date, '00:00:00') unless ref($date);
    $self->setBirthDate($date->getGT);
}

sub getBirthDate {
    my $self = shift;
    my @attr = $self->getFreeRemark(FCREM_DOB);
    if (@attr > 1) {
	confess "Found conflicting mouse date of birth indicators on ".$self->debugId;
    } elsif (!@attr) {
	return undef;
    } else {
	return $attr[0];
    }
}

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

# XXX: setDeathDate, getDeathDate : ATR::Date? other half of alive range? method names as [sg]etDate(Birth|Death|Weaning) ?

# XXX: general purpose attribute get .. may want to pass the attribute (or un-dbh'ed version of) up somewhere so folks can get time/user info easily. Also need to access history by some uniform mechanism.


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

=head2 getLitterGroup

Returns the L<ATR::MicePE::LitterGroup> for this mouse.  May be undef,
i.e. the mouse may not be a member of a litter.

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 getLitterGroup { # XXX:DUP very similar to Weaning->getLitterGroup4Virtual
    my $self = shift;
    return $self->{_littergroup} if defined $self->{_littergroup};

    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,
       -infoReason => GTx::REASON_CONTAINS,
       -infoType => GTx::CONT_TYPE_ATTRIBUTE,
       -attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
       -value => $self->getPeID);

    # XXX: Deal with multiple and/or cancelled LitterGroups found
    return undef if !@id_pairs;
    die "Mouse ".$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;
}


=head2 getPenneds($when, $cardType)

BROKEN / SUBJECT TO CHANGE

Returns card objects (ATR::MicePE::Card subclass) relevant to this
mouse, searching according to $type:

 mate => mating cards on which the mouse was a mate
 wean => any weaning cards (virtual or otherwise)
 pup => mating cards for the mouse's litter.

In list context, returns all such cards or an empty list if there are
none.  In scalar context, returns exactly one card or throws an error.

Cards are considered relevant if the mouse was listed on the card
during date/time C<$when>.  This should be an L<ATR::Date>, or
C<undef> to return all cards that have ever contained the mouse.

XXX: Cancelled cards should be ignored.

=head2 getCurrentCard()

Returns card(s) currently relevant for this mouse, list or scalar
context as for C<getCards>.  Uses C<makeDate>'s notion of 'now'.

=cut

sub getPenneds {
    my ($self, $when, $type) = @_;
    my $gtx = $self->getGTx;
die "XXX: broken, not yet used";
    die "Need 2 args for object method" unless @_ == 3;
    # Get and sort lists of [pe, subpe] pairs...

    # Uniquify the IDs list:
    #   for matings since parent mice are in both penned & mating group
    #   for weaning cards to allow for mice with multiple PennedAnimal sub-entities

    my %scan; # key = PeID, value = [ type, { key = SubPeID, value = undef } ]
    foreach my $id_pair ($gtx->listEntitiesWith(-peType => ATR::GTx::ENT_TYPE_ATR_MOUSE_MATING,
						-subPeType => ATR::GTx::ENT_CONT_TYPE_ATR_MATING,
						-infoReason => GTx::REASON_CONTAINS,
						-attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
						-value => $self->getPeID),
			 $gtx->listEntitiesWith(-peType => ATR::GTx::ENT_CONT_TYPE_ATR_MATING,
						-subPeType => ATR::GTx::ENT_CONT_TYPE_ATR_PENNED,
						-infoReason => GTx::REASON_CONTAINS,
						-attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
						-value => $self->getPeID)) {
	my ($pe, $subpe) = @$id_pair;
	$scan{$pe} ||= [ 'ATR::MicePE::MatingPair', {} ];
	$scan{$pe}->[1]->{$subpe} = undef;
    }

    foreach my $id_pair ($gtx->listEntitiesWith(-peType => ATR::GTx::ENT_TYPE_ATR_MOUSE_WEANING,
						-subPeType => ATR::GTx::ENT_CONT_TYPE_ATR_PENNED,
						-infoReason => GTx::REASON_CONTAINS,
						-attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
						-value => $self->getPeID)) {
	my ($pe, $subpe) = @$id_pair;
	$scan{$pe} ||= [ 'ATR::MicePE::Weaning', {} ];
	$scan{$pe}->[1]->{$subpe} = undef;
    }

    # Adopt each PE, try the relevant SubPEs
    foreach my $peid (keys %scan) {
	my $type = $scan{$peid}->[0];
	my @subpe = keys %{ $scan{$peid}->[1] };
	my $obj = $type->findByPeId($peid);
	warn "Adopted $peid = $obj\n";
    }

    die "XXX: Want entity/sub-entity pair list; adopt the sub-entities to filter each separately";
}


sub getCurrentCard {
    my $self = shift;
    return $self->getCards(ATR::Date->now);
}


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

=head2 $mouseA-E<gt>cmpByName($mouseB)

Or C<ATR::MicePE::Mouse-E<gt>cmpByName($mouseA, $mouseB)> if you prefer;
this version will cope with C<undef> for either object, putting undefs
after defined, but you must pass two scalars.

Returns -1, 0 or +1 the way the 'cmp' operator does for strings.

=cut

sub cmpByName {
    my @cmp = @_;
    my $class = ref($cmp[0]) ? ref($cmp[0]) : shift @cmp;
    croak "Can only compare two" unless @cmp == 2;

    my $def = (defined $cmp[1]) <=> (defined $cmp[0]);
    return $def if $def != 0 || !defined $cmp[0];

    my @name = map { $_->getMouseName } @cmp;
    my @len = map { length($_) } @name;
    return $len[0] <=> $len[1] || $name[0] cmp $name[1];
}


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

=head1 LOCKING

Not yet implemented.  dn1 suggests

  select id_entity from physical_entity
  where  id_entity = ?
  for update nowait

before Adopting.  Expect much fun with DBAs clearing locks, locking
more things than I intended, grumpiness about locks being sat on.

=cut


1;
