package Owl_printmap2;

############
#use strict;
############
use vars qw(@ISA @EXPORT);
use Exporter;
@ISA = ('Exporter');
@EXPORT = qw(&printmaps_out);
require Exporter;

use Text::Wrap;
use finch2_general;
use EquusDatabaseInterface;
use SDTable;
use Data::Dumper;

#    $S_description_list ; a list of the descriptions of possible runtypes
#    $each   ; 0 or 1 (off and on) -produces a separate page for each order if 'on'
#    $outfile; Screen, None or a Filename 
#    $printer; Required printer name 
#    $manager; The 'manager' using the application
#    @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 ($dbh, $chem2suff, $S_description_list, $each, $outfile, $printer, $manager, @printmap_struct) = @_;
    my $prog = "Owl_printmap2.pm"; 
    
    #For testing purposes
    #my $outfile=$ENV{'HOME'}.'/badger-bin/finch/newtest.ps';
    
    my %plate_proj;
    my $well_info;
    my $add_info;
    my $suff_info;
    my $wdesc_info;
    my $wprim_info;
    my $wells_on_plate;
    my $CHECK_384;
    my $o_bdt;
    my $is_bdt;

    @all_plates = ();

    my $this_plate = 'Some plate';
    my $old_plate = 'Some other plate';
    
    #sql statement to check wether a platename exists
    #in oracle and get the project information.
    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";

    #Get project/clone correlation
    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();
     
    # 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]));
    
    # Get the set of available additive options
    my $valid_additives = get->valid_additives($dbh);
    

    #if it's a pcr based plate get the relevant information.
    my $stat_pcr = "select distinct a.id_pcrvessel||'-'||b.maprow||''||b.mapcol 
from pcr_product a, rowcol_map b 
where a.id_map = b.id_map
and pcr_template_name = ?";
    my $sth_pcr = $dbh->prepare($stat_pcr) || die "ERROR:$DBI::errstr";
    
    
#statement to handle 384->96 well connection.
#it also handles direct 384 connection.
    my $stat384_96 = "select distinct dpm.id_dnaplate,rcm.maprow||rcm.mapcol,ap.target_quadrant,rcm2.maprow||rcm2.mapcol,dpm2.id_dnaplate,bb.name 
from dnaplate_map dpm, bb_map bbm, beckman_box bb, array_pattern ap, dnaplate_map dpm2, dna_plate dp, rowcol_map rcm, rowcol_map rcm2
where dpm.id_bbmap = bbm.id_bbmap
and bbm.id_beckmanbox = bb.id_beckmanbox
and dpm.id_map = ap.source_idmap
and dpm.id_map = rcm.id_map
and ap.id_arraypattern = 2
and bb.name = ?
and dpm2.id_bbmap = bbm.id_bbmap
and dpm2.id_dnaplate = dp.id_dnaplate
and dpm2.id_map = rcm2.id_map
and rcm2.maprow = ?
and rcm2.mapcol = ?
and dp.copy_type = 1
and dp.format = 96
UNION
select distinct dpm.id_dnaplate,rcm.maprow||rcm.mapcol,ap.target_quadrant,rcm2.maprow||rcm2.mapcol,dpm.id_dnaplate,bb.name 
from dnaplate_map dpm, bb_map bbm, beckman_box bb, array_pattern ap, rowcol_map rcm, rowcol_map rcm2,dna_plate dp
where dpm.id_bbmap = bbm.id_bbmap
and bbm.id_beckmanbox = bb.id_beckmanbox
and dpm.id_map = ap.source_idmap
and dpm.id_map = rcm.id_map
and ap.id_arraypattern = 2
and bb.name = ?
and ap.target_idmap = rcm2.id_map
and rcm.maprow = ?
and rcm.mapcol = ?
and dpm.id_dnaplate = dp.id_dnaplate
and dp.copy_type = 1
and dp.format = 384
";


