package ATR::Tk::AnimalTransfer;

use strict;
use warnings;

# Could probably be a Tk::Frame instead, if the caller expected that
use base qw(Tk::Derived Tk::Toplevel);
Tk::Widget->Construct('AnimalTransfer');


=head1 NAME

ATR::Tk::AnimalTransfer - top level transient dialog for moving animals

=head1 DESCRIPTION

Grid of animals (down) and cards (across), with radio buttons for
where the animal is / should be; plus some buttons.

=head1 ATTACHMENT

Animals are attached to the grid as rows, as managed by the
::MouseLine package in this module file.  See C<addPenned> and
C<getLines>.

The sort order is arranged so that these will make sense to the user.
See C<setSort> and C<getSortOrder>.

=cut

# $Id: AnimalTransfer.pm,v 1.22 2005/03/03 09:52:11 mca Exp $

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

sub Populate {
    my ($self, $args) = @_;
    $self->SUPER::Populate($args);

    $self->transient($self->Parent->toplevel);
    $self->group($self->Parent->toplevel); # XXX: do I want this instead of/as well as transient?
    $self->minsize(400, 240);
    $self->protocol('WM_DELETE_WINDOW' => [ $self, 'cancel' ]);

    $self->title("Animal transfer"); # could list card names (during updateGUI)...

# Main grid
    # When this gets too wide, need Scrolled('Pane')...
    my $grid_f = $self->Frame(Name => 'grid_f',
			      -background => 'white')
      ->pack(-side => 'top', -fill => 'both', -expand => 1, -anchor => 'nw');
    $self->privateData->{grid_f} = $grid_f;

# Action buttons
    my $btn_f = $self->Frame(Name => "buttons_f") # config by optdb
      ->pack(-side => 'bottom', -fill => 'x');
    $btn_f->Button(-text => 'Commit', -command => [ $self, 'doTransfer' ])
      ->pack(-side => 'right');

    $btn_f->Button(-text => 'Cancel', -command => [ $self, 'cancel' ])
      ->pack(-side => 'right');
    $self->bind('<Key-Escape>' => [ $self, 'cancel' ]);

    my $histDate = $self->UpdateEntry(-label => "Transfer date", -labelpos => 'n')
      ->pack(-side => 'right');
    $histDate->setFieldDisplay('date');
    $histDate->setFieldAccessors(-load => sub { ATR::Date->now->getUI });
    $histDate->clearGui;
#    $self->Label(-text => "XXX: Add historic date set widget here...")->pack(-side => 'bottom', -fill => 'x');

    $self->queueUpdate;
}

sub grid { $_[0]->privateData->{grid_f} }

sub grid_bg {
    my $self = shift;
    return $self->privateData->{grid_bg} ||=
      $self->grid->Frame(Name => 'grid_bg', -bg => 'lightgrey', -border => 2, -relief => 'raised');
}

sub queueUpdate {
    my $self = shift;
    my $P = $self->privateData;
    return 0 if $P->{queueUpdate}; # already set
    $P->{queueUpdate} = 1;
    $self->afterIdle(sub { $self->updateGUI });
}

