#! /usr/local/bin/perl 
#######################################################################
# 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.                      #
#######################################################################

# $Id: owl_printmap1.pm,v 1.23 2002/08/14 16:23:05 kva Exp $
# $Log: owl_printmap1.pm,v $
# Revision 1.23  2002/08/14  16:23:05  kva
# Added a fix for the corruption of the map image and altered the way it handles the associated well information on the crib sheet.
#
# Revision 1.22  2002/05/08  17:40:06  kva
# *** empty log message ***
#
# Revision 1.21  2002/05/08  17:39:49  kva
# Altered the way the special information for the primer is handled.
#
# Revision 1.20  2002/02/26  10:04:08  kva
# added the extra information for the 1k suffix.
#
# Revision 1.19  2002/02/15  17:28:42  kva
# *** empty log message ***
#
# Revision 1.18  2002/02/14  17:56:33  kva
# Altered the ordering of the platelist. - kva
#
# Revision 1.17  2002/02/14  14:37:32  kva
# Added a dbh disconnect string that was missing. - kva
#
# Revision 1.16  2002/02/06  18:32:51  kva
# Altered the mapplate to print transposon information on the cheat sheet.
#
# Revision 1.15  2001/11/23  16:22:31  kva
# Altered the heading titles for the map front page. - kva
#
# Revision 1.14  2001/05/23  16:49:12  kva
# altered the universal primer associated well section to include r1c entries - kva
#
# Revision 1.13  2000/11/29  12:42:43  kva
# *** empty log message ***
#
# Revision 1.12  2000/11/29  12:38:20  kva
# added new print information in relation to the p1c,q1c and s1c primers. In the same format as additives and primer information - kva
#
# Revision 1.11  2000/11/20  13:13:55  kva
# *** empty log message ***
#
# Revision 1.10  2000/11/20  11:57:11  kva
# *** empty log message ***
#
# Revision 1.9  2000/11/16  17:57:42  kva
# *** empty log message ***
#
# Revision 1.8  2000/11/16  17:51:36  kva
# changed the format of the page which prints out the extra primer and additive information. Now a sensibly sort routine sorts the identifiers for the primer names and the identifiers are now grouped with their project into blocks - kva
#
# Revision 1.7  2000/11/16  09:48:21  kva
# added the section which adds the projectname as the unique identifier to the primer name - kva
#
# Revision 1.6  2000/11/15  17:00:58  kva
# *** empty log message ***
#
# Revision 1.5  2000/11/15  16:43:59  kva
# *** empty log message ***
#
# Revision 1.4  2000/11/15  16:42:28  kva
# added the projectname to make the primernames a unique identifier - kva
#
# Revision 1.3  2000/11/15  09:00:57  kva
# *** empty log message ***
#
# Revision 1.2  2000/11/15  08:42:39  kva
# *** empty log message ***
#
# Revision 1.9  1998/09/23  08:43:04  dn1
# *** empty log message ***
#
# Revision 1.8  1998/08/25  08:49:35  dn1
# *** empty log message ***
#
# Revision 1.7  1998/08/24  14:21:20  dn1
# *** empty log message ***
#
# Revision 1.6  1998/08/24  14:07:27  dn1
# *** empty log message ***
#
# Revision 1.5  1998/08/24  12:45:34  dn1
# fixed-bug;
# my $Last;
#
# Revision 1.4  1998/08/17  14:15:54  dn1
# T33 format plates now handled as well :-)
#
# Revision 1.3  1998/07/08  16:25:50  dn1
# if ($get_from ne ''){
# 	    print OUTPUT "$plate      :from $get_from\n";
# 	} else {
# 	    print OUTPUT "$plate      :cannot determine original project\n";
# 	}
#
# Revision 1.2  1998/07/08  16:18:32  dn1
# #printf OUTPUT  "%d %d (MAP $map$comment) sc\n",$platex+$wellsize*$cols/2,$platey+30;
# replaced with...
# printf OUTPUT  "%d %d (MAP_ID is $map   MAP_TYPE is $comment) sc\n",$platex+$wellsize*$cols/2,$platey+30;
#
# Revision 1.1  1998/06/24  10:16:00  dn1
# Initial revision
#

require Exporter;
use Text::Wrap;
use EquusDatabaseInterface;
use Checkfinentries;

use DBI;

@owl_printmap1::ISA = qw(Exporter);
@owl_printmap1::EXPORT = qw(printmaps_out);

#use Data::Dumper;

package owl_printmap1;

# DN1
##############################################################
# A 'sliced 'n diced' version of PRINTMAP (sd) for OWL's use #
##############################################################
# Supply                $S_description_list ; a list of the descriptions of possible runtypes
# Supply                $each   ; 0 or 1 (off and on) -produces a separate page for each order if 'on'
# Supply                $outfile; Screen, None or a Filename 
# Supply                $printer; Required printer name 
# Supply                $manager; The 'manager' using the application
# Supply                @printmap_struct

# NOTE ! This code was hacked toghether using the old printmaps code... hence the scope of 
# the vars used is not all it could be ... needs a re-write at some point (dn1)


