package ATR::MicePE::PennedMouse;

use strict;
use warnings;

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

use base 'ATR::MiceSubPE';


=head1 NAME

ATR::MicePE::PennedMouse - object wrapper for GT 'Penned Animal'
sub-entity

=head1 DESCRIPTION

Object represents the mouse on a card.

=cut


# $Id: PennedMouse.pm,v 1.13 2005/02/04 16:06:29 mca Exp $
our $VERSION = (qw$Revision: 1.13 $)[1];

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


=head2 construct($card, $pennedAnimalSubentity)

Create wrapper object for $pennedAnimalSubentity, which should be a
part of $card.

To be called by the containing ATR::MicePE::* object.

May return C<undef> if your sub-entity has been cancelled.

=cut

sub construct {
    my ($proto, $card, $pennedAnimalSubentity) = @_;
    croak "Need 2 args: card, mouse pointer attribute" if @_ != 3;
    croak "Need a card, got $card" if !UNIVERSAL::isa($card, 'ATR::MicePE::Card');
    croak "Need a 'Penned animal' sub-entity, got $pennedAnimalSubentity"
      if !UNIVERSAL::isa($pennedAnimalSubentity, 'GT::Physical::Entity::Contents') ||
	$pennedAnimalSubentity->getIdEntityContentsType != ATR::GTx::ENT_CONT_TYPE_ATR_PENNED;

    my $class = ref($proto) || $proto;
    my $self = bless { card => $card, cont => $pennedAnimalSubentity }, $class;

    return undef if !$self->_getMouseAttr; # this is an ex-PennedAnimal; it has been cancelled

    my $try_it = $self->_getWhenAttr; # ... what do we do/allow when animal is set but range hasn't been?

    return $self;
}


=head2 create($card, $atrMouse, $start_date, $end_date)

Create new 'Penned Animal' sub-entity with given mouse and dates,
return ($wrapperObject, $subEntity) for it.

To be called by the containing ATR::MicePE::* object.

=cut

sub create {
    my ($proto, $card, $mouse, @range) = @_;
    croak "Class method needs 4 args: card, mouse, date pair" if @_ != 5;
    croak "Need a card, got $card" if !UNIVERSAL::isa($card, 'ATR::MicePE::Card');
    croak "Need an ATR::MicePE::Mouse, got $mouse"
      if !UNIVERSAL::isa($mouse, 'ATR::MicePE::Mouse');
    croak "Cannot set daterange with open start" if !defined $range[0];
    croak "Date pair args must be ATR::Date"
      if grep { defined $_ && !UNIVERSAL::isa($_, 'ATR::Date') } @range;

    my $class = ref($proto) || $proto;
    my $self = bless { card => $card }, $class; # object is incomplete at this point!
    my $gtx = $self->getGTx;
    $self->{cont} = $gtx->createSubEntity(-pe => $card->_getPE,
					  -idEntityContentsType => ATR::GTx::ENT_CONT_TYPE_ATR_PENNED);

    # Set mouse
    $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);

    # Set containment date(s)
    $self->setDateRange(@range);

    $self->_flush; # XXX: setDateRange did it already...

    return ($self, $self->_getSubPE);
}


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

=head1 OBJECT METHODS

=head2 getMouse

Returns and caches the adopted mouse as an L<ATR::MicePE::Mouse>.

=cut

sub getMouse { # XXX:DEPRECATED (but rather convenient) best that the caller does the adoption: we can now supply the mouseId
    my $self = shift;
    return $self->{mouse} ||= ATR::MicePE::Mouse->findByAttribute($self->_getMouseAttr);
}

# Returns mouse PeID or undef if this item is cancelled
sub getMouseId {
    my $self = shift;
    my $attr = $self->_getMouseAttr;
    return $attr ? $attr->getValue : undef;
}


# Returns undef or "contained mouse" attribute; error if multiple mice
sub _getMouseAttr {
    my $self = shift;
    my $gtx = $self->getGTx;

    my ($list) = $gtx->getAttribute(-pe => $self->_getSubPE,
				    -attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
				    -reason => GTx::REASON_CONTAINS);
    return $list->[0] if @$list <= 1;
    die "Expected one contained mouse, found (".@$list.")";
}

