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

use Tk::Derived;
use ATR::Tk::UpdateEntry;
use ATR::Tk::CardRowMouse;

use ATR::Util;

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

# $Id: WeaningCard.pm,v 1.35 2005/04/13 14:04:05 mca Exp $

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


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

# XXX: Other call modes: "make a new one with ..."

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

# Button area XXX: share with MatingCard, argh more multiple inheritance argh ... or put that in AtrCard
    my $ops = $self->Subwidget('operators');
    $ops->Button(-text => 'Transfer',
		 -font => $self->getFont('furniture'),
		 -command => [ $self, 'op_transfer' ])->pack(-side => 'left');
    my $sex_split_b = # show/hide from intendedSex -load accessor
      $ops->Button(-text => 'Split by sex',
		   -font => $self->getFont('furniture'),
		   -command => [ $self, 'op_transfer', 'by_sex' ])->pack(-side => 'left');
    $self->Advertise(sex_split_b => $sex_split_b);
    $self->Advertise(go_mating_b => # show/hide in _fieldsUpdate
		     $ops->Button(-text => 'Jump to mating',
				  -font => $self->getFont('furniture'),
				  -command => [ $self, 'op_jump_mating' ])
		     ->pack(-side => 'left'));

    $ops->Button(-text => 'Debug columns', -command => [ $self, 'op_sinceuntils' ])->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 => "Weaning card: ",
				      -labelpos => 'w')
		     ->pack(-side => 'left', -fill => 'y')
		    );
    $self->Advertise('intendsex',
		     $hf->UpdateEntry(-class => 'title', Name => 'intendsex',
				      -labelfont => $self->getFont('title'),
				      -datafont  => $self->getFont('titledata'),
				      -label => "Sex: ",
				      -labelpos => 'w')
		     ->pack(-side => 'left', -fill => 'y')
		    );


# Licence area
    my $card_f = $self->Subwidget('card_f');
    my $lf = $card_f->Frame(Name => 'lic_f') # config by optdb
      ->pack(-side => 'right', -fill => 'none', -anchor => 'se');

    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 => 'both', -expand => 0);
	$self->Advertise("Licence$n", $w);
    }

# Barcode area
    $self->Advertise('barcode', $lf->BarcodeImage(-balloon => $self->tlBalloon))
	->pack(-before => ($lf->packSlaves)[0],
	       -side => 'top',
	       -anchor => 'ne',
	       -fill => 'none');

# Litter mice frame
    my $mice_f = $card_f->Frame(Name => 'mice_f') # config by optdb
      ->pack(-side => 'left', -fill => 'none', -anchor => 'nw');
    $self->Advertise(mice_f => $mice_f);
}