sub updateGUI {
    my $self = shift;
    $self->privateData->{queueUpdate} = 0;

    # Rows:
    # 0 = column heads, 1 = grid_bg top, 2+@penneds = grid_bg bottom
    # 2 = first data row, 1+@penneds = last data row
    my @penneds = sort { ATR::MicePE::Mouse->cmpByName($a->mouse, $b->mouse) } $self->getLines;
    my @row = (2 .. 1+@penneds); # deals with zero items OK
    for (my $i=0; $i<@penneds; $i++) {
	$penneds[$i]->grid_row($row[$i]);
	$penneds[$i]->updateGUI($self);
    }

    # Attach the background, at the back of the pile
    my ($data_min, $data_max) = (1, 2+@penneds); # XXX: hardwired row numbers
    my %hdr_col = $self->getColumnInfo('header');
    my ($card_min, $card_max) = @hdr_col{qw{bg_left bg_right}};

    # ...if there are cards and mice
    if (defined $card_min && defined $data_min) {
	my $grid_bg = $self->grid_bg;
#warn "gridbg on col=($card_min, $card_max) row=($data_min, $data_max)\n";
	$grid_bg->lower(($self->grid->children)[0]);
	$grid_bg->grid(-row => $data_min, -rowspan => $data_max - $data_min + 1,
		       -col => $card_min, -columnspan => $card_max - $card_min + 1,
		       -sticky => 'nsew');
	# Set minimum sizes for the rows & columns containing the edges of grid_bg
# XXX: ought to un-minsize them when they're not being used for grid_bg edges
	my $grid_f = $self->grid;
	$grid_f->gridColumnconfigure($card_min, -minsize => 4);
	$grid_f->gridColumnconfigure($card_max, -minsize => 4);
	$grid_f->gridRowconfigure($data_min, -minsize => 4);
	$grid_f->gridRowconfigure($data_max, -minsize => 4);
    }

    # XXX: rowhead_cardName label with rowspan

    # Attach card headers
    my $cards = $self->getCardsInfo;
    my %data_col = $self->getColumnInfo('row');
    foreach my $colname (keys %$cards) {
	my $widg = $cards->{$colname}->[2]; # XXX: Object!
	$widg->grid(-row => 0, # XXX: hardwired row numbers
		    -col => $data_col{$colname});
    }

    # Provokes an afterIdle updateGUI if it adds another card
    $self->setupBlankCards;
}

sub doTransfer {
    my $self = shift;

    # XXX: rollback should only need to invalidate my model,
    # and the reload should fix up the GUI.
    # For now, collect some code which can patch up the GUI and trash the broken data
    my $rollbackActions = [];

    my $prob;
    $prob = $@ unless eval {
	my $when = ATR::Date->now; # XXX: link to historic date
	foreach my $row ($self->getLines) {
	    $row->doTransfer($when, $rollbackActions);
	}
	1;
    };

    warn "XXX: GUI cards not updated!\n"; # XXX: Display confirmation of change?  invalidate all objects anyway?

    if (!$prob) {
	# debug menu sets commit/rollback mode
	my $result = main::doCommit();
	$prob = "debug mode rollback" if !defined $result;
    }

    # If we don't destroy, we will need to regenerate all the changed mouse rows
    $self->destroy if !$prob;

    if ($prob) {
	ATR::MicePE->rollbackAll("error");
	eval {
	    foreach my $action (@$rollbackActions) {
		$action->();
	    }
	};
	my $rollbackProb = $@;
	warn "Transfer failed: $prob"; # XXX:USRTHROW we would need more detail, and a catcher
	warn "Changes were NOT saved (database rollback)\n";
	if ($rollbackProb) {
	    # We couldn't reset all the data in this window
	    warn "Rollback left the transfer window confused: $rollbackProb  I must close it\n";
	    $self->afterIdle(sub { $self->cancel });
	}
    } else {
	$self->bumpCards;
    }
}

sub cancel {
    my $self = shift;
    warn "Cancelled transfer\n";
    $self->destroy;
}

sub bumpCards {
    my $self = shift;
    my @atrCards = @{  $self->privateData->{bumpCards} ||= []  };
    foreach my $guiCard (@atrCards) {
	$guiCard->fieldsUpdate;
    }
}

# may allow multiple source cards... eventually.
sub addSourceCard {
    my ($self, $atrCard, $card) = @_;
    push @{  $self->privateData->{bumpCards} ||= []  }, $atrCard; # XXX: tidy this up.. take $card from this / allow either type? Or do the registry thing.
    $self->privateData->{source} = $card;

    # Generate card column
    # (insert to the cardsInfo structure)
    my $radioValue = $self->getNextRadioValue;
    my ($cardName, $colname);
    if ($card) {
	$cardName = $card->getCardName;
	$colname = "stayCards_".$card->getPeID;
    } else {
	$cardName = "New card";
	$colname = "newCard_$radioValue";
    }
    my $cards = $self->getCardsInfo;
    die "Already have source card '$cardName' for column $colname"
      if exists $cards->{$colname};
    $cards->{$colname} = [ $card,
			   $radioValue++,
			   undef ];
    $self->setCardHeader($colname);

    if ($card) {
	# Generate mouse rows (now the card column has been made)
	foreach my $penned ($card->getCurrentMice) { # XXX: broken for MatingPair
	    $self->addPenned($penned, $card);
	}
    }

    # Update display
    $self->queueUpdate;
}