sub debugId {
    my $self = shift;
    return "penned mouse class $self" unless ref($self);
    # Hardened against objects evaporating (becoming undef) during global destruction...
    my $speid = eval { $self->_getSubPE->getId } || '[no data]';
    my $mouseid   = eval { my $attr = $self->_getMouseAttr; $attr ? $attr->getValue : "[cancelled]" } || '[unknown]';
    my $card = eval { $self->card->debugId } || '[lost card ref]';
    return "penned mouse (SubPEid=$speid for mouse PeID=$mouseid under $card)";
}

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

sub card { $_[0]->{card} }
sub _flush { $_[0]->card->_flush } # runtime inefficient, but keeps code simple


=head2 getStartDate

Returns one L<ATR::Date> object.

=head2 getEndDate

Returns one L<ATR::Date> object or C<undef> if this mouse/timespan is
still current.

=cut

sub getStartDate {
    my $self = shift;
    return ($self->getDateRange)[0];
}

sub getEndDate {
    my $self = shift;
    return ($self->getDateRange)[1];
}

sub cmpDate {
    my ($self, $when) = @_;
    my ($start, $end) = $self->getDateRange;

    return 1 if $start->cmp($when) > 0; # $start is newer than $when --> $self newer than $when
    return 0 if !defined $end;          # no $end --> within open range
    return -1 if $end->cmp($when) < 0;  # $end is older than $when --> $self older than $when
    return 0;			        # inside closed range
}


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

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

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

    return $starts->[0] if @$starts == 1 && @$ends == 0;
    return $ends->[0]   if @$starts == 0 && @$ends == 1;

    return undef if $noError;

    die "Found no timing information on ".$self->debugId if @$starts + @$ends == 0;
    die "Found ambiguous timing information starts=(@$starts), ends=(@$ends) on ".$self->debugId;
}

sub getDateRange {
    my ($self, $attr) = @_;
    $attr = $self->_getWhenAttr unless defined $attr;
    my $id_daterange = $attr->getValue;
    return ATR::BioTables->getDateRangeById($id_daterange)
}


=head2 setStartDate($when)

Equivalent to C<setDateRange($when, $currentEndDate)>

Change the start date on the containment, maintaining the end date (or
lack of).

C<$when> can be an L<ATR::Date>, or strings will be sent for a guess
at format conversion.

=head2 setEndDate($when)

Equivalent to C<setDateRange($currentStartDate, $when)>

C<$when> may be C<undef> or blank to show an open range.

C<$when> can be an L<ATR::Date>, or strings will be sent for a guess
at format conversion B<date part only>.

=cut

sub setStartDate {
    my ($self, $newDate) = @_;
    $newDate = ATR::Date->new_GuessDate($newDate, '00:00:00') if !ref($newDate);
    my $currentEndDate = $self->getEndDate;
    $self->setDateRange($newDate, $currentEndDate);
}

sub setEndDate {
    my ($self, $newDate) = @_;
    if (!$newDate) {
	undef $newDate;
    } elsif (!ref($newDate)) {
	$newDate = ATR::Date->new_GuessDate($newDate, '23:59:59');
    } # else it'll be an ATR::Date

    my $currentStartDate = $self->getStartDate;
    $self->setDateRange($currentStartDate, $newDate);
}


=head2 setDateRange($startWhen, $endWhen)

If C<$endWhen> is C<undef>, (re)sets the mouse/timespan to be current
and contiguous from the start.

Otherwise, parameters should be of type L<ATR::Date>.

B<nb.> Also calls C<fixRangeConflicts> at the end.

=cut

