package ATR::Tk::MatingCard;
use strict;
use Carp;

use ATR::Tk::UpdateEntry;
use ATR::Tk::CardRowParent;

use ATR::MicePE::MatingPair;
use ATR::MicePE::LitterGroup;

use ATR::Util;

use base qw(Tk::Derived ATR::Tk::AtrCard);
Tk::Widget->Construct('MatingCard');

# $Id: MatingCard.pm,v 1.71 2005/04/18 19:12:45 mca Exp $

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

my @LITS_HEAD = ('#', 'DOB', 'Pups', 'Weaned', 'Comments');


sub Populate {
    my ($self, $args) = @_;

# XXX: Allow initial info or edits: "...with these parents/in this colony"

    $self->SUPER::Populate($args);
#    $self->ConfigSpecs();

# Button area
    my $ops = $self->Subwidget('operators');
    $self->Advertise('add_litter',
		     $ops->Button(-text => 'Add litter',
				  -font => $self->getFont('furniture'),
				  -command => [ $self, 'op_add_litter' ])
		     ->pack(-side => 'left') );
    $ops->Button(-text => 'Transfer',
		 -font => $self->getFont('furniture'),
		 -state => 'disabled', # XXX: Fix
		 -command => [ $self, 'op_transfer' ])->pack(-side => 'left');

# Header area
    my $hf = $self->Subwidget('head_f');

    $self->Advertise('cardname',
		     $hf->UpdateEntry(-class => 'title', Name => 'cardname',
				      -labelfont => $self->getFont('title'),
				      -datafont  => $self->getFont('titledata'),
				      -label => "Mating card: ",
				      -labelpos => 'w')
		     ->pack(-side => 'left', -fill => 'y')
		    );

    $self->Advertise('carddate',
		      $hf->UpdateEntry(-class => 'title', Name => 'carddate',
				       -labelfont => $self->getFont('title'),
				       -datafont  => $self->getFont('titledata'),
				       -label => "Date mating setup:",
				       -labelpos => 'w')
		     ->pack(-side => 'right', -fill => 'y'));

# Top part of card
    my $card_f = $self->Subwidget('card_f');
    my $top_f = $card_f->Frame(Name => 'top_f')->pack(-side => 'top', -fill => 'x');
    my $lf = $top_f->Frame(Name => 'lic_f') # config by optdb
      ->pack(-side => 'right', -anchor => 'ne');
    my $pf = $top_f->Frame(Name => 'progs_f') # config by optdb
      ->pack(-side => 'left', -anchor => 'nw');

# Licence area
    foreach my $n (qw( PPL PIL User 19b )) {
	my $w = $lf->UpdateEntry(-label => "$n: ", -labelpos => 'w', Name => $n,
				 -labelfont => $self->getFont('label'),
				 -datafont  => $self->getFont('data'),
				)
	  ->pack(-side => 'top', -fill => 'x', -expand => 0);
	$self->Advertise("Licence$n", $w);
    }

# Progenitors
    # Row naming is significant, is matched and passed to addParent(-slot)
    foreach my $pname (qw(par_M par_F)) {
	my $row = ATR::Tk::CardRowParent->new($pname);
	$self->setRow($pname => $row);
	my $gridRow = $pname =~ /M/ ? 0 : 1;
	$row->setGridRow($gridRow);
	$row->setColumns(qw(sex name dob geno pheno ear coat dna comm));
	$row->makeWidgets($pf, -labelpos => ($gridRow ? 'n' : 'none'),
			  -labelfont => $self->getFont('label'),
			  -datafont  => $self->getFont('data'),
			 );
	$row->show(1);
    }

# Barcode area
    $self->Advertise('barcode', $card_f->BarcodeImage(-balloon => $self->tlBalloon))
	->pack(-side => 'right', -anchor => 'ne', -fill => 'none');

# Litters frame
    my $lit_f = $card_f->Frame(Name => 'litters_f')
      ->pack(-side => 'top', -anchor => 'nw');
    for (my $i=0; $i<@LITS_HEAD; $i++) {
	my $hdr = $lit_f->Label(Name => "col$i", -text => $LITS_HEAD[$i], -font => $self->getFont('label'));
	$hdr->grid(-row => 0, -column => $i, -sticky => 'nsew');
    }
    $self->Advertise(litters_f => $lit_f);

    $self->recommission;
}

