#######################################################################
# This software has been created by Genome Research Limited (GRL).    # 
# GRL hereby grants permission to use, copy, modify and distribute    # 
# this software and its documentation for non-commercial purposes     # 
# without fee at the user's own risk on the basis set out below.      #
# GRL neither undertakes nor accepts any duty whether contractual or  # 
# otherwise in connection with the software, its use or the use of    # 
# any derivative, and makes no representations or warranties, express #
# or implied, concerning the software, its suitability, fitness for   #
# a particular purpose or non-infringement.                           #
# In no event shall the authors of the software or GRL be responsible # 
# or liable for any loss or damage whatsoever arising in any way      # 
# directly or indirectly out of the use of this software or its       # 
# derivatives, even if advised of the possibility of such damage.     #
# Our software can be freely distributed under the conditions set out # 
# above, and must contain this copyright notice.                      #
#######################################################################
#
# dna2gel
#
# Create Digest Gels from DNA Plates
#
# Author: Jennifer Liddle (js10)
#
# $Id: dna2gel.pm,v 1.8 2007/01/30 12:06:00 js10 Exp $
#
# $Log: dna2gel.pm,v $
# Revision 1.8  2007/01/30 12:06:00  js10
# bottoms - forgot to remove the use lib js10 again
#
# Revision 1.7  2007/01/30 12:05:13  js10
# Added the '-session' paramater, plus other bug fixes
#
# Revision 1.6  2007/01/29 16:47:37  js10
# fixed typo in enzyme names [FX: blush]
#
# Revision 1.5  2007/01/29 16:35:06  js10
# added a changeStatus(2) for the rdrequest record.
#
# Revision 1.4  2007/01/29 15:06:17  js10
# Ooops! Left the 'use lib js10' in by mistake again
#
# Revision 1.3  2007/01/29 14:43:00  js10
# ja1 requested changes
#
# Revision 1.2  2007/01/25 17:26:30  js10
# removed a use lib 'js10' left in by mistake
#
# Revision 1.1  2007/01/25 16:08:13  js10
# changes mostly (but not exclusively) for dna2gel
#
#

package dna2gel;

use Tk::widgets qw/Frame Entry Button/;
use base qw/Tk::Derived Tk::DialogBox/;

use strict;
use warnings;

Construct Tk::Widget 'dna2gel';

#use lib '/nfs/team71/psg/js10';
use Time::localtime;
use Date::Manip qw(ParseDate UnixDate);
use GTx;
use SqlEngine2;
use Tapir::rdgel;
use Tapir::rdrequest;
use Tapir::dnaprep;
use Checkbarcode2;

$| = 1;

my %map = (     # mapping from source (plate) to target (gel lane)
'a1'    =>  1,
'a2'    =>  2,
'a3'    =>  3,
'a4'    =>  4,
'b1'    =>  6,
'b2'    =>  7,
'b3'    =>  8,
'b4'    =>  9,
'c1'    => 11,
'c2'    => 12,
'c3'    => 13,
'c4'    => 14,
'd1'    => 16,
'd2'    => 17,
'd3'    => 18,
'd4'    => 19,
'e1'    => 21,
'e2'    => 22,
'e3'    => 23,
'e4'    => 24,
'f1'    => 26,
'f2'    => 27,
'f3'    => 28,
'f4'    => 29,
'g1'    => 31,
'g2'    => 32,
'g3'    => 33,
'g4'    => 34,
'h1'    => 36,
'h2'    => 37,
'h3'    => 38,
'h4'    => 39,
'a5'    => 41,
'a6'    => 42,
'a7'    => 43,
'a8'    => 44,
'b5'    => 46,
'b6'    => 47,
'b7'    => 48,
'b8'    => 49,
'c5'    => 51,
'c6'    => 52,
'c7'    => 53,
'c8'    => 54,
'd5'    => 56,
'd6'    => 57,
'd7'    => 58,
'd8'    => 59,
'e5'    => 61,
'e6'    => 62,
'e7'    => 63,
'e8'    => 64,
'f5'    => 66,
'f6'    => 67,
'f7'    => 68,
'f8'    => 69,
'g5'    => 71,
'g6'    => 72,
'g7'    => 73,
'g8'    => 74,
'h5'    => 76,
'h6'    => 77,
'h7'    => 78,
'h8'    => 79,
'a9'    => 81,
'a10'   => 82,
'a11'   => 83,
'a12'   => 84,
'b9'    => 86,
'b10'   => 87,
'b11'   => 88,
'b12'   => 89,
'c9'    => 91,
'c10'   => 92,
'c11'   => 93,
'c12'   => 94,
'd9'    => 96,
'd10'   => 97,
'd11'   => 98,
'd12'   => 99,
'e9'    =>101,
'e10'   =>102,
'e11'   =>103,
'e12'   =>104,
'f9'    =>106,
'f10'   =>107,
'f11'   =>108,
'f12'   =>109,
'g9'    =>111,
'g10'   =>112,
'g11'   =>113,
'g12'   =>114,
'h9'    =>116,
'h10'   =>117,
'h11'   =>118,
'h12'   =>119,
);