#get original platename if it is a retransformation.

    my $retrans_stat = "select rr.dnaplate_name||rcm.maprow||rcm.mapcol
from retrans_request rr, rowcol_map rcm, rrplate_bb rb, beckman_box bb
where rr.dp_idmap = rcm.id_map
and rr.id_rrplate = rb.id_rrplate
and rb.id_beckmanbox = bb.id_beckmanbox
and bb.name = ?
and rr.rp_idmap in (select id_map from rowcol_map where maprow = ? and mapcol = ?)";
    
#    my $retrans_stat = "select rr.dnaplate_name||rcm.maprow||rcm.mapcol
#from retrans_request rr, rowcol_map rcm
#where rr.dp_idmap = rcm.id_map
#and rr.id_rrplate = ?
#and rr.rp_idmap in (select id_map from rowcol_map where maprow = ? and mapcol = ?)";
    my $retrans_sth = $dbh->prepare($retrans_stat) || die "ERROR:$DBI::errstr";


#statement to give 384 well plate information for a set of platenames.

    my $stat384_info = "select distinct dp.format||'DP_id :-'||dpm.id_dnaplate, ' / quadrant '||ap.target_quadrant
from dnaplate_map dpm, bb_map bbm, beckman_box bb, array_pattern ap, dna_plate dp
where dpm.id_bbmap = bbm.id_bbmap
and bbm.id_beckmanbox = bb.id_beckmanbox
and dpm.id_map = ap.source_idmap
and ap.id_arraypattern = 2
and bb.name = ?
and dpm.id_dnaplate = dp.id_dnaplate
and dp.copy_type in (1,3)";

    my $sth384 = $dbh->prepare($stat384_info) || die "ERROR:$DBI::errstr";
    
    my %SPEC_ADD;
    my $get_nongtp_add_list = "select id_additive from additive where description not like '%dGTP%'";
    my $sth_nongtp_add_list = $dbh->prepare($get_nongtp_add_list) || die "ERROR:$DBI::errstr";
    $sth_nongtp_add_list->execute() || die "ERROR:$DBI::errstr";
    my $ADD_ID;
    while($ADD_ID = $sth_nongtp_add_list->fetchrow()){
        $SPEC_ADD{$ADD_ID}=1;
    }
    $sth_nongtp_add_list->finish();
    
    foreach $this (@printmap_struct){
        
	#############################
	########################
	##################
	#$outfile = 'Screen';
	##################
	########################
	#############################

	#######################
	# Print the map itself
	#######################
	&outputon($outfile, $printer, $prog);
	&init();
	&pre();
	&printmap($this, $each, @printmap_struct);
	&post();
	&outputoff();

    
	###############################
        # Print the orders for the map 
        ###############################
	&outputon($outfile, $printer, $prog);
	($well_info,$add_info,$suff_info,$wdesc_info,$wprim_info,$plate_info,$orig_info,$wells_on_plate,$CHECK_384,$o_bdt,$is_bdt)=&dumporders($dbh, $retrans_sth, $stat384_96,$chem2suff, $S_description_list, $date, $this, $valid_additives, \%SPEC_ADD, @printmap_struct);
	&outputoff();
        
        ########################################
        # Print the grouped orders for the map 
        ########################################
        if (defined (%$well_info)||(%$add_info)||(%$suff_info)||(%$wdesc_info)||(%$wprim_info)){
            my $format = $this->{"format"};
            &outputon($outfile, $printer, $prog);
            &titles($this, $date, $S_description_list);   
            &grouporders($dbh,$outfile, $printer, $prog,$well_info,$add_info,$suff_info,$wdesc_info,$wprim_info,$plate_info,$orig_info,$stat384_96,$format,$wells_on_plate,$CHECK_384,$o_bdt,$is_bdt);
        }else{
            #print "Nothing to print from group orders\n";
            ##This additonal page for group orders shouldn't be printed.
        }
        
    }



    ############################################################
    # Print-out all the plates needed for this printout-session
    # ...sort and find unique entries in @all_plates
    ############################################################
    &outputon($outfile, $printer, $prog);
    
    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;
    my %SAP;
    
    foreach my $sap (@sorted_all_plates){
        my %h_check;
        my %q_check;
        my $h_count=0;
        $sth384->bind_param(1,$sap);
        $sth384->execute();
        my($loc_384,$quad_384);
        while (($loc_384,$quad_384) = $sth384->fetchrow()){
            $h_count++;
            $h_check{$h_count}=$loc_384;
            $q_check{$loc_384}=$quad_384;
        }
        if ($h_count == '4') {
            my $loc_384 = $h_check{$h_count};
            $SAP{$sap}=$loc_384.' All quadrants';
        } else {
            my $loc_384 = $h_check{$h_count};
            $SAP{$sap}=$loc_384.$q_check{$loc_384};
        }
    }
    $sth384->finish();
    
    my %seen = ();
    my @unique;

    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 available 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){
                    
                    $sth_pcr->bind_param(1,$plate);
                    $sth_pcr->execute || die "ERROR:$DBI::errstr";
                    $name = $sth_pcr->fetchrow();
                    if ($name) {
                        $name = "PCR ID ".$name;
                    }
                }
                
                
            }  
            
        }

        if (defined $plate_obj){
            $get_from=$plate_obj;
        }else{
            $get_from=$name;
        }
        
        if ($get_from) {
            $plate_proj{$plate} = $get_from;
            push (@unique,$get_from) unless $seen{$get_from}++;
        } else {
            $plate_proj{$plate} = 'NONE';
            push (@unique,'NONE') unless $seen{'NONE'}++;
        }
        
    }
    
    my ($new_proj,$old_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 {
                    my $ext_inf = $SAP{$keys};
                    my $fin_inf;
                    if ($ext_inf){
                        $fin_inf = "(".$ext_inf.")";
                    }
                    print OUTPUT "$keys      :from $plate_proj{$keys}\t$fin_inf\n";
                }
                $old_proj = $new_proj;
            }
        }
    }
    
    close(OUTPUT);
    $sth3->finish(); 
    $sth4->finish();
    $sth_pcr->finish();

    &outputoff;
    
}


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