sub recommission {
    my $self = shift;
    $self->{litter_map} = []; # key = grid(-row) number, value = ATR::MicePE::LitterGroup object, or ATR::Tk::UpdateEntry (the one for the litter name) for new
}


sub _setCard {
    my ($self, $card) = @_;
    die "Method needs 1 arg" unless @_ == 2;
    if (defined $card) {
	my $want_type = 'ATR::MicePE::MatingPair';
	croak "Card '$card' is not a $want_type" unless UNIVERSAL::isa($card, $want_type);
    }
    $self->privateData->{card} = $card;

    $self->fieldsUpdate;

    foreach my $w ($self->getAllFields) {
	next unless $w->isa('ATR::Tk::UpdateEntry');
	$w->clearGui;
    }
}
sub pair  { $_[0]->privateData->{card} } # specifically a mating _pair_
sub haveCard { defined $_[0]->pair }

sub decommission {
    my $self = shift;
    undef $self->privateData->{card};

    my $lits_f = $self->Subwidget('litters_f');
    my @widg = $lits_f->gridSlaves();
    foreach my $w (@widg) {
	$w->destroy if $w->isa('ATR::Tk::UpdateEntry'); # XXX: Should decommission these too
    }
}

### optional method, equivalent to a 'new(%args)'
# sub recommission { my ($self, %args) = @_; }

sub getAllParts {
    my $self = shift;

    # 'cardname' must be first thing committed on a blank, so we have
    # a card to poke into; then other fields
    my @cardFields = safemap { $self->Subwidget(shift) }
      qw(cardname LicencePPL LicencePIL LicenceUser Licence19b);

    my @litterFields;
    my %got_litter = $self->getLitterList;
    my @litterName = # litters in grid order
      (sort { $got_litter{$a}->[0] <=> $got_litter{$b}->[0] }
       keys %got_litter);
    foreach my $litterName (@litterName) {
	my ($gridRow, $litterGroup) = @{ $got_litter{$litterName} };
	# litterGroup will be undef while a litter is new
	my %widg = $self->litter_row_widgets($gridRow);
	push @litterFields, @widg{@LITS_HEAD}; # order is correct: littername first
    }

    my @parentRows = $self->getRow(qw(par_M par_F));
    return (@cardFields,
	    @parentRows,
	    $self->Subwidget('carddate'), # XXX: after parents, because of dependence on addParent above
	    @litterFields);
}


my $COL_PAT = qr/^([A-Z]+)/; # XXX:BUSLOG We're using the cardname field to set colony field