sub setDateRange {
    my ($self, @newRange) = @_;

    croak "Object method requires 2 args" unless @newRange == 2;
    croak "Cannot set daterange with open start" if !defined $newRange[0];
    croak "Object method args must be ATR::Date"
      if grep { defined $_ && !UNIVERSAL::isa($_, 'ATR::Date') } @newRange;

    my $attr = $self->_getWhenAttr(1);

    my @oldRange = defined $attr ? $self->getDateRange($attr) : ();

    my $gtx = $self->getGTx;

    if (@oldRange		# have an existing attribute + bio record,
	&& !defined $oldRange[1] && defined $newRange[1] # existing end_date is null,
	&& $oldRange[0]->cmp($newRange[0]) == 0	# keeping same start_date
       ) {
	# We're filling in the end date, not changing the start.
	# Update the bio record, then replace the attribute.

	my $id_daterange = $attr->getValue;
	ATR::BioTables->setDateRange_end($id_daterange, $newRange[1]);

	$gtx->cancelAttribute($attr);
	$gtx->addAttribute(-pe => $self->_getSubPE,
			   -attributeType => ATR::GTx::ATT_TYPE_PENNED_DURING,
			   -value => $id_daterange, # same Bio record
			   -reason => GTx::REASON_ATTRIBUTE,
			   -idRole => $self->getIdRole,
			   -sessionId => $self->getSessionId);
    } else {
	# Changes can't be represented by preserving existing records.
	# Invalidate whatever is there, create fresh records.

	my $datesType  = (defined $newRange[1]
			  ? ATR::GTx::ATT_TYPE_PENNED_DURING
			  : ATR::GTx::ATT_TYPE_PENNED_SINCE);
	my $id_daterange = ATR::BioTables->newDateRange_Id(@newRange); # end_date may be undef

	$gtx->cancelAttribute($attr) if defined $attr;
	$gtx->addAttribute(-pe => $self->_getSubPE,
			   -attributeType => $datesType,
			   -value => $id_daterange,
			   -reason => GTx::REASON_ATTRIBUTE,
			   -idRole => $self->getIdRole,
			   -sessionId => $self->getSessionId);
    }

    # Flush before the checking fix, else the SQL will not see us (!)
    $self->_flush;

    # Check for holes in the history (left by either case above) or
    # ranges overlapping with other cards (second case only)
    $self->fixRangeConflicts();
}


=head2 CancelVisit()

Cancel the date range attribute (if present) and the contained animal
(?).  The animal was, from now in data-entry-time, never on the card
in mouse-history time.

XXX: Not clear: cancel just the range, the contained animal too or the sub-entity as well?

=cut

sub CancelVisit {
    my $self = shift;
    my $gtx = $self->getGTx;
    my $whenAttr = $self->_getWhenAttr(1);
    $gtx->cancelAttribute($whenAttr) if $whenAttr;

    my $mouseAttr = $self->_getMouseAttr;
    $gtx->cancelAttribute($mouseAttr) if $mouseAttr;

    $self->_flush;
}


=head2 fixRangeConflicts()

Finds and fixes overlapping PennedAnimal date ranges for this mouse.

Overlapping ones will be truncated (for partial overlap) or cancelled
(for complete overlap - "contains" will also be cancelled, leaving a
PennedAnimal containing no animal or date). XXX: things will fall over on seeing this

Warnings will be made for overlap ranges modified.  The PennedMouse
objects could be returned from this call if necessary.

Precedence is by the data-entry time C<$attr-E<gt>getInitDate>, most
recent get the first bite of available mouse-existence time range.
Older data will be truncated or cancelled to make space for the new
data.

New open ranges will close old open ranges in the obvious way.

XXX: Contains ickiness to avoid n-squared (almost certainly harmless but wasteful) recursion on a mouse

=cut