sub outputon {
    my ($outfile, $printer, $prog) = @_;
    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";
    } else {
    	open(OUTPUT,">>$outfile") || die "$prog: Could not open file $outfile for output: $!\n";
    }
}

sub outputoff {
    close(OUTPUT);
}

####################################################
# Prints out the title for each page detailing the
# map-id, type, runtype (if any) and date. It is used 
# to head each page of the printout information 
# except for the page which details which plates  
# are required.
####################################################
sub titles {
    
    my ($this, $date, $S_description_list)=@_;
    
    ########################
    # 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";
    
    ##############################
    print OUTPUT "$title1 \n";
    print OUTPUT "$title2 \n";
    print OUTPUT "\n";
    
}


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

sub dumporders {
    my ($dbh, $retrans_sth, $stat384_96, $chem2suff, $S_description_list, $date, $this, $valid_additives, $spec_add, @printmap_struct) = @_;
    
    #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 %SPEC_ADD = %$spec_add;

    my %plate_hash;
    my %orig_well;
    my %scsp_hash;
    my %desc_hash;
    my %primer_hash;
    my %wells;
    my %check_384;
    my %ONLY_BDT;
    my $IS_BDT;

    # 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";

    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;

    # Set some SQL up
    my $freq_st = "
select  a.ID_FREQUEST, a.ID_FBATCH, a.PLATENAME, a.ROWLETTER, a.COLNUM, 
a.ID_SEQCHEM, a.ID_RUNTYPE, a.ITERATION, a.ID_PRIMER, a.ID_SCSP, a.ID_ADDITIVE, b.PROJECTNAME
from finish_request a, finish_batch b
where a.id_fbatch = b.id_fbatch
and a.id_frequest = ?";
    my $freq_sth = $dbh->prepare($freq_st) || die "ERROR:$DBI::errstr";


    my $ol_st = "
select PRIMERNAME, PRIMERSEQ
from primer 
where ID_PRIMER = ?
";
    my $ol_sth = $dbh->prepare($ol_st) || die "ERROR:$DBI::errstr";
    

    
    foreach $next (@array_array){
	my @array = @$next;

	#################################################################################### 
	# create coords(a1)   plate_row_col.suffix[iteration][primername] [primersequence] #
	####################################################################################

	$freq_sth->bind_param(1, $array[0]);
	$freq_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, $PROJECTNAME) = $freq_sth->fetchrow();

        #Information on 384 well mapping.
        my $array_ref = $dbh->selectall_arrayref($stat384_96,{},$PLATENAME, $ROWLETTER, $COLNUM,$PLATENAME, $ROWLETTER, $COLNUM);


#find out if there is a retransformation entry
        my $plate = $PLATENAME;
        #print ">>PLATE - $plate<<\n";
        $retrans_sth->bind_param(1,$plate);
        $retrans_sth->bind_param(2,$ROWLETTER);
        $retrans_sth->bind_param(3,$COLNUM);
	$retrans_sth->execute();
        my $original_name = $retrans_sth->fetchrow();
        if ($original_name){
            #print ">>ORIGINAL NAME $original_name from $plate$ROWLETTER$COLNUM<<\n";
            $original_name='  ('.$original_name.')  ';
        }

	# Convert $ID_SCSP into a suffix
	my $SUFFIX = $chem2suff->{$ID_SCSP};
	$SUFFIX = "." . "$SUFFIX";

        #Check wether the maps has version 2/3 BDT.
	#If so flag it up.
	if (($SUFFIX=~ /\S+k$/) || ($SUFFIX=~ /\S+c$/)){
            $IS_BDT='yes';
        }
        

	# If we have an ID_PRIMER value then we need PRIMERNAME and PRIMERSEQ from PRIMER
	my ($OLIGO, $SEQ);
	if (defined $ID_PRIMER){
	    $ol_sth->bind_param(1, $ID_PRIMER);
	    $ol_sth->execute || die "ERROR:$DBI::errstr";
	    ($OLIGO, $SEQ) = $ol_sth->fetchrow();
	}

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

	if (defined $ITERATION && defined $ID_PRIMER){
	    $info = sprintf "%-25s %-s", $PLATENAME.$ROWLETTER.$COLNUM.$SUFFIX.$ITERATION.$OLIGO, $SEQ;
	}
	if (!defined $ITERATION && defined $ID_PRIMER){
	    $info = sprintf "%-25s %-s", $PLATENAME.$ROWLETTER.$COLNUM.$SUFFIX.$OLIGO, $SEQ;
	}
	if (defined $ITERATION && !defined $ID_PRIMER){
	    $info =  sprintf "%-25s %-s", $PLATENAME.$ROWLETTER.$COLNUM.$SUFFIX.$ITERATION;
	}
	if (!defined $ITERATION && !defined $ID_PRIMER){
	    $info =  sprintf "%-25s %-s", $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
	########################################################################
	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";
	    }
	}
        
        #add the original name onto the end for retransformations.
        if (defined $original_name){
            $info = $info."$original_name";
        }

	if ($this_plate ne $old_plate){
	    push @all_plates, $this_plate;
	    printf OUTPUT "\n";
	}
	$old_plate = $this_plate;

	# What project is this sample from
	$this_project = $PROJECTNAME;

	# We can put a break in between blocks
	if ($this_project ne $old_project){
	    print OUTPUT "\n";
	    print OUTPUT "-------------o-------------";
	    print OUTPUT "\n";
	}
	
	
	$old_project = $this_project;
	
	my $location_384;
	if (scalar(@$array_ref)>0){
	    foreach my $ar (@$array_ref){
		$location_384 = "[384-".@$ar[1]."-->"."Quad-".@$ar[2]." 96-".@$ar[3]."]";
	    }
	}