sub _setCard {
    my ($self, $card) = @_;
    die "Method needs 1 arg" unless @_ == 2;
    if (defined $card) {
	my $want_type = 'ATR::MicePE::Weaning';
	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 card  { $_[0]->privateData->{card} }
sub haveCard { defined $_[0]->card }

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

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


sub getAllParts {
    my $self = shift;

    my @cardFields = safemap { $self->Subwidget(shift) }
      qw(cardname intendsex LicencePPL LicencePIL LicenceUser Licence19b);

    my @miceRows = $self->getRow; # all rows

    return (@cardFields, @miceRows);
}


sub newMouseRow {
    my ($self, $rowName) = @_;
    my $row = ATR::Tk::CardRowMouse->new($rowName);

    $row->setColumns(qw(name sex dob geno pheno ear coat dna comm)); # XXX: row should figure this out itself (ask the card?)
    # since until

    $row->makeWidgets($self->Subwidget('mice_f'),
		      -labelfont => $self->getFont('label'),
		      -datafont  => $self->getFont('data'),
		     );
    $self->setRow($rowName => $row);
    return $row;
}

sub op_sinceuntils { # prototype column-set changer
    my $self = shift;
    my @row = $self->getRow;
    my $present = grep { $_ eq 'since' || $_ eq 'until' } $row[0]->columns;
    foreach my $R (@row) {
	my @oldCol = $R->columns;
	$R->setColumns(($present ? () : qw(since until)),
		       grep { $_ ne 'since' && $_ ne 'until' } @oldCol);
	$R->makeWidgets($self->Subwidget('mice_f'),
			-labelfont => $self->getFont('label'),
			-datafont  => $self->getFont('data'),
		       );
    }
    $self->fieldsUpdate; # does show(1), fieldsUpdate, sets headings for each row
    # XXX: Need to modify the column-set of the next created row; another reason to hold column-set per card
}


sub _fieldsUpdate {
    my $self = shift;

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

# Set up loose (non-row) card fields

    # Cardname - saves first so ensure card exists
    my $w = $self->Subwidget('cardname');
    $w->setFieldDisplay($self->haveCard ? 'label' : 'entry');
    $w->setFieldAccessors
      (-load => sub {
	   return undef if !$self->haveCard;
	   return $self->card->getCardName },
       -default => sub { "" }, # blank is "" to ensure 'modified' state
       -finish => sub {
	   my $newval = shift;
	   return undef if $newval eq "";
	   return "XXX: Intended litter not yet implemented - not sure whether this is the right field";
       },
       -save => sub {
	   my ($oldval, $newval) = @_;
	   die "Double-create for weaning card, new=$newval old=$oldval" if $self->haveCard;
	   my $card = ATR::MicePE::Weaning->createBlank();
	   $self->_setCard($card);
       });
    $w->checkDb;

    # Intended sex
    $w = $self->Subwidget('intendsex');
    $w->setFieldDisplay('entry');
    $w->setFieldAccessors
      (-load => sub {
	   return undef if !$self->haveCard;
	   my ($sexLtr, $sexLong) = $self->card->getIntendedSex;

	   # Bodge: ensure button is on display/hidden when irrelevant
	   my $split_b = $self->Subwidget('sex_split_b');
	   if ($sexLtr eq 'U') { $split_b->pack(-side => 'left') }
	   else { $split_b->packForget }

	   return $sexLong || 'Unknown';
       },
       -finish => sub { undef }, # XXX: do sexes check
       -save => sub {
	   my ($oldval, $newval) = @_;
	   $self->card->setIntendedSex($newval);
       });
    $w->checkDb;

    # Licence info XXX:DUP mostly shared with mating
    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->card->$getter;
	       return defined $val ? $val : "";
	   },
	   # XXX: Default weaning licencing from litter?  May belong with splitter code, or shared with .. in Weaning.pm ?
	   -finish => sub { undef }, # no checking
	   -save => sub {
	       my ($oldval, $newval) = @_;
	       $self->card->$setter($newval);
	   });
	$w->checkDb;
    }


    # V-Wean to Mating link button
    my ($litterName, $virtual) = $self->haveCard ? $self->card->getIntendedLitter : ();
    if ($virtual) {
	$self->Subwidget('go_mating_b')->pack(-side => 'left');
    } else {
	$self->Subwidget('go_mating_b')->packForget;
    }


# Set up the mice
    # Get the current PennedMouse list; XXX:CACHE objects will be re-used from previous calls
    # XXX: Later, get all visits and display the current; needed for v-wean to show alumni
    my %db_mice; # key = mouseName, value = PennedMouse
    foreach my $P ($self->haveCard ? $self->card->getCurrentMice : ()) {
	my $mouseName = $P->getMouse->getMouseName;
	# While we get only current mice, this won't happen - mouse can't be current twice
	die "XXX: Mouse $mouseName on card twice (last: ".$P->debugId.")\nCan't cope"
	  if $db_mice{$mouseName};
	$db_mice{$mouseName} = $P;
    }

    # Get current display list