my %fixRangeConflicts_busy; # key = mouseId, value = mouse-being-processed flag
sub fixRangeConflicts {
    my $self = shift;
    my $gtx = $self->getGTx;

    # List of PennedMouse containing our mouse; will include ourself
    my @penned;

    my %cards; # key=peId, value = ATR::MicePE::Card
    my $mouseId = $self->getMouseId;
    # XXX:LOCK fixRangeConflicts_busy only locks among ourself (this app) and within our transaction
    if ($fixRangeConflicts_busy{$mouseId}) {
	warn "      Avoid recusion on mouseid $mouseId\n";
	return;
    }
    local $fixRangeConflicts_busy{$mouseId} = 1; # unlocks when we leave, handy

    foreach my $class (qw( ATR::MicePE::MatingPair ATR::MicePE::Weaning )) { # XXX: enumerate Card subclasses?
	my $entType = $class->idEntityType;
	my @pairs = $gtx->listEntitiesWith
	  (-peType => $entType,
	   -subPeType => ATR::GTx::ENT_CONT_TYPE_ATR_PENNED,
	   -infoReason => GTx::REASON_CONTAINS,
	   -attributeType => ATR::GTx::ATT_TYPE_ATR_MOUSE,
	   -value => $mouseId);

	foreach my $p (@pairs) {
	    my ($peId, $subPeID) = @$p;
	    # XXX: caching of GT and ATR2GT objects should be whole-app with some lock
	    my $card = $cards{$peId} ||= $class->findByPeId($peId);
	    push @penned, $card->getPennedById($subPeID);
	}
    }

    my %penned = map {( $_, $_ )} @penned; # string-to-object map

warn "fixRangeConflicts for ".$self->debugId.":\n";

    # Used ranges
    my %used; # key = stringified-PennedMouse, value = [$start, $end] pair of ATR::Date, $end may be undef

    # Consider @penned items in by initdate of their daterange: recently entered data last
    @penned = sort __byLastUpdated @penned;

    for (my $I=$#penned; $I >= 0; $I--) {
	my $p = $penned[$I];
	my $origRange = [ $p->getDateRange ];

{my $attr = $p->_getWhenAttr(1);
 if ($attr) {
     my $id = $attr->getId;
     my $i = $attr->getInitDate;
     $attr = "$id\@$i <= [".__daterange2str($p->getDateRange)."]";
 } else {
     $attr = "[undef]";
 }
 warn "  $attr ".$p->debugId."\n";
}

	# List of listref:[ $start, $end ]
	# First item is for $p, others would have to be created later
	my @pRanges = ($origRange);

	# Items that took bites out of @fromto
	my @edits; # list of listref:[ stringified-PennedMouse, $editType ]

      # Check each of @pRanges against all %used so far
      # In forward order of history, for tidy edits
      foreach my $used (@penned) { # nb. order 0.5 n-squared
	    next if !$used{$used}; # only subtract what has been used/seen already (data entered after $p)
	    next if $used == $p; # don't subtract range from itself
	    next unless defined $used->getMouseId; # ignore PennedAnimal we just cancelled
if(0)
{ my $uB = join "", $penned{$used}->card->getBarcode;
  my $pB = join "", $p->card->getBarcode;
  my $pR = join "; ", safemap { __daterange2str(@{+shift}) } @pRanges;
  my $uR = __daterange2str(@{$used{$used}});
  warn "    Do for $pB:($pR) loses $uB:($uR)\n";
}
	    my ($editsList, @ranges) = __daterangeSubtract($used{$used}, @pRanges);
	    next if !$editsList;
	    # We need to edit @pRanges
	    push @edits, map {[ $used, $_ ]} @$editsList;
#warn "      Edits (@$editsList)\n";
	    @pRanges = @ranges;
	    last if !@pRanges; # stop early if @pRanges are now entirely hidden/replaced
	}
	$used{$p} = $origRange; # daterange is now "used up"; doesn't matter if it overlaps preceding
	next unless @edits;

warn
+( join "\n|     ", "|== Modified card ".(join "", $p->card->getBarcode)." with",
   safemap {
       my $ref = shift;
       my ($timeUser, $edit) = ($penned{$ref->[0]}, $ref->[1]);
       my $barcode = join "", $timeUser->card->getBarcode;
       my $when = (defined $timeUser->getMouseId
		   ? __daterange2str($timeUser->getDateRange)
		   : '[no range]'); # shouldn't happen any more
       "$edit : $barcode:[$when]";
   } [$p, "INITIAL"], @edits
 )."\n";

	# Things changed, we must edit $p
	if (!@pRanges) {
	    # Cancel the whole thing
	    $p->CancelVisit();
	    warn "  > Cancelled range in ".join "", $p->card->getBarcode;;
	} else {

	    for (my $i=0; $i<@pRanges; $i++) {
		my (@fromto) = @{ $pRanges[$i] };
		if ($i == 0) {
		    # Update the existing range
		    $p->setDateRange(@fromto);
warn "  > Set old range [".__daterange2str(@fromto)."]\n";
		} else {
		    # Add new visit of the same mouse & card, directly without using the
		    # card class: we manage the PennedAnimal sub-entity
		    my ($card, $mouse) = ($p->card, $p->getMouse);
		    my ($penned, $pennedSubEnt) = ATR::MicePE::PennedMouse->create($card, $mouse, @fromto);
warn "  > Added new range [".__daterange2str(@fromto)."]\n";
		}
	    }
	}
    }
warn "Done\n========================================\n";

    # XXX: Need to detect when we're leaving holes in the history, and warn there too?
    # (can do this by sticking the "alive" range at the back of @penned, see if any of it remains)
}