#	printf OUTPUT  "%-5s %s %-10s\n", "$array[1]$array[2]", $info, $location_384;
        printf OUTPUT  "%-5s %s\n", "$array[1]$array[2]", $info;

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

#Make a hash of the 384 information;
	$check_384{$well_no} = $array_ref;

        #Make a hash of the wells 
        #that are used on this plate
        unless ($wells{$well_no}){
            $wells{$well_no}="";
        }
        
#get list of platenames.
        unless ($plate_hash{$well_no}){
            $plate_hash{$well_no} = $PLATENAME;
            $orig_well{$well_no}= $ROWLETTER.$COLNUM;
        }
#get idscsp list.
        unless ($scsp_hash{$well_no}){
            $scsp_hash{$well_no} = $ID_SCSP;
        }
        

        my $ADDITIVE;
        if (defined $ID_ADDITIVE){

	    #get list of wells that do not have
            #BDT:dGTP4:1 or dGTP.
            if ($SPEC_ADD{$ID_ADDITIVE}){
                $ONLY_BDT{$well_no}=1;    
            }

            #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 there is additive information for this well
            #add the information in as the value in the hash.
            $wells{$well_no}=$well_no;
        }
        
        if (defined $OLIGO){
            my $UNIQUE_OLIGO;
            $UNIQUE_OLIGO="$PROJECTNAME"."_"."$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};
        }
    }


    $freq_sth->finish();
    $ol_sth->finish();
    $sth_ei1->finish();
    $sth_ei2->finish();

    return(\%well_hash, \%add_hash, \%suff_hash, \%wdesc_hash, \%wprim_hash, \%plate_hash, \%orig_well, \%wells, \%check_384, \%ONLY_BDT,$IS_BDT);
    
    
}


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