sub printmaps_out {
    my ($db_database, $db_user, $db_pass, $S_description_list, $each, $outfile, $printer, $manager, @printmap_struct) = @_;
    my $prog = "owl_printmap1"; 

    # Connect to the database
    my $dbh = DBI->connect( $db_database, $db_user, $db_pass, 'Oracle') || die "ERROR: Could not connect to database: $DBI::errstr\n";

#for testing purposes
#    $outfile="/nfs/griffin2/kva/badger-bin/finch/newtest_owp1.ps";

    # Bug fixing
    my %plate_proj;
    my $well_info;
    my $add_info;
    my $suff_info;
    my $wdesc_info;
    my $wprim_info;
    @all_plates = ();
    my $this_plate = 'Some plate';
    my $old_plate = 'Some other plate';

    #sql statement to check wether a platename exists
    #in oracle and if there is a projectname attached to it.
    my $s_bname = "select cp.projectname
from beckman_box bb, bb_map bm, subclone a, ligation l, clone_project cp
where bb.id_beckmanbox = bm.id_beckmanbox
and bm.id_map in (1,97)
and bm.id_subclone = a.id_subclone
and a.id_ligation = l.id_ligation
and l.clonename = cp.clonename 
and bb.name = ?";
    my $sth3 = $dbh->prepare($s_bname) || die "ERROR:$DBI::errstr";

    my $p_name = "select projectname 
from clone_project 
where clonename = ?";
    my $sth4 = $dbh->prepare($p_name) || die "ERROR:$DBI::errstr";
    
    # A connection to equus
    my $edi = EquusDatabaseInterface->new();

    # Get the set of available additive options
    my $st_a = "select id_additive, description from additive";
    my $sth_a = $dbh->prepare($st_a) || die "ERROR:$DBI::errstr";
    $sth_a->execute || die "ERROR:$DBI::errstr";
    my ($id_dict, $desc);
    my %hash;
    while ( ($id_dict, $desc) = $sth_a->fetchrow() ){
        $hash{$id_dict} = $desc;
    }
    my $valid_additives = \%hash;
    $sth_a->finish();
    
    # What is the current date/time ?
    my $date = sprintf("%04d-%02d-%02d-%02d%02d%02d",((localtime)[5]+1900),((localtime)[4]+1),((localtime)[3]),((localtime)[2]),((localtime)[1]),((localtime)[0]));
    
    
    foreach $this (@printmap_struct){
	################################
        # Choices for output; $outfile #
        ################################
	if ($outfile eq 'Screen') {
	    open(OUTPUT,">&STDOUT") || die "$prog: Could not open stdout for output: $!\n";
	} elsif ($outfile eq 'None'){
	    open(OUTPUT,"| lpr -P$printer") || die "$prog: Could not spool to printer: $!\n";
	    warn "$prog: Spooling to printer: \"$printer\"\n";
	} else {
	    open(OUTPUT,">>$outfile") || die "$prog: Could not open file $outfile for output: $!\n";
	}
	&init();
	&pre();
	############################################
	&printmap($this, $each, @printmap_struct);
	
	&post();
	close(OUTPUT);
    
	###############################################
        # Also have to print the orders out for a map #
        ###############################################
	################################
        # Choices for output; $outfile #
        ################################
	if ($outfile eq 'Screen') {
	    open(OUTPUT,">&STDOUT") || die "$prog: Could not open stdout for output: $!\n";
	} elsif ($outfile eq 'None'){
	    open(OUTPUT,"| lpr -P$printer") || die "$prog: Could not spool to printer: $!\n";
	    warn "$prog: Spooling to printer: \"$printer\"\n";
	} else {
	    open(OUTPUT,">>$outfile") || die "$prog: Could not open file $outfile for output: $!\n";
	}

	($well_info,$add_info,$suff_info,$wdesc_info,$wprim_info)=&dumporders($dbh, $S_description_list, $date, $this, $valid_additives, @printmap_struct);

	close(OUTPUT);
        
        
        ###############################################
        # Also have to print group information        #
        ###############################################
	################################
        # Choices for output; $outfile #
        ################################
        if ($outfile eq 'Screen') {
	    open(OUTPUT,">&STDOUT") || die "$prog: Could not open stdout for output: $!\n";
	} elsif ($outfile eq 'None'){
	    open(OUTPUT,"| lpr -P$printer") || die "$prog: Could not spool to printer: $!\n";
	    warn "$prog: Spooling to printer: \"$printer\"\n";
	} else {
	    open(OUTPUT,">>$outfile") || die "$prog: Could not open file $outfile for output: $!\n";
	}
        
        if (defined (%$well_info)||(%$add_info)||(%$suff_info)||(%$wdesc_info)||(%$wprim_info)){ 
            my $format = $this->{"format"};
            &grouporders($well_info,$add_info,$suff_info,$wdesc_info,$wprim_info,$format);
        }else{
            #print "Nothing to print from group orders\n";
            ##This additonal page for group orders shouldn't be printed.
        }
        
	close(OUTPUT);

    }

    # Also need to print-out all the plates needed for this printout-session
    # ...sort and find unique entries in @all_plates
    if ($outfile eq 'Screen') {
    	open(OUTPUT,">&STDOUT") || die "$prog: Could not open stdout for output: $!\n";
    } elsif ($outfile eq 'None'){
    	open(OUTPUT,"| lpr -P$printer") || die "$prog: Could not spool to printer: $!\n";
    	warn "$prog: spooling to printer: \"$printer\"\n";
    } else {
    	open(OUTPUT,">>$outfile") || die "$prog: Could not open file $outfile for output: $!\n";
    }

    #########################################################
    #printf STDERR "The following plates are required;\n";
    #printf STDERR "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n";
    print OUTPUT "The following plates are required;\n";
    print OUTPUT "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n";
    #########################################################

    my $Last;
    my @sorted_all_plates = grep(($Last eq $_ ? 0 : ($Last = $_, 1)), sort @all_plates);
    my $plate;

    foreach $plate (@sorted_all_plates){

        #performs a check of the template name in oracle and then equus. 
        my $plate_obj;
        my $get_from;
        my $name;
        
        #Check for validity of platename on oracle.
        $sth3->bind_param(1, $plate);
        $sth3->execute || die "ERROR:$DBI::errstr";
        $name = $sth3->fetchrow();
        
        my $clone_obj;
        #If not present in oracle check equus.
        unless ($name) {
            # The following connection is needed because equus tends to loose it's connection if left unattended
            
            $edi->reconnect();
            my $plate_info = $edi->{db}->fetch(-class => 'Plate',
                                               -name  => $plate,
                                               );
            
            my $lig2_obj = $edi->EquusDatabaseInterface::getSubtree(Plate,$plate_info,Ligation);
            my $clone_info = $edi->EquusDatabaseInterface::getSubtree(Ligation,@$lig2_obj,Clone);
            $clone_obj = "@$clone_info";
            $clone_obj=~ s/\s+//g; 

            #If the clonename is got get the related projectname.
            if (defined $clone_obj){
                $sth4->bind_param(1,$clone_obj);
                $sth4->execute || die "ERROR:$DBI::errstr";
                $plate_obj = $sth4->fetchrow();
            }
            
        }
        
        if ( ($plate_obj)||($name) ){
            if (defined $plate_obj){
                $get_from=$plate_obj;
            } else {
                $get_from=$name;
            }
            
            if ($get_from) {
                $plate_proj{$plate} = $get_from;
            } else {
                $plate_proj{$plate} = 'NONE';
            }  
        } 
        
    }
 
    my ($new_proj,$old_proj);  
    my %seen = ();
    my @unique;
    foreach my $keys (sort { $plate_proj{$a} cmp $plate_proj{$b} } keys %plate_proj){
        my $uni_proj = $plate_proj{$keys};
        push (@unique,$uni_proj) unless $seen{$uni_proj}++;
    }
    
    foreach my $unq (sort @unique){
        foreach my $keys (sort keys %plate_proj){
            my $comp_proj = $plate_proj{$keys};
            if ($comp_proj eq $unq){
                $new_proj = $comp_proj; 
                if ($new_proj ne $old_proj){
                    print OUTPUT "\n";
                }
                if ($plate_proj{$keys} eq 'NONE') {
                    print OUTPUT "$keys      :cannot determine original project from Oracle or Equus\n";
                } else {
                    print OUTPUT "$keys      :from $plate_proj{$keys}\n";
                }
                $old_proj = $new_proj;
            }
        }
    }
    
    close(OUTPUT);
    $sth3->finish(); 
    $sth4->finish();
    $dbh->disconnect();
    
}				# end of sub printmaps_out {