########################################################################
## Standard Tk mega widget method for creating this mega widget and
## initialising the super class widget.
########################################################################
sub ClassInit {
    my ($class,$mw) = @_;
    $class->SUPER::ClassInit($mw);
}

########################################################################
## Standard Tk mega widget method for defining mega widget
## characteristics and capturing arguments unknown to Tk.
########################################################################
sub Populate {
    my ($self,$args) = @_;

    $self->{_email} = delete $args->{-email};
    $self->{_dbh} = delete $args->{-dbh};
    $self->{_gtx} = delete $args->{-gtx};
	if ($args->{-session}) {
		$self->{_session} = delete $args->{-session};
	} else {
		$self->{_session} = $$;
	}

	$args->{-title} = 'Create Gel from DNA plate';
	$args->{-buttons} = ['Submit', 'Cancel'];
	$args->{-default_button} = '';

	die "-email not supplied" if !$self->{_email};
	die "-dbh not supplied" if !$self->{_dbh};
	die "-gtx not supplied" if !$self->{_gtx};

	$self->SUPER::Populate($args);
	my $f = $self->Frame()->pack();
	$f->Label(-text => 'DNA plate')->pack(-side=>'left');
	$self->{dnaW} = $f->Entry(-width=>20)->pack(-side=>'left');
	$self->{HindIII} = $f->Checkbutton(-text => 'HindIII',
	                                             -variable => \$self->{HindIIIV},
	                                             -padx => 15)->pack(-side=>'left');
	$self->{BamHI} = $f->Checkbutton(-text => 'BamHI',
	                                           -variable => \$self->{BamHIV},
	                                           -padx => 15)->pack(-side=>'left');
	$self->{EcoRI} = $f->Checkbutton(-text => 'EcoRI',
	                                           -variable => \$self->{EcoRIV},
	                                           -padx => 15)->pack(-side=>'left');
	$self->{statusW} = $self->Status(-selfpack=>1);
	$self->{HindIIIV} = 1;
	$self->{dnaW}->bind('<Return>' => sub { normalise($self); } );
	$self->{dnaW}->focus();

	$self->{dnaprep} = new Tapir::dnaprep($self->{_dbh}, $self->{_session});
	$self->{rdgel} = new Tapir::rdgel($self->{_dbh}, $self->{_session});
	$self->{rdrequest} = new Tapir::rdrequest($self->{_dbh}, $self->{_session});

	$self->{se} = new SqlEngine2;
}

sub Show
{
	my $self = shift;
	my $valid = 0;
	my @idGels;

	my $old_focus = $self->focusSave;
    my $old_grab = $self->grabSave;
    $self->Subwidget("top")->pack;
    $self->Subwidget("bottom")->pack;

    $self->Popup();
	$self->grab;
	$self->focus;

	$self->{statusW}->show();	# clear error message

	eval {
	while (!$valid) {
		$self->waitVariable(\$self->{'selected_button'});
		$self->Callback(-command => $self->{'selected_button'});

		if ($self->{"selected_button"} ne 'Submit') {
			$valid = 1;
			next;
		}

		my $plateId = normalise($self);

		next if (!$plateId);

		if ($self->{HindIIIV}) {
			my $id = update_db($self, $plateId->{Number}, 'HindIII');
			push @idGels, $id;
		}
		if ($self->{BamHIV}) {
			my $id = update_db($self, $plateId->{Number}, 'BamHI');
			push @idGels, $id;
		}
		if ($self->{EcoRIV}) {
			my $id = update_db($self, $plateId->{Number}, 'EcoRI');
			push @idGels, $id;
		}
		$valid = 1;
	}
	};	# end of eval

	my $msg = $@;
    $self->grabRelease;
    $self->withdraw;
    &$old_focus;
    &$old_grab;
	die $msg if $msg;
	return @idGels;
}