sub _fieldsUpdate { # XXX: Method becoming single-call-per-setup yet?  It should, when the fields become autonomous
    my $self = shift;
my $ev = $self->profileBlock('fieldsUpdate');
    # XXX: Allow litter addition on new card
    # Currently, it barfs on getNextLitterName, need class-method for null card? Strange route.
    $self->Subwidget('add_litter')->configure(-state => $self->haveCard ? 'normal' : 'disabled');

    # Barcode present when the card exists
    my ($bc_pfx, $bc_num) = $self->haveCard ? $self->pair->getBarcode : ();
    $self->Subwidget('barcode')->barcode($bc_num, $bc_pfx);

# Set up loose (non-row) card fields
# All need to -load or -default without a 'pair',
# 'cardname' must create the card when there is none.

# XXX: (various -finish codes) should do MicePE check; needed less if we can rollback

    my $w = $self->Subwidget('cardname');
    $w->setFieldDisplay($self->haveCard ? 'label' : 'entry');
    $w->setFieldAccessors(-load => sub {
			      return undef if !$self->haveCard;
			      return $self->pair->getMatingName;
			  },
			  -default => sub {
			      my $newColony = $self->newForColony;
			      return "" if !defined $newColony; # blank is "" to ensure 'modified' state
			      return ATR::MicePE::MatingPair->getNextName($newColony);
			  },
			  -complete => sub {
			      my ($text, $cursor) = @_;
			      my $str = substr($text, 0, $cursor);

			      my ($col) = $text =~ $COL_PAT;
			      if (defined $col && $str eq $col) {
				  return ATR::MicePE::MatingPair->getNextName($col); # XXX: deal with other mating cards in progress (and for default)
			      } else {
				  return ();
			      }
			  },
			  -finish => sub {
			      my $newval = shift;
			      $self->newForColony($1, "cardnameEdit", "name=$newval")
				if $newval =~ $COL_PAT;
			      $self->redefaultFields; # recursion alert - see method
			      return undef; # no checks, just wanted the hook
			  },
			  -save => sub {
# XXX: need to detect already-used mating number, offer to bump the number up one (or just do it)
			      my ($oldval, $newval) = @_;
			      die "Double-create for mating, new=$newval old=$oldval" if $self->haveCard;
			      my ($col) = $newval =~ $COL_PAT;
			      die "Can't figure out colony name from mating name '$newval', use 'LL123' format"	# XXX:USRTHROW
				unless $col;
			      my $card = ATR::MicePE::MatingPair->createBlank($col, $newval);
			      $self->_setCard($card);
			  });
    $w->checkDb;

    $w = $self->Subwidget('carddate');
    $w->setFieldDisplay('date');
    $w->setFieldAccessors(-default => sub { ATR::Date->now->getUI },
			  -load => sub {
			      return undef if !$self->haveCard;	# XXX: common guard clause, move out?
			      my $setup = $self->pair->getDateSetup;
			      return defined $setup ? $setup->getUI : "";
			  },
			  -finish => sub { undef },
			  ($self->haveCard # set r/o state; best if an accessor decides this later
			   ? ()
			   : ( -save => sub { warn "XXX: Set mating carddate relies on addParent" })
			  ),
			 );
    $w->checkDb;

    # Licence info
    foreach my $n (qw( PPL PIL User 19b )) {
	my $w = $self->Subwidget("Licence$n");
	my $getter = "getLicence$n";
	my $setter = "setLicence$n";
	$w->setFieldDisplay('entry');
	$w->setFieldAccessors
	  (-load => sub {
	       return undef if !$self->haveCard;
	       my $val = $self->pair->$getter;
	       return defined $val ? $val : "";
	   },
	   -default => sub {
	       my $newColony = $self->newForColony;
	       return undef if !defined $newColony;
	       return "for $newColony"; # XXX: find default for current colony
	   },
	   -finish => sub { undef }, # no checking
	   -save => sub {
	       my ($oldval, $newval) = @_;
	       $self->pair->$setter($newval);
	   });
	$w->checkDb;
    }

    # Set progenitors' info
    my @pair = $self->haveCard ? $self->pair->getParents : (); # XXX: change to return (undef, female) when only one present?
    # XXX: deal with absent mates
    $self->getRow('par_M')->setAdopted($pair[0]);
    $self->getRow('par_F')->setAdopted($pair[1]);
    $self->getRow('par_M')->fieldsUpdate;
    $self->getRow('par_F')->fieldsUpdate;

    # Litters on display
    my %got_litter = $self->getLitterList;

    # Enumerate litters in database .. compare
    my $num_litters = $self->haveCard ? $self->pair->getLitterCount : 0;
    for (my $i=0; $i<$num_litters; $i++) {
	my $litter = $self->pair->getLitter(-idx => $i);
	my $name = $litter->getLitterName;
	my $displayed = delete $got_litter{$litter->getLitterName};
	if (!defined $displayed) {
	    # New litter, isn't on display, stick it on the bottom of the list
	    $self->put_litter($litter, undef);
	} elsif (!defined $displayed->[1]) {
	    # Database litter matches "new" litter
	    $self->put_litter($litter, $displayed->[0]);
	} else {
	    # Database litter is already on display, check it's up-to-date
	    $self->put_litter($displayed->[1], $displayed->[0]);
	}
    }

    # New litter(s), not in database
    foreach my $litter_name (keys %got_litter) {
	$self->put_litter(undef, $got_litter{$litter_name}->[0]);
    }
}