sub setCardHeader {
    my ($self, $colname) = @_;
    my $cardList = $self->getCardsInfo->{$colname};
    die "Unknown card column '$colname'" unless $cardList;

    my $cardName;
    my $sex;
    if ($cardList->[0]) {
	# Real card - get data to display
	my $card = $cardList->[0];
	$cardName = $card->getCardName;
	$sex = $card->getIntendedSex; # one letter
    } else {
	# Note that a 'real' card can be rolled back and we'll end up back here
	$cardName = "New card";
	$cardName .= " for $cardList->[4]" if $cardList->[4]; # intended litter
	$sex = $cardList->[3]; # may be undef
    }
    $sex = '?' if !defined $sex; # XXX: Use a SexSymbol

    # Ensure column header widget,
    # set properties
    my $widg = $cardList->[2] ||= $self->grid->Label(-class => 'CardGridHeader');
    $widg->configure(-text => $cardName." [$sex]",
		     -wraplength => 80, # screen units
		     # wide enough for "(unweaned)" in current font
		    );

    # XXX: Row group cardname widget
# $grid_f->Label(-text => "g\nr\no\nu\np")->grid(-row => 1, -column => 0, -rowspan => 3, -sticky => 'nsew');
}

sub addPenned {
    my ($self, $penned, $card) = @_;
    my $list = $self->privateData->{lines} ||= [];
    push @$list, ATR::Tk::AnimalTransfer::MouseLine->new($self, $penned, [ $card ]);
}

sub getLines {
    my $L = $_[0]->privateData->{lines};
    return $L ? @$L : ();
}

sub getColumnInfo {
    my ($self, $type) = @_;
    die "getColumnInfo object method needs 1 arg" unless @_ == 2;

    # Fix up column scheme - will become more flexible later
    my %val = $self->getCardRadioValues;
    my $cardCount = scalar keys %val ? (minmax(values %val))[1] + 1 : 0;

    my $dataCol1 = 5;
    my %col = ($type eq 'row'
	       ? (
		  rowhead_mouseName => 1,
		  rowhead_mouseSex  => 2,
		  rowhead_mouseDob  => 3,
		  # map radio buttons in at $dataCol1 + $radio_value
		  (map {( $_ => $val{$_} + $dataCol1 )} keys %val),
		 )
	       : (
		  rowhead_cardName => 0,
		  bg_left => 4,
		  bg_right => $cardCount + $dataCol1,
		 ));

    return wantarray ? %col : \%col;
}

sub minmax { (sort { $a <=> $b } @_)[0, -1] } # XXX: probably for ATR::Util

# Return (live! do not meddle!) hashref of
#   colname => [ $micepe_card, radio_value, $headerwidget ]
# further columns for blank cards with intended info set.. [ $sex, $litterName ]
sub getCardsInfo {
    my ($self) = @_;
    # Data inserted here by addSourceCard
    # "Further columns" tweaked by setupBlankCards
    return $self->privateData->{cardsInfo} ||= {};
}