# Args: ( [$usedStart, $usedEnd], @originRanges), where @originRanges
# members are [$start,$end] pairs which represent (remaining) pieces
# of one original range.
#
# Returns ($editsList, @replacementRanges)
# $editsList is undef if no changes were made to any range, else a list containing
# one item per member of @originRanges: string describing the edit or undef for no change
sub __daterangeSubtract { # XXX: Make daterange class using ATR::Date, put this in there; subclass ATR::Date to allow undef value of its point?
# XXX:TEST this code is slightly hairy, no tests
    my ($usedRange, @inRanges) = @_;
    my ($uL, $uR) = @$usedRange;
    my @edits;
    my @outRanges;
    for (my $i=0; $i<@inRanges; $i++) {
	my ($mL, $mR) = @{ $inRanges[$i] };

	my $mLuR = defined $uR ? $mL->cmp($uR) : undef;
	my $mRuL = defined $mR ? $mR->cmp($uL) : undef;
	my $mLuL = $mL->cmp($uL);
	my $mRuR = defined $mR && defined $uR ? $mR->cmp($uR) : undef;

	# From here in, you need the diagram...
	if ( (defined $uR && $mLuR >= 0) # (open|closed) M entirely to the right of  closed       U
	     ||
	     (defined $mR && $mRuL <= 0) #       closed  M entirely to the left  of (closed|open) U
	   ) {
	    # Non-overlap, possibly with a gap
	    push @outRanges, [ $mL, $mR ];

	} elsif ( (defined $mRuR && $mRuR <=0 && $mLuL >=0) # closed M entirely hidden by closed U
		  ||
		  (!defined $uR && $mLuL >= 0)              # (open|closed) M entirely hidden by open U
		) {
	    my $exact = $mLuL == 0 && defined $mRuR && $mRuR == 0;   # when M & U are the same closed range
	    $exact ||= ($mLuL == 0 && !defined $mR && !defined $uR); # when M & U are the same open range
	    $edits[$i] = $exact ? "replaced" : "hidden";

	} elsif (!defined $uR && !defined $mR) { # given: $mLuL < 0
	    # open M is shut by open U; this happens in a normal transfer
	    $edits[$i] = "close";
	    push @outRanges, [ $mL, $uL->midnightJiggle(1) ];

	} elsif (!defined $uR # given: $mLuL < 0 && $mRuL > 0
		 ||
		 (defined $mR && $mRuR <= 0) # given: $mLuL < 0
		) {
	    # closed M is shortened on the right by (open|closed) U
	    $edits[$i] = "shrink_R";
	    push @outRanges, [ $mL, $uL->midnightJiggle(1) ];

	} elsif ($mLuL >= 0) {
	    # (open|closed) M is shortened on the left by closed U
	    $edits[$i] = "shrink_L";
	    push @outRanges, [ $uR->midnightJiggle(0), $mR ];

	} else {
	    # (open|closed) M is split in two by closed U
	    $edits[$i] = "split";
	    push @outRanges, ( [$mL, $uL->midnightJiggle(1)],
			       [$uR->midnightJiggle(0), $mR] );

#	} else {
#	    my $used = join " - ", $uL->getGT, (defined $uR ? $uR->getGT : 'ever');
#	    my $mod  = join " - ", $mL->getGT, (defined $mR ? $mR->getGT : 'ever');
#	    die "Code is broken: failed to subtract ($used) from ($mod)";
	}
    }

    return( @edits ? \@edits : undef,
	    @outRanges );
}

sub __daterange2str { join " - ", $_[0]->getGT, (defined $_[1] ? $_[1]->getGT : 'ever') }

sub __byLastUpdated {
    # $a, $b are PennedMouse objects.  Sort most recent daterange
    # first; sort by presence of daterange, then init_date, then by
    # id_attribute.
    #
    # Sorting by ID is dubious when sequences have caches, but we only
    # need to stabilise the sort when init_dates are equal.

    my ($aA, $bA) = ($a->_getWhenAttr(1), $b->_getWhenAttr(1)); # no errors
    return( (defined $aA <=> defined $bA) ||
	    $aA->getInitDate cmp $bA->getInitDate || # GT date format is string-sortable
	    $aA->getId <=> $bA->getId
	  );
}

1;