############################################################
# Subroutines
############################################################

############################################################
# &dumporders
#
# dumps out what is going where on this map
#
#############################################################

sub dumporders {
    my ($dbh, $S_description_list, $date, $this, $valid_additives, @printmap_struct) = @_;
    #warn "dumping orders for map -> $this %%%%%%%%%%%%%%%%%%%\n";
    #my $capture = Data::Dumper::Dumper(@printmap_struct);
    #warn $capture;

    
    #variables to be used to store that additive and primer information for group orders subroutine.
    my %well_hash;
    my %add_hash;
    my %suff_hash;
    my $well_no;
    my %v_adds;
    %v_adds=%$valid_additives;

    my %plate_hash;
    my %scsp_hash;
    my %desc_hash;
    my %primer_hash;

    ########################
    # A title for this map #
    ########################
    my $number = substr ($this->{comment}, 3);
    my $RUN;
    if ($number eq 'NULL'){
	$RUN = 'No Preference';
    } else {
	$number--;
	$RUN = $S_description_list->[$number];
    }
    my $title1 = "MAP_ID is $this->{map_name}" . "   " . "MAP_TYPE is $this->{comment}" . "   " . "MACHINE_RUN is $RUN";
    my $title2 = "PRINTED at $date \n";

    ##############################
    #printf STDERR "$title1 \n";
    #printf STDERR "$title2 \n";
    #print "\n";

    print OUTPUT "$title1 \n";
    print OUTPUT "$title2 \n";
    print OUTPUT "\n";

    ##################################
    # What goes where on the map >?< #
    ##################################
    my @array_array = @{$this->{map_reads}};
    my $next;
    foreach $next (@array_array){
	my @array = @$next;

	#################################################################################### 
	# create coords(a1)   plate_row_col.suffix[iteration][primername] [primersequence] #
	####################################################################################
	my $statement = "select * from finish_request where id_frequest = \'$array[0]\'";
	my $sth = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
	$sth->execute || die "ERROR:$DBI::errstr";
	my ($ID_FREQUEST, $ID_FBATCH,  $PLATENAME, $ROWLETTER, $COLNUM, $ID_SEQCHEM, $ID_RUNTYPE, $ITERATION, $ID_PRIMER, $ID_SCSP, $ID_ADDITIVE);
	($ID_FREQUEST,$ID_FBATCH,$PLATENAME,$ROWLETTER,$COLNUM,$ID_SEQCHEM,$ID_RUNTYPE,$ITERATION,$ID_PRIMER, $ID_SCSP, $ID_ADDITIVE) = $sth->fetchrow();
	$sth->finish();
	
	#############################################
	# Need to convert $ID_SEQCHEM into a suffix #
	#############################################
	my $statementsuf = "select suffix from seqchem where id_seqchem = \'$ID_SEQCHEM\' and finservice = 1";
	my $sthsuf = $dbh->prepare($statementsuf) || die "ERROR:$DBI::errstr";
	$sthsuf->execute || die "ERROR:$DBI::errstr";
	my $SUFFIX = $sthsuf->fetchrow();
	$sthsuf->finish();
	#warn "derived suffix -> $SUFFIX \n";

	#################################################################################### 
	# If we have an ID_PRIMER value then we need PRIMERNAME and PRIMERSEQ from PRIMER  #
	####################################################################################
        my ($OLIGO, $SEQ);
	if (defined $ID_PRIMER){
	    $statement_olname = "
select PRIMERNAME 
from primer 
where ID_PRIMER = \'$ID_PRIMER\'
";
	    $sth_olname = $dbh->prepare($statement_olname) || die "ERROR:$DBI::errstr";
	    $sth_olname->execute || die "ERROR:$DBI::errstr";
	    $OLIGO = $sth_olname->fetchrow();
	    $sth_olname->finish;
	    $statement_olseq = "select PRIMERSEQ from primer where ID_PRIMER = \'$ID_PRIMER\'";
	    $sth_olseq = $dbh->prepare($statement_olseq) || die "ERROR:$DBI::errstr";
	    $sth_olseq->execute || die "ERROR:$DBI::errstr";
	    $SEQ = $sth_olseq->fetchrow();
	    $sth_olseq->finish;
	}

	#########################################################
	# A different entry for $info depending on what we have #
	#########################################################

	if (defined $ITERATION && defined $ID_PRIMER){
	    #$info = "$PLATENAME". "$ROWLETTER". "$COLNUM". "$SUFFIX". "$ITERATION". "$OLIGO". "    $SEQ";
	    $info = sprintf "%-20s %s", $PLATENAME.$ROWLETTER.$COLNUM.$SUFFIX.$ITERATION.$OLIGO, $SEQ;
				}
	if (!defined $ITERATION && defined $ID_PRIMER){
	    #$info = "$PLATENAME". "$ROWLETTER". "$COLNUM". "$SUFFIX". "$OLIGO". "    $SEQ";
	    $info = sprintf "%-20s %s", $PLATENAME.$ROWLETTER.$COLNUM.$SUFFIX.$OLIGO, $SEQ;
	}
	if (defined $ITERATION && !defined $ID_PRIMER){
	    $info = "$PLATENAME". "$ROWLETTER". "$COLNUM". "$SUFFIX". "$ITERATION";
	}
	if (!defined $ITERATION && !defined $ID_PRIMER){
	    $info = "$PLATENAME". "$ROWLETTER". "$COLNUM". "$SUFFIX";
	}
	
	########################################################################
	# A space is required if this is a different plate to the last one seen
	# we are looking at (eg.); 
	#
	# Xco82b7.s2c2         CTGATCCTACCAACATAC
	# (or eg.) 
	# 495010-01a1.s1ea
	# 
	########################################################################
	################################
	# New code to handle platenames
	################################
	if ($info =~ /\w+-\w+/){
	    if ($info =~ /(\w+-\w+)\D{1}\d+.\w+/){
		$this_plate = $1;
	    } else {
		warn "cannot match ! T33 format platename ? \n";
	    }
	} else {
	    if ($info =~ /(\w+)\D{1}\d+.\w+/){
		$this_plate = $1;
	    } else {
		warn "cannot match ! Second attempt to grab platename\n";
	    }
	}

	#################################
	# Old code to handle platenames
	#################################
#	# look for letter/1ormore_numbers/./*/space to get the platename
#	if ($info =~ /(\w+)\D{1}\d+.\w+/){
#	    $this_plate = $1;
#	} else {
#	    warn "Something is wrong cannot match platename ! \n";
#	}





	if ($this_plate ne $old_plate){
	    push @all_plates, $this_plate;

	    #####################
	    #print STDERR "\n";
	    printf OUTPUT "\n";
	    #####################
	}
	$old_plate = $this_plate;

 	# What project is this sample from >?< ###This is crap, we are reworking something we know already
	# HACK HACK HACK
	# We have the current id_frequest in $ID_FREQUEST
	my $statement_hack = "
select finish_batch.projectname
from finish_request, finish_batch
where finish_request.id_fbatch = finish_batch.id_fbatch
and  id_frequest = \'$ID_FREQUEST\'
";
	my $sth_hack = $dbh->prepare($statement_hack) || die "ERROR:$DBI::errstr";
	$sth_hack->execute || die "ERROR:$DBI::errstr";
	$this_project = $sth_hack->fetchrow();
	$sth_hack->finish;
	
	#print STDERR "$this_project\n";

	########################################
	# We can put a break in between blocks #
	########################################

	if ($this_project ne $old_project){

	    #####################
	    #print STDERR "\n";
	    #print STDERR "-------------o-------------";
	    #print STDERR "\n";
	    print OUTPUT "\n";
	    print OUTPUT "-------------o-------------";
	    print OUTPUT "\n";


	    #####################
	}

	$old_project = $this_project;

	##############################################################
	#printf STDERR  "%-5s %s\n", "$array[1]$array[2]", $info;
	printf OUTPUT  "%-5s %s\n", "$array[1]$array[2]", $info;
	##############################################################

        $well_no="$array[1]"."$array[2]";

        #get list of platenames.
        unless ($plate_hash{$well_no}){
            $plate_hash{$well_no} = $PLATENAME;
        }
#get idscsp list.
        unless ($scsp_hash{$well_no}){
            $scsp_hash{$well_no} = $ID_SCSP;
        }
    
        my $ADDITIVE;
        if (defined $ID_ADDITIVE){
            #if additive id exists obtain the additive description from the additive id.
            if (defined $v_adds{$ID_ADDITIVE}){
                $ADDITIVE=$v_adds{$ID_ADDITIVE};
            }
            
            #Build a hash of multiple values for the additives.
            #This if statement is for double additive additions, 
            #so that the additives involved will have their associated 
            #wells added to their individual lists respectively.
            #if not the additives have their associated wells added to them.
            if ($ADDITIVE=~ /\S+\s+\S+/g){
                my @all;
                @all=split(/\s+/,$ADDITIVE);
                foreach (@all){
                    push ( @{$add_hash{$_}},$well_no);
                }
            }else{ 
                push ( @{$add_hash{$ADDITIVE}},$well_no);
            }
        }
        
        if (defined $OLIGO){
            my $UNIQUE_OLIGO;
            $UNIQUE_OLIGO="$this_project"."_"."$OLIGO"; 
            #Build a hash of multiple values for the primernames.
            push ( @{$well_hash{$UNIQUE_OLIGO}}, $well_no);
        }

        if ($SUFFIX=~ /.p1c|.s1c|.q1c|.r1c|.p1k|.s1k|.q1k|.r1k/g){
            #Build a hash of multiple values for the 8 particular suffixes.
            push (@{$suff_hash{$SUFFIX}}, $well_no);
        }
        
    }

#get unique plate list.
    my %seen1 = ();
    my @uniq_plate = ();
    foreach my $keys (keys %plate_hash){
        my $temp = $plate_hash{$keys};
        push (@uniq_plate ,$temp) unless $seen1{$temp}++;
    }

#get unique id_scsp.
    my %seen2 = ();
    my @uniq_scsp = ();
    foreach my $keys (keys %scsp_hash){
        my $temp = $scsp_hash{$keys};
        push (@uniq_scsp ,$temp) unless $seen2{$temp}++;
    }


    my $stat_ei1 = "select bb.NAME, std.DESCRIPTION
from   BECKMAN_BOX bb, BB_MAP bm, SUBCLONE s, 
       LIGATION l, FRAGMENTATION_BAND fb,
       SIL_JOB sj, SIL_REQUEST sr,
       SILTYPEDICT std
where  bb.name = ?
and    bb.id_beckmanbox = bm.id_beckmanbox
and    bm.id_map in (1,97)
and    bm.id_subclone = s.id_subclone
and    s.id_ligation  = l.id_ligation
and    l.ID_FRAGBAND = fb.ID_FRAGBAND
and    fb.ID_FRAG    = sj.ID_FRAG
and    sj.ID_REQUEST = sr.ID_REQUEST
and    sr.SIL_TYPE = std.ID_DICT";
    
    my $sth_ei1 = $dbh->prepare($stat_ei1) || die "ERROR:$DBI::errstr";
    
    my $stat_ei2 = "select pv.primername||' (vector - '||pv.vectorname||')', ss.id_scsp
from seqchem_seqprotocol ss, seqchemistry sc, pt_vector pv
where ss.id_seqchem  = sc.id_seqchem
and sc.id_ptv = pv.id_ptv
and vectorname not in ('m13mp18','puc18','NONE')
and ss.id_scsp = ?";
    
    my $sth_ei2 = $dbh->prepare($stat_ei2) || die "ERROR:$DBI::errstr";
    
    foreach my $up (@uniq_plate){
        $sth_ei1->bind_param(1,$up);
        $sth_ei1->execute || die "ERROR:$DBI::errstr";
        my($NAME, $DESC) = $sth_ei1->fetchrow();
        if (defined $DESC){
            $desc_hash{$NAME}=$DESC;
        }
    }
    
    
    foreach my $us (@uniq_scsp){
        $sth_ei2->bind_param(1,$us);
        $sth_ei2->execute || die "ERROR:$DBI::errstr";
        my($PRIM, $SCSP) = $sth_ei2->fetchrow();
        if (defined $PRIM){
            $primer_hash{$SCSP}=$PRIM;
        }
    }
    
    my %wdesc_hash;
    my %wprim_hash;
    
    foreach my $ph (keys %plate_hash){
        my $temp = $plate_hash{$ph};
        if ($desc_hash{$temp}){
            $wdesc_hash{$ph} = $desc_hash{$temp};
        }
    }

    foreach my $sh (keys %scsp_hash){
        my $temp = $scsp_hash{$sh};
        if ($primer_hash{$temp}){
            $wprim_hash{$sh} = $primer_hash{$temp};
        }
    }

    $sth_ei1->finish();
    $sth_ei2->finish();
    
    return(\%well_hash, \%add_hash, \%suff_hash, \%wdesc_hash, \%wprim_hash);

}    # end of dumporders