sub setupBlankCards {
    my $self = shift;
    my $cards = $self->getCardsInfo;

    # Get "new cards" list
    my %used; # key = radiovalue, value = [ MouseLine ]
    my %newCard; # key = radiovalue, value = colname
    my @newCard_colname = grep { !defined $cards->{$_}->[0] } keys %$cards;
    %used    = map {( $cards->{$_}->[1], [] )} @newCard_colname; # initialise to zero use
    %newCard = map {( $cards->{$_}->[1], $_ )} @newCard_colname;

    # Get current selection, mark "blank" usage
    my @lines = $self->getLines; # no particular order
    return if !@lines; # no mice: nothing to do
    for (my $i=0; $i < @lines; $i++) {
	my $line = $lines[$i];
	my $val = $line->getCurrentValue;
	next unless exists $used{$val}; # ignore existing cards
	push @{ $used{$val} }, $line;
    }

    # Ensure we have at least one spare "new card" column
    my @unused_new = grep { @{ $used{$_} } == 0 } keys %used;
    $self->addSourceCard(undef) unless @unused_new;

    # When there is but one mouse on a blank card, we set the "intended" fields
    foreach my $val (keys %used) {
	next unless @{ $used{$val} } == 1;
	my $colname = $newCard{$val};
	my $line = $used{$val}->[0]; # the sole mouse on this blank card

	my $sex = $line->mouse->getSex;
	$sex = 'U' if $sex eq 'N'; # 'Unsexed' card for 'Not yet sexed' mouse
	$cards->{$colname}->[3] = $sex;

	$cards->{$colname}->[4] = $line->mouse->getLitterGroup->getLitterName; # ADOPT
	$self->setCardHeader($colname);
    }
}

# Get Radiobutton 'value' for the next unallocated slot
sub getNextRadioValue {
    my $self = shift;
    my $cardsInfo = $self->getCardsInfo;

    my $next_radio_value = 0;
    foreach my $colname (keys %$cardsInfo) {
	my $radio_value = $cardsInfo->{$colname}->[1];
	next if $next_radio_value > $radio_value;
	$next_radio_value = $radio_value + 1;
    }
    return $next_radio_value;
}

# Return hash[ref] of (columnName => $radio_value)
sub getCardRadioValues {
    my ($self) = @_;
    my $cardsInfo = $self->getCardsInfo;
    my %val = map {( $_ => $cardsInfo->{$_}->[1] )} keys %$cardsInfo;
    return wantarray ? %val : \%val;
}

sub getCardForValue { # XXX: this is a classic object method for the "card column" class I haven't made
    my ($self, $value, $rollbackActions) = @_;
    die "Object method needs 2 args" unless @_ == 3;
    my $cards = $self->getCardsInfo;

    # Get column name for $value (linear search on small hash)
    my $colname;
    foreach my $try_col (keys %$cards) {
	next unless $cards->{$try_col}->[1] == $value;
	$colname = $try_col;
	last;
    }

    # Return create-on-demand MicePE object for card
    my $cardInfo = $cards->{$colname};

    if (!$cardInfo->[0]) {
	# XXX: Rollback the data! Make a "pending updates" object to track these?
	die "Card in column $value '$colname' does not exist, no rollbackActions given, cannot create"
	  unless $rollbackActions;
	my ($sex, $litter) = ($cards->{$colname}->[3],
			      $cards->{$colname}->[4]);
	# or could try using some kind of $method(@args) pending operation list?
	my $card = ATR::MicePE::Weaning->createBlank;
	push @$rollbackActions, sub {
	    $card->invalidate;
	    $cardInfo->[0] = undef;
	    $self->setCardHeader($colname);
	};
	$cardInfo->[0] = $card;
	$card->setIntendedSex($sex);
	$card->setIntendedLitter($litter);
	my $bar = join "", $card->getBarcode;
	warn ">>> Creating weaning card ".$card->getCardName." with barcode $bar\n";
	$self->setCardHeader($colname);
    };

    return $cardInfo->[0];
}

# This is a rather quick'n'dirty implementation, but should hold for now
# It's not going to work if there are already blank cards allocated...
sub setStateBySex {
    my $self = shift;
    if ($self->privateData->{queueUpdate}) {
	# If we're called early, the mouse radio widgets won't exist
	# so we'll defer ourself and hope for the best
	$self->afterIdle(sub { $self->setStateBySex });
	return;
    }

    my %sexVal = ( M => undef, F => undef ); # values to move
    my $nextVal = 1;
    foreach my $line ($self->getLines) {
	my $mouse = $line->mouse;
	my $sex = $mouse->getSex;
	next unless exists $sexVal{$sex};
	$self->setupBlankCards; # ensure blanks are fired up to go
	if (!defined $sexVal{$sex}) {
	    # First mouse of this sex, need to pick a new column for it
	    $sexVal{$sex} = $nextVal ++;
	}
	$line->setCurrentValue($sexVal{$sex});
    }
    # Need to call setupBlankCards after setting each button,
    # so that the first into a blank card will set the sex+litter,
    # and so we'll have the next card available
}