#
# Update the database
# This function is bound to the 'submit' button
#
sub update_db
{
	my $self = shift;
	my $dnaId = shift;
	my $enzyme = shift;

	my $gtx = $self->{_gtx};
	my $dbh = $self->{_dbh};
	my $gelNumber = 0;
	my $gelSize = 1;

	# look up id_person from an email
	my $q = $self->{se}->virtualSqlLib('dna2gel','email2id',
	                                   "select id_person from person where email=?");
	my $idPerson = $self->{se}->getRow($q, [$self->{_email}], $dbh);

	# create a new rdgel record
	while (1) {		# try to find a unique gelname
		$self->{rdgel}->loadRecordByGelname($dnaId.'_'.$enzyme.'_'.++$gelNumber);
		last if !$self->{rdgel}->exists();
	}
	# we're not doing any locking, so it's possible for somebody else to create the gelname
	# before we do, which is why we need the second loop below...
	while (1) {
		$self->{rdgel}->setGelname($dnaId.'_'.$enzyme.'_'.$gelNumber++);
		$self->{rdgel}->setGelsize(121);
		$self->{rdgel}->setMarkerrepeat(5);
		$self->{rdgel}->setOperator($idPerson);
		eval { $self->{rdgel}->insert(); };
		last if !$@;
		next if ($@ =~ /unique constraint/);
		die $@;
	}

	eval {
	my $rdgelId = $self->{rdgel}->getId_rdgel();
	print "Created new rdgel (id = $rdgelId   gelname = ", $self->{rdgel}->getGelname(), ")\n";

	my $rowposQ = $self->{se}->virtualSqlLib('dna2gel', 'rowcol',
	                                         "select maprow, mapcol from rowcol_map where format=96 and id_map=?");

	# look at each well of the DNA plate
	my $idPe = $gtx->getPhysicalEntityId(-idInt => $dnaId, -entityType => GTx::ENT_TYPE_DNA_PLATE);
	die "No such DNA plate" if !$idPe;
	my $subs = $gtx->getSubEntityId(-idPe => $idPe, -idEntityContentsType => GTx::ENT_CONT_TYPE_WELL);
	my @lanes;
	foreach my $well (@$subs) {
		my %laneInfo;
		my $idPrep = $gtx->getInfoValue(-idPe => $well->[0],
		                                -sub => 1,
		                                -idContentType => GTx::CONT_TYPE_DNAPREP,
		                                -reason => GTx::REASON_CONTAINS);
		my $wellId = $gtx->getAttributeValue(-idPe => $well->[0],
		                                     -sub => 1,
		                                     -attributeType => GTx::ATT_TYPE_ID_MAP,
		                                     -reason => GTx::REASON_LOCATION);
		# convert well pos [1..96] into rowcol [a1..h12]
		my ($row,$col) = $self->{se}->getRow($rowposQ, [$wellId], $dbh);

		$self->{dnaprep}->loadRecord($idPrep);
		die "Can't find dnaprep record $idPrep" if !$self->{dnaprep}->exists();
#		print "idPrep = $idPrep  Clonename = ", $self->{dnaprep}->getClonename(), "\n";

		# create rdrequest for each well
		$self->{rdrequest}->setId_dnaprep($idPrep);
		#$self->{rdrequest}->setClonename($self->{dnaprep}->getClonename());
		$self->{rdrequest}->setRequested_by($idPerson);	# IS THIS CORRECT???
		$self->{rdrequest}->setIs_fasttrack(0);
		my $x = ParseDate($self->{dnaprep}->getStatusdate());
		my ($month, $year) = UnixDate($x, '%m', '%y');
		my $sampleRef = $month . '.' . $year . '/' . $self->{dnaprep}->getPrep_number();
#		print "SampleRef = $sampleRef   (from ", $self->{dnaprep}->getStatusdate(), ")\n";
		$self->{rdrequest}->setSample_ref($sampleRef);
		$self->{rdrequest}->setOperator($idPerson);
		$self->{rdrequest}->insert();
		$self->{rdrequest}->changeStatus(2);	# 'In Progress'
		$self->{rdrequest}->link2enzyme($enzyme);
#		print "Created new rdrequest id = ", $self->{rdrequest}->getId_rdrequest(), "\n";
		
		$laneInfo{id_rdrequest} = $self->{rdrequest}->getId_rdrequest();
		$laneInfo{lane} = $map{"$row$col"};
		$gelSize = $laneInfo{lane} if $laneInfo{lane} > $gelSize;	# keep track of max lane number
		push @lanes, \%laneInfo;
	}

	$self->{rdgel}->addLanes(@lanes);
	while ($gelSize % 5) { $gelSize++; }	# round up to include next marker repeat lane
	$self->{rdgel}->updateGelSize($gelSize+1);

	}; 	# end of eval

	if ($@) {
		die $@;
		$self->{statusW}->error($@);
	}

	return $self->{rdgel}->getId_rdgel();
}

#
# This is bound to <Return> from the plate input field
# so it gets called when a barcode is scanned in
#
sub normalise
{
	my $self = shift;

	$self->{statusW}->show();	# clear error message

	my $fullPlateId = $self->{dnaW}->get();
	$self->{dnaW}->delete(0,'end');
	my $plateId = Verifynumber($fullPlateId);
	if ($plateId->{Check}) { $fullPlateId = $plateId->{Type} . $plateId->{Number} . $plateId->{Check}; }
	if (!$plateId->{Check}) {
		$self->{statusW}->error("$fullPlateId: This is not a valid plate number");
		return undef;
	}

	if ($plateId->{Type} ne 'SD') {
		$self->{statusW}->error("$fullPlateId: This is not a DNA Plate");
		return undef;
	}

	if (!$self->{HindIIIV} && !$self->{BamHIV} && !$self->{EcoRIV}) {
		$self->{statusW}->error("You must select one or more enzymes");
		$self->{dnaW}->insert(0,$fullPlateId);
		return undef;
	}

	$self->{dnaW}->insert(0,$fullPlateId);
	return $plateId;
}