# For new mating only: Set/get the current "preferred colony" for this card
sub newForColony {
    my $self = shift;
    if (@_) {
	my ($colony, $origin, $info) = @_;
	$self->privateData->{newColony} = [$colony, $origin];
warn "Made default '$colony' from $origin ($info)\n";
    } else {
	my ($colony, $origin) = @{ $self->privateData->{newColony} || [] };
	return wantarray ? ($colony, $origin) : $colony;
    }
}

# Notification that parents or cardname have changed.  Recalculate the
# defaults for the mating fields.
# nb. Won't loop if called from "finish" (a user edit) and only prods non-user-edit fields
sub redefaultFields {
    my $self = shift;

    # Check parents for a colony name
    my ($newColony, $origin) = $self->newForColony;
    if (!defined $origin || $origin eq 'parents') {
	my @parentNames = safemap { shift->getVisibleMouseName } $self->getRow(qw(par_M par_F));
	my ($parentColony) = safemap {
	    my $pname = shift;
	    ($pname =~ $COL_PAT ? ($1) : ());
	} @parentNames;
	$self->newForColony($parentColony, 'parents', "(@parentNames)")
	  if defined $parentColony;
    }

    foreach my $n (qw(LicencePPL LicencePIL LicenceUser Licence19b cardname)) {
	$self->Subwidget($n)->retryDefault; # XXX: can I do this to all the fields, then?  In commit order?
    }
}


# tk callback; button disabled when there's no card, or if we have a
# new litter in progress already
sub op_add_litter {
    my $self = shift;

    $self->put_litter(undef, undef);
    $self->fieldsUpdate;
}


# Return list of hash elements: key = (current or requested) littername, value = [ grid_row, object ]
# Object will be ATR::MicePE::LitterGroup for stored litters, undef for a new entry
sub getLitterList {
    my $self = shift;
    my @return;
    my $L = $self->{litter_map};
    for (my $i=0; $i<@$L; $i++) {
	if (UNIVERSAL::isa($L->[$i], 'ATR::MicePE::LitterGroup')) {
	    push @return, $L->[$i]->getLitterName,   [ $i, $L->[$i] ];
	} else {
	    push @return, ${ $L->[$i]->getTextRef }, [ $i, undef    ];
	}
    }
    return @return;
}