############################################################
# &grouporders
# groups the associated wells with their primername and 
# their additive name. 
#############################################################

sub grouporders {

    my ($well_info,$add_info,$suff_info,$wdesc_info,$wprim_info,$format) = @_;

    my %well_hash;
    my %add_hash;
    my %suff_hash;
    my @allwell;

    %well_hash=%$well_info;
    %add_hash=%$add_info;
    %suff_hash=%$suff_info;
    %wdesc_hash=%$wdesc_info;
    %wprim_hash=%$wprim_info;
    my %proj;
     

    print OUTPUT "\n";
    print OUTPUT "---------- Custom primers and associated wells ----------\n"; 
    print OUTPUT "\n";

    if (defined %well_hash){
        
        foreach my $key (sort keys %well_hash){
            #Each project is but into a hash and the corresponding project_primername id
            #stored with it.
            if ($key=~ /(\S+)\_\S+/){
                my $project=$1;
                my @projectnames;
                push @projectnames, $project;
                foreach my $p (@projectnames){
                    push (@{$proj{$p}}, $key);
                }
            }
        }

        #The hashes of the projects use the sensibly subroutine, which sorts
        #the projects. The project is displayed and then the associating
        #project_primername identifiers are sorted in order. Then the %well_hash which
        #holds the information on the project_primernames and associated wells will have 
        #the values of the wells printed out with it. 
        foreach my $key2 (sort {sensibly($a, $b)} keys %proj){

            my($t_project,$o_project);
            # What project is this sample from
            $t_project = $key2;
            
            # We can put a break in between blocks
            if ($t_project ne $o_project){
                print OUTPUT "\n";
                print OUTPUT "-------------o-------------";
                print OUTPUT "\n";
            }            
            $o_project = $t_project;
            
            #print out the project and the primer information.
            print OUTPUT "\n";
            print OUTPUT "Project : $key2\n";
            my @values;
            push @values, @{$proj{$key2}};
            foreach (sort {sensibly($a, $b)} @values){ 
                print OUTPUT "\n";
                print OUTPUT "Primername: $_\n";
                @allwell=();
                push @allwell, @{$well_hash{$_}};
                
                #Limits the number of columns per line, so that text can be fitted to a page.
                my $columns;
                use Text::Wrap qw($columns &wrap);
                $columns = 20;
                
                #check to see if the number of wells if
                #equal to the full quota of the plate
                #if so, just state that all the wells
                #are to be added to.
                my $count = scalar(@allwell);
                if ($count == $format) {
                    print OUTPUT "Associated wells : ALL WELLS\n";
                } else {
                    print OUTPUT "Associated wells :\n";
                    print OUTPUT wrap(" ", " ",@allwell), "\n";
                }
            }
        }
        
    }else{
        print OUTPUT "No Primers were ordered\n";
    }

    
    print OUTPUT "\n";
    print OUTPUT "---------- Additives and associated wells ----------\n"; 
    print OUTPUT "\n";
    
    if (defined %add_hash){
        
        foreach my $key (sort keys %add_hash){
            print OUTPUT "\n";
            print OUTPUT  "Additive $key\n";        
            @allwell=();
            push @allwell, @{$add_hash{$key}};
            
            my $columns;
            use Text::Wrap qw($columns &wrap);
            $columns = 20;
            
            my $count = scalar(@allwell);
            if ($count == $format) {
                print OUTPUT "Associated wells : ALL WELLS\n";
            } else {
                print OUTPUT "Associated wells :\n";
                print OUTPUT wrap(" ", " ",@allwell), "\n";
            }
        }
    } else{
        print OUTPUT "No Additives were previously defined\n";
    } 

    my %spec_hash;
    my %tester;
    if (defined %wprim_hash){
        print OUTPUT "\n";
        print OUTPUT "---------- Special Additional information ----------\n"; 
        print OUTPUT "\n";

#        foreach my $keys (sort keys %wdesc_hash){
#            if ($wdesc_hash{$keys}=~ /transposon/i){
#                my $temp = $wprim_hash{$keys};
#                push (@{$tester{$temp}},$keys);
#            }
#        }

        foreach my $keys (sort keys %wprim_hash){
            my $temp = $wprim_hash{$keys};
            push (@{$tester{$temp}},$keys);
        }

        foreach my $key (sort keys %tester){
            print OUTPUT "\n";
            print OUTPUT  "Primer $key\n";        
            @allwell=();
            push @allwell, @{$tester{$key}};
            
            my @newwell;
            foreach (sort {sensibly($a, $b)} @allwell){
                push @newwell,$_;   
            }

            my $columns;
            use Text::Wrap qw($columns &wrap);
            $columns = 20;

            foreach (@newwell){
                $spec_hash{$_}=1;
            }

            my $count = scalar(@newwell);
            if ($count == $format) {
                print OUTPUT "Associated wells : ALL WELLS\n";
            } else {
                print OUTPUT "Associated wells :\n";
                print OUTPUT wrap(" ", " ",@newwell), "\n";
            }
        }
        
    }


    if (defined %suff_hash){
        
        print OUTPUT "\n";
        print OUTPUT "---------- p1c/k, s1c/k, r1c/k, q1c/k and associated wells ----------\n"; 
        print OUTPUT "\n";
        
        foreach my $key (sort keys %suff_hash){  
            @allwell=();
            push @allwell, @{$suff_hash{$key}};
            
            my @welllft;
            foreach my $aw (@allwell){
                unless (defined $spec_hash{$aw}){
                    push @welllft,$aw;
                }
            }

            my $columns;
            use Text::Wrap qw($columns &wrap);
            $columns = 20;
            if (scalar(@welllft)>0){
                my $count = scalar(@welllft);
                if ($count == $format) {
                    print OUTPUT "\n";
                    print OUTPUT "Universal Primer for $key\n";
                    print OUTPUT "Associated wells : ALL WELLS\n";
                } else {
                    print OUTPUT "\n";
                    print OUTPUT "Universal Primer for $key\n";
                    print OUTPUT "Associated wells :\n";
                    print OUTPUT wrap(" ", " ",@welllft), "\n";
                }
            } else {
                print OUTPUT "\n";
                print OUTPUT "Universal Primer for $key\n";
                print OUTPUT "Associated wells : No universal primer info.\n";
                print OUTPUT wrap(" ", " ",@welllft), "\n";
            } 
        }
    } else{
        #print OUTPUT "No p1c/k, s1c/k, r1c/k, q1c/k reactions were previously defined\n";
    } 
    
}