#----------------------------------------------------------------------------
#
# Class for collecting relevant widgets and data for one mouse line
#
# I suppose this would be an inner class, in Java...

package ATR::Tk::AnimalTransfer::MouseLine;

use strict;
use warnings;

use ATR::Tk::SexSymbol;


=head1 ATR::Tk::AnimalTransfer::MouseLine

=head2 new($xfer, $penned, $cardList)

Class constructor method.

$xfer should be the L<ATR::Tk::AnimalTransfer> to which this line is
to be attached.

$penned is an L<ATR::MicePE::PennedMouse> representing a GT 'Penned
Animal' sub-entity.

$cardList is a listref containing the card(s) above this one, highest
first.  (Its members should not be used for trying to re-find the
PennedAnimal sub-entity because we already have that, and hence a way
to get the containing card entity.)

For instance adding a mouse on a virtual weaning card, you may give
the mating card and then the v-wean: this allows mice from two litters
of the same mating to be put in the same transfer window and we have a
chance of sorting all the rows into a useful order:

       / DN53.1 --> (DN53.1a)
 DN53 =
       \ DN53.2 --> (DN53.2a, DN53.2b, ...)

=cut

sub new {
    my ($proto, $xfer, $penned, $cardList) = @_;

    my %vals = $xfer->getCardRadioValues;
    my $cardName = $cardList->[-1]->getCardName;
    my $peId = $cardList->[-1]->getPeID;
    my $radio_value = $vals{"stayCards_$peId"}; # XXX: need a clean way to get the card
    if (!defined $radio_value) {
	die "Could not find default radio value for card '$cardName' in values list (|".
	  (join "|, |", sort keys %vals)."|)";
    }

    my $self =
      {
       penned => $penned,
       cards => [ @$cardList ],

       # Hash of Tk::Radiobutton for this row; this may be
       # too many or not enough, at any time
       radios => {},
       radios_variable => $radio_value, # will be Radiobutton "-variable"
       radios_origin => $radio_value,

       # Row label widgets for which we're responsible
       labels => {},

       grid_row => undef,

       # DO NOT store ref of ATR::Tk::AnimalTransfer object, will
       # create circular reference.  (Or use Scalar::Util::weaken.)
       # Can derive from widget hierarchy if necessary.
       # xfer => $xfer,
      };
    bless $self, ref($proto) || $proto;

    return $self;
}

# Doesn't update to the current mouse location...  but this object is
# currently specific to the PennedAnimal record so we can't easily
# pick up a location on different card anyway.
sub getLocationValue { $_[0]->{radios_origin} }

sub penned { $_[0]->{penned} }
sub mouse { $_[0]->{penned}->getMouse } # ADOPT

# Find our parent object; we don't keep the reference, use Tk instead
sub xfer {
    my $self = shift;
    my %widget = ($self->getLabels, $self->getRadios);
    die "xfer method called too early to find parent" unless scalar keys %widget;

    my $anywidg = $widget{(keys %widget)[0]};
    my $xfer = $anywidg->toplevel;
    die "Can't queue update on $xfer, it is not my transfer window"
      unless UNIVERSAL::isa($xfer, 'ATR::Tk::AnimalTransfer');
    return $xfer;
}

sub makeLabel { # XXX: May be a little slow, could shove it into the idle loop for responsiveness?
    my ($self, $grid_f, $colname) = @_;
    my $L = $self->{labels};
    my $mouse = $self->mouse;
    my $widg;

    if ($colname eq 'rowhead_mouseName') {
	$widg = $grid_f->Label(-text => $mouse->getMouseName);
    } elsif ($colname eq 'rowhead_mouseSex') {
	my $mouseSex = ($mouse->getSex)[1];
	if ($mouseSex =~ /^(fe)?male$/i) { # XXX: jump through hoops because SexSymbol doesn't understand the ATR::MicePE conventions
	    $widg = makeSex($grid_f, lc($mouseSex), 24);
	} else {
	    $widg = $grid_f->Label(-text => $mouseSex);
	}
    } elsif ($colname eq 'rowhead_mouseDob') {
	my $dob = $mouse->getDateBirth;
	my $days = $dob->getDaysOld;
	$widg = $grid_f->Label(-text => $dob->getUI." ($days)");
    }
    return $L->{$colname} = $widg;
}