#  $litter_obj = ATR::MicePE::LitterGroup, or
#                undef for litter existing only in the GUI (new litter)
#  $rownum = row-number of container made here earlier, or
#                  undef if litter is not yet in the GUI
sub put_litter {
    my ($self, $litter_obj, $rownum) = @_;

    my $lits_f = $self->Subwidget('litters_f');
    my $L = $self->{litter_map};

    my %widg; # key = column name from @LITS_HEAD; value = UpdateEntry widget
    if (defined $rownum) {
	# Pull out existing widgets for the row, file them in %widg
	%widg = $self->litter_row_widgets($rownum);

    } else {
	# No GUI, need to make the widgets
	$rownum = @$L;
	for (my $i=0; $i<@LITS_HEAD; $i++) {
	    my $colname = $LITS_HEAD[$i];
	    $widg{$colname} = $lits_f->UpdateEntry(Name => $colname,
						   -label => $colname, -labelpos => 'none',
						   -labelfont => $self->getFont('label'),
						   -datafont  => $self->getFont('data'),
						  );
	    $widg{$colname}->grid(-row => $rownum+1, -col => $i, -sticky => 'nsew');
	    my $type = 'entry';
	    $type = 'date' if $colname eq 'DOB';
	    $widg{$colname}->setFieldDisplay($type);
	}
    }

    # Set the widgets to do database stuff (we should always have a 'card' set)

    # Any widget may need to read before the $litter_obj exists, but
    # only the name ('#') may need to create on -save.  Created litter
    # will be stash to $litter_obj and relevant data structs.

# XXX: (get a proper accessor for gui value)

    $self->{litter_map}->[ $rownum ] = defined $litter_obj ? $litter_obj : $widg{'#'}; # old voodoo .. I forget the details

    $widg{'#'}->setFieldDisplay(defined $litter_obj ? 'button' : 'entry'); # XXX: '#' isn't a good label, neither is 'id'

# XXX: need to set 'button' on doDisplayCommit, restore 'entry' during $rollbackAction: these need to be new data accessors: object methods by any other name
    $widg{'#'}->setFieldAccessors(-load => sub {
				      return undef if !$litter_obj;
				      return $litter_obj->getLitterName;
				  },
				  -click => sub {
				      my @cards = ATR::MicePE::Weaning->listForLitter($litter_obj->getLitterName);
				      my @menuitems;
				      my $lastType;
    foreach my $item (sort { $b->[0] <=> $a->[0] || $a->[1] <=> $b->[1] } @cards) {
	my ($type, $peid) = @$item;
	push @menuitems, [ Separator => "" ]
	  if defined $lastType && $lastType != $type;
	$lastType = $type;

# XXX:UPDATE create on demand is bad: split reading (no commit) and writing (whole-card commit); need to fix/delete old data before removing
# $self->commitRealSoon(0); # XXX: only commit when created
# this has gone away because we're not calling getVirtualWeaningId anymore...

	my $card = ATR::MicePE::Weaning->findByPeId($peid);
	my $cardname = $card->getCardName;
	my $sex = ($card->getIntendedSex)[1];
	my $mice = $card->getCurrentMice;
	push @menuitems, [ Button => "Show $cardname ($sex card, $mice mice)", -command =>
			   sub {
			       ATR::Tk::AtrMain->ShowPeCard($card);
			   }
			 ];
    }
    push @menuitems, [ Button => "(found no cards)", -state => 'disabled' ] if !@menuitems;
				      return (Name => 'litter_menu', -menuitems => \@menuitems);
				  },
				  -default => sub {
				      my @already_adding;
				      foreach my $rowItem (@{ $self->{litter_map} }) {
					  # Ignore litters already on card, it knows of these
					  next unless $rowItem->isa('ATR::Tk::UpdateEntry');
					  my $val = ${ $rowItem->getTextRef }; # XXX: dirty private access (goes away with CardRowLitter)
					  push @already_adding, $val if defined $val && $val ne "";
				      }
				      $self->pair->getNextLitterName(@already_adding);
				  },
				  # Read-only when a button; writable initially when there's no LitterGroup
				  -finish => sub {
				      my $newval = shift;
				      $newval =~ s/^\s*|\s*$//; # XXX:DUP to createBlank
				      return "Please set the full litter name" unless $newval =~ /[A-Z].*\d/i;
				      return undef;
				  },
				  -save => sub {
				      my ($oldval, $newval) = @_;

				      # GUI should call us once only, if ever
				      die "Multiple litter-create detected: old=".$litter_obj->debugId.", new=$newval"
					if $litter_obj;

				      my $newgrp = $self->pair->addLitter($newval);
my $vwean = $newgrp->getVirtualWeaningId; # ensure v-wean card exists .. XXX should be done after DOB set and mice made? unless they catch themselves up later.
				      # XXX:SPEC when is the v-wean to be printed?
				      # Stash in our data structure XXX: rollbackAction here!
				      $litter_obj = $self->{litter_map}->[ $rownum ] = $newgrp;
				      $widg{'#'}->setFieldDisplay('button'); # XXX: this should be in (each of?) doDisplayCommit/rollbackAction/postDbLoad_GuiRefresh
				  },
				 );

    $widg{DOB}->setFieldAccessors(-load => sub {
				      return undef if !$litter_obj;
				      my $dob = $litter_obj->getLitterDateBirth;
				      return undef if !$dob;
				      return $dob->getUI
				  },
				  -default => sub { ATR::Date->now->getUI },
				  # XXX: Prefer to leave time part in DOB, but UpdateFieldDate doesn't support this
				  -finish => sub {
				      my $newval = shift;
				      return undef if $newval; # widget ensures it's a valid date or null
				      return "Please set the litter's Date of Birth"; # mandatory field
				  },
				  -save => sub {
				      my ($oldval, $newval) = @_;
				      # XXX: when DOB already set, what's happening with existing pup DOBs?
				      $litter_obj->setLitterDateBirth($newval);
				  });
    $widg{Pups}->setFieldAccessors(-load => sub {
				       return "" if !$litter_obj;
				       my $count = $litter_obj->getPupCount;
				       return defined $count ? $count : "";
				   },
				   -finish => sub {
				       my $newval = shift;
				       return "Pup count should be a number (0-9999) or blank"
					 unless $newval =~ /^\d{0,4}$/;	# XXX: MicePE should validate for us!
				       # Any number is good for creating the litter
				       return undef if !$litter_obj;
				       my $oldval = $litter_obj->getPupCount || 0;
				       return "Removing pups must be done from the litter, for now"
					 if $oldval > $newval;
				       # XXX: can have ($oldval == $newval && hasEdit) which is silly
				       return undef;
				   },
				   -save => sub {
				       my ($oldval, $newval) = @_;
				       $litter_obj->setPupCount($newval);
				   });
    $widg{Weaned}->setFieldAccessors(-load => sub {
					 return "" if !$litter_obj;
					 # XXX:DUP with ATR::Report::XML
					 my @dates = sort { $a->cmp($b) } $litter_obj->getWeanedDates;
					 my (%count, %date);
					 foreach my $d (@dates) {
					     my $u = $d->getUI;
					     $count{$u} ++;
					     $date{$u} = $d;
					 }
					 @dates = keys %date;
					 return join "; ", map {"$_ ($count{$_})"} @dates;
				     },
# XXX: wean date needs MicePE support for read, write-from-undef (do transfer?) and overwrite-existing
#					 -save => sub {
#					     my ($oldval, $newval) = @_;
#					     $litter_obj->setWeanedDate($newval);
#					 }
				    );

    $widg{Comments}->setFieldAccessors(-load => sub {
					   return "" if !$litter_obj;
					   return $litter_obj->getFreeRemark('Comment');
				       },
				      -finish => sub { undef },
				      -save => sub {
					  my ($oldval, $newval) = @_;
					  $litter_obj->setFreeRemark('Comment', 1, $newval); # XXX: the vague data model
				      });

    foreach my $w (values %widg) {
	$w->checkDb if $w->isa('ATR::Tk::UpdateEntry'); # XXX: widgets need to keep themselves up to date, now we have whole-card commit
    }
}

sub litter_row_widgets {
    my ($self, $rownum) = @_;
    my $lits_f = $self->Subwidget('litters_f');
    my @widg = $lits_f->gridSlaves(-row => $rownum+1);
    my %widg;
    foreach my $w (@widg) {
	if ($w->isa('ATR::Tk::UpdateEntry')) {
	    my $name = $w->cget('-label');
	    $widg{$name} = $w;
	} else {
	    warn "Ignoring unknown widget $w at ".$w->PathName." on row $rownum";
	}
    }
    return %widg;
}

1;