##################################################################################
# This subroutine splits off the left-hand component of both symbols and
# compares them (numerically if they are both composed of digits, lexically
# otherwise). If they are different, it returns with a value indicating which
# comes first, otherwise it reinvokes itself recursively with the remainder
# of the two symbols until either a difference is found, or else one or both
# of the symbols has been exhausted. Note that this will only work if all
# symbols to be sorted are guaranteed to start with the same thing (digit 
# or letter). also each letter is converted to it's lowercase equivalent before
# sorting.
###################################################################################
sub sensibly {
        my ($aa, $bb) = @_;
        my ($a_lhs, $b_lhs);

        return $aa cmp $bb if $aa eq "" or $bb eq "";
        $aa =~ s/^(\D+|\d+)//;
        $a_lhs = lc($1);

        $bb =~ s/^(\D+|\d+)//;
        $b_lhs = lc($1);
      
        if ($a_lhs =~ /^[0-9]/ and $b_lhs =~ /^[0-9]/) {
                if ($a_lhs == $b_lhs) {
                        return sensibly($aa, $bb);
                } else {
                        return $a_lhs <=> $b_lhs;
               }
        } else {
                if ($a_lhs eq $b_lhs) {
                        return sensibly($aa, $bb);
                } else {
return $a_lhs cmp $b_lhs;
                }
        }
}