sub grouporders {

    my ($dbh,$outfile, $printer, $prog, $well_info,$add_info,$suff_info,$wdesc_info,$wprim_info,$plate_info,$orig_info,$stat384_96,$format,$wells_on_plate,$CHECK_384,$o_bdt,$is_bdt) = @_;

    my %well_hash;
    my %add_hash;
    my %suff_hash;
    my %wdesc_hash;
    my %wprim_hash;
    my %plate_hash;
    my %orig_well;
    my %wells;
    my @allwell;
    my %CHECK;
    my %ONLY_BDT;

    %well_hash=%$well_info;
    %add_hash=%$add_info;
    %suff_hash=%$suff_info;
    %wdesc_hash=%$wdesc_info;
    %wprim_hash=%$wprim_info;
    %plate_hash=%$plate_info;
    %orig_well=%$orig_info;
    %wells=%$wells_on_plate;
    %CHECK = %$CHECK_384;
    %ONLY_BDT = %$o_bdt;
    my $IS_BDT=$is_bdt;

    my %proj; 


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

    if (defined %well_hash){

        foreach my $key (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 "---------- Seq Mix,Additives and associated wells ----------\n"; 
    print OUTPUT "\n";
    
#    if (defined %add_hash){
    my @untreated_wells;
    if (scalar(keys %add_hash)>0){
    
        foreach my $key (sort keys %add_hash){
	    my $label;
            if ($key=~ /dGTP|BDT:dGTP4:1/){
                $label = 'Seq Mix';
            } else {
                $label = 'Additive';  
            }
            print OUTPUT "\n";
            print OUTPUT  "$label $key\n";        
            @allwell=();
            push @allwell, @{$add_hash{$key}};
            
            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";
            }
        }

	if ($IS_BDT=~ /yes/){
	    #only enter the wells that have no values
	    #into the array.
	    my @un_wells;
	    foreach my $key2 (sort keys %wells){
		if ($wells{$key2} eq ""){
		    push @un_wells,$key2;
		} 
	    }
	    
	    foreach (sort {sensibly($a, $b)} @un_wells){
		push @untreated_wells,$_;   
	    }
	    
	    #list wells that require BDT only, where no 4:1 or dGTP
	    #has been used.
	    my @only_bdt = keys %ONLY_BDT;
	    if (scalar(@untreated_wells)>0){
		push @only_bdt,@untreated_wells;
	    }
	    my @sort_only_bdt;
	    foreach (sort {sensibly($a, $b)} @only_bdt){
		push @sort_only_bdt,$_;   
	    }
	    
	    if (scalar(@sort_only_bdt)>0){               
		my $columns;
		use Text::Wrap qw($columns &wrap);
		$columns = 20;
                print OUTPUT "\nSeq Mix BDT\n";
		my $count = scalar(@sort_only_bdt);
		if ($count == $format) {
		    print OUTPUT "Associated wells : ALL WELLS\n";
		} else {
		    print OUTPUT "Associated wells :\n";
		    print OUTPUT wrap(" ", " ",@sort_only_bdt), "\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;
            }

            #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(@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;
            my $count = scalar(@welllft);
            if ($count>0){
                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";
    } 

    &outputoff();
    
    my @r_cs;
    my $table1 = SDTable->new('format' => 'gaudy');
    $table1->set('title'=> "384->96 mapping information", 'titles' => ["Map well","384DPID","well","Quad","","96 well","DPID","BB_Name"]);

    #@lowells needs to be accounted for.
    my @lowells;
    foreach my $key_well (sort {sensibly($a, $b)} keys %CHECK){
	my $array_ref = $CHECK{$key_well};
        if (scalar(@{$array_ref}) == '0'){
	    push @lowells, $key_well;
	} else {
            foreach my $ar (@{$array_ref}){
                if (@$ar[0] eq @$ar[4]){
                    @$ar[4] = "N/A";
                }
                my @cs=("$key_well","@$ar[0]","@$ar[1]","@$ar[2]","-->","@$ar[3]","@$ar[4]","@$ar[5]");
                push (@r_cs, \@cs);
            }
        }
    }
    
    if (scalar(@r_cs)>0)  {
        
        foreach my $rc (@r_cs){
            $table1->add(@$rc);
        }

        &outputon($outfile, $printer, $prog);
        print OUTPUT "\n";
        print OUTPUT "The table below provides 384 conversion information where\n"; 
        print OUTPUT "either four 96 well plates have been condensed into\n";
        print OUTPUT "one 384 well plate, or a direct 384 well plate is used, the\n";
        print OUTPUT "quadrant and the related 96 well information is provided\n";
        print OUTPUT "for easy referral if overlays are used. Where a direct 384\n";
        print OUTPUT "well plate is used, the DPID field (for 96 well plate) will\n";
        print OUTPUT "have a N/A entry.\n\n";
        print OUTPUT $table1->format();
        print OUTPUT "\n";

        my $locount = scalar(@lowells);
        if ((defined $table1) && ($locount>0)) {
            print OUTPUT "\nThe list of well(s) below are those whose DNA is sourced\n";
            print OUTPUT "from a 96 well plate, so a 384 well plate conversion list\n";
            print OUTPUT "entry isn't required.\n\n"; 
            my $columns;
            use Text::Wrap qw($columns &wrap);
            $columns = 20;   
            print OUTPUT "Associated wells :\n";
            print OUTPUT wrap(" ", " ",@lowells), "\n";
        }
        
        &outputoff();
    }



}

##################################################################################
# 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)   SD
#
# 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};
    $format = $this->{"format"};
    $comment = $this->{comment};
    @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) = @_;

    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;
}

1;