sub getLabels {%{ shift->{labels} }}
sub getRadios {%{ shift->{radios} }}

sub getCurrentValue { shift->{radios_variable}}
sub setCurrentValue { # XXX: Don't trust the caller to give a valid Value!
    my ($self, $newVal) = @_;
    $self->{radios_variable} = $newVal;
    $self->radioClick;
}

sub makeRadio {
    my ($self, $parentWidg, $name, $value) = @_;
    my $radio = $parentWidg->Radiobutton
      (-variable => \$self->{radios_variable},
       -value => $value,
       -padx => 0, -pady => 0,
       -bg => $value == $self->getLocationValue ? 'green' : 'lightgrey',
       -command => [ $self, 'radioClick' ],
      );
    return $self->{radios}->{$name} = $radio;
}

sub radioClick { $_[0]->xfer->queueUpdate } # XXX: doTransfer with warnings, rollback
# will need to rollback data changes for getCardForValue and perhaps others...  or make hollow MicePE objects

# get/set
sub grid_row {
    my $self = shift;
    my $return;
    if (@_) {
	$return = $self->{grid_row};
	$self->{grid_row} = shift;
    } else {
	my $row = $self->{grid_row};
	die "No grid row defined for ".$self->debugName unless defined $row;
	$return = $row;
    }
    return $return;
}

sub updateGUI {
    my ($self, $xfer) = @_;
    my $grid_row = $self->grid_row;

    # Get column positions
    my %cols = $xfer->getColumnInfo('row');

    # Get existing widgets, by name
    my %widget = ($self->getLabels, $self->getRadios);

    my %values; # populated on demand

    # Nail on the widgets
    foreach my $n (keys %cols) {
	my $widg = delete $widget{$n};
	if (!$widg && $n =~ /^rowhead/) {
	    $widg = $self->makeLabel($xfer->grid, $n);
	} elsif (!$widg) {
	    # Make radio button on demand
	    %values = $xfer->getCardRadioValues unless scalar keys %values;
	    die "Can't get radiovalue for column '$n'" unless defined $values{$n};
	    $widg = $self->makeRadio($xfer->grid, $n, $values{$n});
	}
	my $col = $cols{$n};
	my %G = $widg->gridInfo;

	# Attach
	if (!defined $G{-row} || $G{-row} != $grid_row || $G{-column} != $col) {
	    my @opt = $widg->isa('Tk::Label') ? (-sticky => 'w') : ();
	    $widg->grid(-row => $grid_row, -column => $col,
			-pady => 2, -padx => 2,
			@opt);
	}
    }

    # XXX: left over widgets in %widget .. we don't care much until card columns get removed
}

# "Update".  Called in an eval/rollback.
sub doTransfer {
    my ($self, $when, $rollbackActions) = @_;
    die "Object method needs 2 args" unless @_ == 3;

    my $currentValue = $self->getCurrentValue;
    my $originValue = $self->getLocationValue;
    return 0 if $currentValue == $originValue; # nothing to do

    # These lexicals carry into $rollbackActions...
    my $destCard = $self->xfer->getCardForValue($currentValue, $rollbackActions);
    my $penned = $self->penned;
    $penned->setEndDate($when); # XXX: will be unnecessary once addMouse removes from old location
    $destCard->addMouse(-mouse => $self->mouse,
			-since => $when,
		       );
    # XXX: Link to weaning date - set field or do calculation?
    # XXX: If $destCard were a MatingPair, we need to do extra/different stuff

    push @$rollbackActions, sub {
	$penned->invalidate;
	$destCard->invalidate;
    };
}


1;