############################################################
# &printmap($map)
#
# Produces postscript representation for map. If
# $each is set, it will produce a separate page for each
# order allocated to the map.
#
############################################################
sub printmap {
    #local($map) = @_;		# gets the map-title !

    local($this, $each, @printmap_struct) = @_;

    local($file);
    local($format);
    local(@mapinfo);
    local($i);
    local($x,$y);

    local($map) = $this->{map_name};
    #warn "map -> $map\n";
    $format = $this->{"format"};
    #warn "format -> $format \n";
    $comment = $this->{comment};
    #warn "comment -> $comment \n";
    @mapinfo = @{$this->{mapinfo}};

    if ($each == 0) {
	print OUTPUT "%%Page: 0 1\n";

	&printpage($map,$format,$comment);

	for($i=0;$i<=$#mapinfo;$i++) {
	    &printorder($format,$mapinfo[$i],1);
	}

	printf OUTPUT  "gs /Times-Roman findfont 8 scalefont setfont\n";
	for($i=0;$i<=$#mapinfo;$i++) {
	    if ($#mapinfo<11) {
		$x = $platex;
		$y = $gely-10*$i;
	    } else {
		$x = 10+(150*int($i/11));
		$y = $gely-10*($i%11);
	    }
	    printf OUTPUT  "%d %d m (%s) show\n",$x,$y,join(" ",@{$mapinfo[$i]});
	}
	print OUTPUT "gr\n";

	print OUTPUT "\nshowpage\n";
    } else {
	for($j=0;$j<=$#mapinfo;$j++) {
	    print OUTPUT "%%Page: $j ",$#mapinfo + 1,"\n";

	    &printpage($map,$format,$comment);

	    for($i=0;$i<=$#mapinfo;$i++) {
		&printorder($format,$mapinfo[$i],($j==$i)?1:0);
	    }

	    print OUTPUT "gs /Times-Roman findfont 8 scalefont setfont\n";
	    for($i=0;$i<=$#mapinfo;$i++) {
		if ($#mapinfo<11) {
		    $x = $platex;
		    $y = $gely-10*$i;
		} else {
		    $x = 10+(150*int($i/11));
		    $y = $gely-10*($i%11);
		}
		printf OUTPUT  "%d %d m (%s) show\n",$x,$y,join(" ",@{$mapinfo[$i]});
	    }


	    if ($#mapinfo<11) {
		$x = $platex;
		$y = $gely-10*$j;
	    } else {
		$x = 10+(150*int($j/11));
		$y = $gely-10*($j%11);
	    }

	    printf OUTPUT  "%d %d (%s) stringwidth pop 1 add 8 rectstroke\n",$x-1,$y-1,join(" ",@{$mapinfo[$j]});
	    printf OUTPUT "gs /Times-BoldItalic findfont 24 scalefont setfont %d %d (* %s *) sr gr\n",$platex+$platewidth,$platey + 60,join(" ",@{$mapinfo[$j]});
	    print OUTPUT "gr\n";


	    print OUTPUT "\nshowpage\n";
	}
    }
    

}



############################################################
# Postscript prolog
############################################################
sub pre {

    local($date);

    chop($date =`date`);
    ############################################################
    # Header
    ############################################################
    print OUTPUT qq#%\!PS-Adobe-1.0
%%Creator: printmap
%%Title: Print Map
%%CreationDate: $date
%%Pages: 1
%%DocumentFonts: Helvetica-Bold Helvetica
%%EndComments
%%EndProlog
/cm {28.35 mul} def
/gs { gsave } def
/gr { grestore } def
/s  { stroke } def
/sh { show } def
/m { moveto } def
/rm { rmoveto } def
/l { lineto } def
/rl { rlineto } def
/np { newpath } def
/sc { 3 -1 roll 1 index stringwidth pop 2 div sub 3 -1 roll m sh } def
/sr { 3 -1 roll 1 index stringwidth pop sub 3 -1 roll m sh } def
/fittext {
  gsave
  findfont 16 scalefont setfont
  5 1 roll
  2 index sub exch
  3 index sub exch
  4 index stringwidth
  pop 16
  2 index exch div exch
  3 index exch div
  2 copy lt {pop} {exch pop} ifelse
  currentfont exch 0.66 mul scalefont setfont
  4 2 roll moveto 2 div exch 2 div exch rmoveto
  dup gsave true charpath flattenpath pathbbox grestore
  2 index sub 2 div neg exch
  3 index sub 2 div neg exch rmoveto pop pop
  show
  grestore
} def
/rectstroke {
  gsave newpath
  4 2 roll moveto
  exch dup 0 rlineto
  exch 0 exch rlineto
  neg 0 rlineto
  closepath
  0 setlinewidth stroke
  grestore
} def
/rectfill {
  gsave newpath
  4 2 roll moveto
  exch dup 0 rlineto
  exch 0 exch rlineto
  neg 0 rlineto
  closepath
  fill
  grestore
} def
#;

}