# ensure a blank row later
    my %ui_mice; # key = mouseName, value = row
    my @blank_rows;
    foreach my $R ($self->getRow) {
	my $mouseName = $R->getVisibleMouseName;
	if ($mouseName eq '') {
	    # May have been not-blank recently, but won't have a Penned
	    push @blank_rows, $R;
	} else {
	    # Mice already on card can't be on twice, as above
	    # Rows must avoid naming a mouse already in the GUI when entered new mouse names
	    die "Mouse $mouseName appears twice on this card, this should not happen"
	      if $ui_mice{$mouseName};
	    $ui_mice{$mouseName} = $R;
	}
    }

    # Pair them up by mousename
    my %micename; @micename{(keys %ui_mice, keys %db_mice)} = ();
    foreach my $mouseName (keys %micename) {
	my $row    = $ui_mice{$mouseName};
	my $penned = $db_mice{$mouseName};
	if ($penned && !$row) {
	    # Need to make a new UI row
	    my $rowName = "penned_".$penned->getSubPeID; # unique & handy for debugging
	    $ui_mice{$mouseName} = $row = $self->newMouseRow($rowName);
	}
	if ($penned) {
	    # a DB mouse, has a row now - check data is set
	    $row->setPenned($penned);
	    $row->setAdopted($penned->getMouse); # XXX: Should be implicit in setPenned
	} elsif ($row->penned) {
	    # Old UI row, DB data has gone.  Remove it.  Later, can hide it instead.
	    # XXX: Check for unsaved changes!
#	    $row->destroy;
# XXX: rows have no destroy method; row fails to go out of scope
# Let it go out of scope? Use DESTROY to see it actually leaves and takes the widgets away
	    $self->setRow($row->name => undef);
	    delete $ui_mice{$mouseName};
	    # hasn't gone out of scope yet (ignoring $row which is just here) .. nail the widgets.. ick
	    $self->afterIdle
	      (sub {
		   my %w = %{ $row->_widgets };
		   foreach my $w (values %w) {
		       $w->setFieldAccessors(); # zap the CODE refs which contain lexicals...  argh
		       $w->destroy;
		   }
	       });
	} # else: this is a fresh row with editable mouse name
    }

    # Ensure we have enough blank rows
    while (1 > @blank_rows || 10 > @blank_rows + keys %ui_mice) {
	my $rowName = "blank_".(@blank_rows + keys %ui_mice); # unique & mostly meaningless
	push @blank_rows, $self->newMouseRow($rowName);
    }
    # Remove spare blank rows, provided they're empty
    while (@blank_rows > 1 && (@blank_rows + keys %ui_mice) > 10) {
	my $drop_row;
	for (my $i=$#blank_rows; $i>0; $i--) { # XXX:SLOW O(N^2) in blank rows!
	    if (!$blank_rows[$i]->hasEdit) {
		$drop_row = splice(@blank_rows, $i, 1);
		last;
	    }
	}
	last if !defined $drop_row;
	$self->setRow($drop_row->name => undef);
#	$drop_row->destroy; # XXX:LEAK references persist
    }
    # Could remove blanks here... XXX: need a CardRow->destroy & $self->unsetRow

    # Sort mice by name
    my @all_rows = ( (map { $ui_mice{$_} }
		      # XXX: We have the mice objects so use Mouse->cmpByName
		      sort { length($a) <=> length($b) || $a cmp $b } keys %ui_mice),
		     sort { my ($A, $B) = ($a->name, $b->name);
			    length($A) <=> length($B) || $A cmp $B }
		     @blank_rows
		   );

    # Attach the rows in order, put heading on top row
    for (my $i=0; $i < @all_rows; $i++) {
	my $row = $all_rows[$i];
	my $old_rownum = $row->gridRow;
#	next if defined $old_rownum && $old_rownum == $i;
	$row->setGridRow($i);
	$row->configAll($i == 0
			? (-labelpos => 'n')
			: (-labelpos => 'none'));
	$row->show(1);
    }

    foreach my $row (@all_rows) { $row->fieldsUpdate }
}

sub op_jump_mating {
    my $self = shift;
    my $card = $self->card;
    my ($litterName, $virtual) = $card->getIntendedLitter;
    die "'Find mating' for plain weaning card is not implemented" # XXX:USRTHROW simply not available yet
      unless $virtual;

    my $litter = $self->card->getLitterGroup4Virtual;
    die "Failed to find litter for ".$card->debugId unless $litter; # XXX:USRTHROW data error, if $virtual
    my $mating = $litter->getMating;
    ATR::Tk::AtrMain->ShowPeCard($mating);
}


1;