############################################################
# &printpage($map,$format)
# Print am empty page layout.
############################################################
sub printpage {

    local($map,$format,$comment) = @_;
    local($i,$j);
    local($rows) = $plateMetrics{$format}->{"rows"};
    local($cols) = $plateMetrics{$format}->{"columns"};
    local($wellsize) = $plateMetrics{$format}->{"wellsize"};


    ############################################################
    # Title
    ############################################################

    print OUTPUT "gs\n";
    print OUTPUT "/Times-Italic findfont\n";
    print OUTPUT "24 scalefont\n";
    print OUTPUT "setfont\n";
    
    #printf OUTPUT  "%d %d (MAP $map$comment) sc\n",$platex+$wellsize*$cols/2,$platey+30;
    printf OUTPUT  "%d %d (MAP_ID is $map   MAP_TYPE is $comment) sc\n",$platex+$wellsize*$cols/2,$platey+30;

    print OUTPUT "gr\n";

    ############################################################
    # Plate
    ############################################################
    print OUTPUT "np\n";
    for ($i=0;$i<=$rows;$i++) {
	printf OUTPUT  "%d %d m %d %d l\n", $platex,$platey-$wellsize*$i,$platex+$wellsize*$cols,$platey-$wellsize*$i;
    }
    for ($i=0;$i<=$cols;$i++) {
	printf OUTPUT  "%d %d m %d %d l\n", $platex+$wellsize*$i,$platey,$platex+$wellsize*$i,$platey-$wellsize*$rows;
    }
    print OUTPUT "s\n";

    ############################################################
    # Plate Labels
    ############################################################
    print OUTPUT "gs\n";
    print OUTPUT "/Helvetica findfont\n";
    print OUTPUT "12 scalefont\n";
    print OUTPUT "setfont\n";
    for ($i=0;$i<$rows;$i++) {
	printf OUTPUT  "%d %d (%s) sr\n", $platex-10,$platey-($wellsize*$i+$wellsize/2),substr("ABCDEFGHIJKLMNOPQRSTUVWXYZ",$i,1);
    }
    for ($i=0;$i<$cols;$i++) {
	printf OUTPUT  "%d %d (%s) sc\n", $platex+($wellsize*$i+$wellsize/2),$platey+10,$i+1;
    }
    print OUTPUT "gr\n";


    ############################################################
    # Gel Photo
    ############################################################
    print OUTPUT "np ";
    printf OUTPUT  "%d %d m ",$gelx,$gely;
    printf OUTPUT  "%d %d l ",$gelx+$gelwidth,$gely;
    printf OUTPUT  "%d %d l ",$gelx+$gelwidth,$gely-$gelheight;
    printf OUTPUT  "%d %d l ",$gelx,$gely-$gelheight;
    printf OUTPUT  "%d %d l ",$gelx,$gely;
    print OUTPUT "s\n";
    print OUTPUT "np ";
    printf OUTPUT  "%d %d m ",$gelx+$geloff,$gely-$geloff;
    printf OUTPUT  "%d %d l ",$gelx+$gelwidth-$geloff,$gely-$geloff;
    printf OUTPUT  "%d %d l ",$gelx+$gelwidth-$geloff,$gely-$gelheight+$geloff;
    printf OUTPUT  "%d %d l ",$gelx+$geloff,$gely-$gelheight+$geloff;
    printf OUTPUT  "%d %d l ",$gelx+$geloff,$gely-$geloff;
    print OUTPUT "s\n";
    print OUTPUT "gs\n";
    print OUTPUT "/Helvetica-Oblique findfont 16 scalefont setfont\n";
    printf OUTPUT  "%d %d (Gel Photo) sc\n",$gelx+$gelwidth/2,$gely-$gelheight/2;
    print OUTPUT "gr\n";


    ############################################################
    # Work flow
    ############################################################
    print OUTPUT "gs\n";
    print OUTPUT "/Helvetica-Bold findfont 16 scalefont setfont\n";
    # Rows
    foreach $i ( [0,2,"Stage"],[1,2,"FIN Number"],[2,1,"Picked"],[3,1,"Cycled"],[4,1,"Loaded"],[5,1,"Pass"],[6,1,"Quality"],[7,1,"Read Length"],[8,2] ) {
	printf OUTPUT  "np %d %d m %d %d l %d setlinewidth s\n", $flowx,$flowy-($flowheight*$i->[0]/8),$flowx+$flowwidth,$flowy-($flowheight*$i->[0]/8),$i->[1];
	if ($#{$i} > 1) {
	    printf OUTPUT  "%d %d m ($i->[2]) show\n",$flowx+10,$flowy-($flowheight*($i->[0]+1)/8)+10;
	}
    }
    # Cols
    foreach $i ( [0,2],[3,1,"Date"],[5,1,"Initials"],[7,1,"Comments"],[12,2] ) {
	printf OUTPUT  "np %d %d m %d %d l %d setlinewidth s\n", $flowx+($flowwidth*$i->[0]/12),$flowy,$flowx+($flowwidth*$i->[0]/12),$flowy-$flowheight,$i->[1];
	if ($#{$i} > 1) {
	    printf OUTPUT  "%d %d m ($i->[2]) show\n",$flowx+($flowwidth*$i->[0]/12)+10,$flowy-($flowheight/8)+10;
	}
    }
    # Transf.
    printf OUTPUT "1 setlinewidth\n";
    printf OUTPUT "%d %d m %d %d rl s\n",$flowx+($flowwidth*10/12),$flowy-($flowheight*6/8),0,-($flowheight/8);
    printf OUTPUT "%d %d m %d %d rl s\n",$flowx+($flowwidth*10/12),$flowy-($flowheight*6.5/8),($flowwidth*2/12),0;
    printf OUTPUT "%d %d %d %d (Transf.) /Helvetica-Bold fittext\n",$flowx+($flowwidth*10/12),$flowy-($flowheight*6.5/8),$flowx+$flowwidth,$flowy-($flowheight*6/8);
    print OUTPUT "gr\n";
    
}

############################################################
# &printorder($format,@{$order},$select)
# Print an individual order on the plate laytout of page.
# If $select, colour it white, else grey it.
#############################################################
sub printorder {
    local($format,$ORDER,$select) = @_;


    # yelp #################################################
    #warn "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n";
    #my $capture = Data::Dumper::Dumper($ORDER);
    #warn $capture;
    ########################################################



    local($columns) = $plateMetrics{$format}->{"columns"};

    local($range,$order,$from,$to) = @{$ORDER};
    local($cellfrom,$cellto) = split(/-/,$range);
    local($numfrom,$numto);
    local($xfrom, $yfrom, $xto, $yto);

    $numfrom = &{$plateMetrics{$format}->{"name2cell"}}($cellfrom);

    #fix to stop postscript going mad
    #when it has to print 1 block at the
    #end of the map.It would block out
    #the whole map previously before the fix.
    if ($cellto eq ''){
        $numto = $format-1;
    } else {
        $numto = &{$plateMetrics{$format}->{"name2cell"}}($cellto);
    }
    
    $xfrom = $numfrom % $columns;
    $yfrom = int($numfrom / $columns);
    $xto = $numto % $columns;
    $yto = int($numto / $columns);

    if ($yto == $yfrom +1 && $xfrom > $xto) {
	# Can't draw as one block
	&printpartorder($xfrom,$yfrom,($columns-1),$yfrom,$order,$from,($columns-$xfrom),$select);
	&printpartorder(0,$yto,$xto,$yto,$order,($columns-$xfrom+1),$to,$select);

    } else {
	&printpartorder($xfrom,$yfrom,$xto,$yto,$order,$from,$to,$select);
    }
}

############################################################
# &printpartorder($xfrom,$yfrom,$xto,$yto,$order,$from,$to,$select)
# Print an order (guarenteed to be a connected block of wells.)
#
#############################################################
sub printpartorder {
    local($xfrom,$yfrom,$xto,$yto,$order,$from,$to,$select) = @_;

    local($rows) = $plateMetrics{$format}->{"rows"};
    local($cols) = $plateMetrics{$format}->{"columns"};
    local($wellsize) = $plateMetrics{$format}->{"wellsize"};
    local($welloff) = $plateMetrics{$format}->{"welloff"};


    # Draw a box around cells
    print OUTPUT "np\n";
    printf OUTPUT  "%d %d m ",$platex+($wellsize*$xfrom+$welloff),$platey-($wellsize*$yfrom+$welloff);

    local($right) = ($yfrom != $yto) ? ($cols-1): $xto;
    printf OUTPUT  "%d %d l ",$platex+($wellsize*($right+1)-$welloff),$platey-($wellsize*$yfrom+$welloff);
    if ($yfrom != $yto && $xto != $right) {
	printf OUTPUT  "%d %d l ",$platex+($wellsize*($right+1)-$welloff),$platey-($wellsize*$yto-$welloff);
	printf OUTPUT  "%d %d l ",$platex+($wellsize*($xto+1)-$welloff),$platey-($wellsize*$yto-$welloff);
    }

    printf OUTPUT  "%d %d l ",$platex+($wellsize*($xto+1)-$welloff),$platey-($wellsize*($yto+1)-$welloff);

    local($left) = ($yfrom != $yto) ? 0 : $xfrom;
    printf OUTPUT  "%d %d l ",$platex+($wellsize*$left+$welloff),$platey-($wellsize*($yto+1)-$welloff);
    if ($yfrom != $yto && $xfrom != $left) {
	printf OUTPUT  "%d %d l ",$platex+($wellsize*$left+$welloff),$platey-($wellsize*($yfrom+1)+$welloff);
	printf OUTPUT  "%d %d l ",$platex+($wellsize*$xfrom+$welloff),$platey-($wellsize*($yfrom+1)+$welloff);
    }    



    printf OUTPUT  "%d %d l ",$platex+($wellsize*$xfrom+$welloff),$platey-($wellsize*$yfrom+$welloff);

    print OUTPUT "closepath ";
    if ($select) {
	print OUTPUT "gs 1 setgray fill gr ";
    } else {
	print OUTPUT "gs .9 setgray fill gr ";
    }
    print OUTPUT "2 setlinewidth s\n";

    # print Order number
    printf OUTPUT  "gs %d %d %d %d ($order) %s fittext gr\n",$platex+($wellsize*$xfrom),$platey-($wellsize*($yfrom+1)),$platex+($wellsize*($right+1)),$platey-($wellsize*$yfrom),($select?"/Times-BoldItalic":"/Times-Roman");


}

############################################################
# Postscript Trailer
############################################################
sub post {

    print OUTPUT "%%Trailer\n";

}




############################################################
# Well and layout initialisation
############################################################

sub init {
    local($format);

    $platex = 75;
    $platey = 750;
    $plateheight = 300;
    $platewidth = 300*12/8;

    $gelx = $platex + $platewidth/2;
    $gely = $platey - $plateheight - 10;
    $gelwidth = $platewidth/2;
    $gelheight = 100;
    $geloff = 7;

    $flowx = $platex;
    $flowy = $gely - $gelheight - 10;
    $flowheight = $plateheight;
    $flowwidth = $platewidth;

    &initPlateMetrics();
    foreach $format ( keys %plateMetrics ) {
	$plateMetrics{$format}->{"wellsize"} = $plateheight/$plateMetrics{$format}->{"rows"};
	$plateMetrics{$format}->{"welloff"} = 3;
    }

}




############################################################
# Plate Metric Stuff - COPY - ORIGINAL IN DISPATCHER 
############################################################

sub initPlateMetrics {
    %plateMetrics = (
		     "96" => {
			 "rows" => 8,
			 "columns" => 12,
			 "cells" => 96,
			 "description" => "96 Well Microtitre plate",
			 "cell2name" => \&cell2name96,
			 "name2cell" => \&name2cell96,
		     },
		     "384" => {
			 "rows" => 16,
			 "columns" => 24,
			 "cells" => 384,
			 "description" => "384 Well Microtitre plate",
			 "cell2name" => \&cell2name384,
			 "name2cell" => \&name2cell384,
		     },
		     );

}


sub cell2name96 {
    &CELL2NAME("96",@_);
}

sub cell2name384 {
    &CELL2NAME("384",@_);
}

sub CELL2NAME {
    local($format, $cell) = @_;
    local($row,$column);

    $row = int($cell / $plateMetrics{$format}->{"columns"});
    $column = ($cell % $plateMetrics{$format}->{"columns"}) + 1;

    return substr("ABCDEFGHIJKLMNOPQRSTUVWXYZ",$row,1) . $column;
}

sub name2cell96 {
    &NAME2CELL("96",@_);
}

sub name2cell384 {
    &NAME2CELL("384",@_);
}

sub NAME2CELL {
    local($format,$name) = @_;
    local($ra,$c) = $name =~ /^(\w)(\d\d?)$/;
    $ra =~ tr/A-Z/a-z/;

    local($r) = index("abcdefghijklmnopqrstuvwxyz",$ra);

    $r * $plateMetrics{$format}->{"columns"} + $c - 1;
}

    #jiggery pokery



############# end of file ###############
# Local Variables:
# mode:perl
# End:
############# end of file ###############










