package pcr_printmap;

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

use Text::Wrap;
use Data::Dumper;

sub pcrmaps_out {
    my ($dbh, $pcr_id, $printer,$prog,$outfile) = @_;
    
    my @all_pcrids = @$pcr_id;
    my $old_project;
    my $this_project;

    #get type and description in a hash.
    my %LUDESC;
    my $stat_LUDESC = "select id_type,description from pcr_lookuptypedict order by id_type";
    my $sth_LUDESC = $dbh->prepare($stat_LUDESC) || die "ERROR:$DBI::errstr";
    $sth_LUDESC->execute() || die "ERROR:$DBI::errstr";
    my($type,$desc);
    while (($type,$desc)=$sth_LUDESC->fetchrow()){
        $LUDESC{$type}=$desc;
    }
    
    #sql statement to get format info
    my $stat_format = "select a.format, c.email
from pcr_vessel a, team_person_role b, person c
where a.id_pcrvessel = ?
and a.finisher = b.id_role
and b.id_person = c.id_person";
    my $sth_format = $dbh->prepare($stat_format) || die "ERROR:$DBI::errstr";
    
    #sql statement to get info on a pcr vessel
    my $stat_pcrvessel = "select a.pcr_template_name,
NVL(c.primername,''),
NVL(c.primerseq,''),
NVL(d.primername,''),
NVL(d.primerseq,''),
NVL(b.maprow,''),
NVL(b.mapcol,''),
a.is_combinatorial,
a.lookup_type,
a.dna_source
from pcr_product a,
rowcol_map b,
primer c,
primer d
where a.id_map = b.id_map (+)
and a.primer_1 = c.id_primer (+)
and a.primer_2 = d.id_primer (+)
and a.id_pcrvessel = ?
order by b.maprow,b.mapcol";
    
#    #sql statement to get info on a pcr tube
#    my $stat_pcrtube = "select a.pcr_template_name,
#NVL(c.primername,''),
#NVL(c.primerseq,''),
#NVL(d.primername,''),
#NVL(d.primerseq,''),
#a.is_combinatorial,
#a.lookup_type,
#a.dna_source
#from pcr_product a,
#primer c,
#primer d
#where a.primer_1 = c.id_primer (+)
#and a.primer_2 = d.id_primer (+)
#and a.id_pcrvessel = ?";
  
    #check for the projectname  
    my $stat_chkproj1 = "select projectname
from clone_project
where clonename = ?";
    my $sth_chkproj1= $dbh->prepare($stat_chkproj1) || die "ERROR:$DBI::errstr";

    my $stat_chkproj2 = "select projectname
from clone_project
where projectname = ?";
    my $sth_chkproj2= $dbh->prepare($stat_chkproj2) || die "ERROR:$DBI::errstr";

    my $stat_chkproj3 = "select d.projectname
from bb_map a, subclone b, ligation c, clone_project d
where a.id_subclone = b.id_subclone
and b.id_ligation = c.id_ligation
and c.clonename = d.clonename
and a.id_bbmap = ?";
    my $sth_chkproj3= $dbh->prepare($stat_chkproj3) || die "ERROR:$DBI::errstr";

    # 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]));
    
    
    #this section is executed if the full 
    #complement of the map is to be printed out.
    
    foreach my $apid (@all_pcrids){
        
        $sth_format->bind_param(1,$apid);
        $sth_format->execute || die "ERROR:$DBI::errstr";
        my ($format,$finisher) = $sth_format->fetchrow();
        
        my $pcr_info = $dbh->selectall_arrayref($stat_pcrvessel,{},$apid) || die "ERROR:$DBI::errstr";
#        if ($format == 1){
#            $pcr_info = $dbh->selectall_arrayref($stat_pcrtube,{},$apid) || die "ERROR:$DBI::errstr";
#        } else {
#            $pcr_info = $dbh->selectall_arrayref($stat_pcrplate,{},$apid) || die "ERROR:$DBI::errstr";
#        }
        
        ###############################
        # Print the orders for the map 
        ###############################
        &outputon($outfile, $printer, $prog);
        &pre();
        &print_id($apid,$format,$finisher);
        my($size,$hash,$prim_hash) = &dumporders($format,$pcr_info,$sth_chkproj1,$sth_chkproj2,$sth_chkproj3,\%LUDESC);
        
        if ($format==1){
            &post();    
            &outputoff();
        }
        
        ########################################
        # Print the grouped orders for the map 
        #######################################
        if ($format=~ /96|384/){
            &grouporders($apid,$date,$format,$size,$pcr_info,$hash,$prim_hash);
        }
        
    } 
    
    $sth_format->finish();
    $sth_chkproj1->finish(); 
    $sth_chkproj2->finish(); 
    $sth_chkproj3->finish();           
}



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


sub outputon {
    my ($outfile, $printer, $prog) = @_;
    if ($outfile eq 'Screen') {
    	open(OUTPUT,">&STDOUT") or die "$prog: Could not open stdout for output: $!\n";
    } elsif ($outfile eq 'None'){
    	open(OUTPUT,"| lpr -P$printer") or die "$prog: Could not spool to printer $printer: $!\n";
    } else {
    	open(OUTPUT,">$outfile") or die "$prog: Could not open file $outfile for output: $!\n";
    }
}

sub outputoff {
    close(OUTPUT);
}


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

    local($date);

    chop($date =`date`);
    ############################################################
    # Header
    ############################################################
    print OUTPUT qq#%\!PS-Adobe-1.0
%%Creator: pcr_printmap
%%Title: PCR Map
%%CreationDate: $date
%%Pages: 1
%%DocumentFonts: Helvetica-Bold Helvetica
%%EndComments
%%EndProlog
/sh { show } def
/m { moveto } def
/s  { stroke } def
/np { newpath } def
/l { lineto } def
/sc { 100 770 moveto } 
def
#;

}


sub print_id {
    my($id,$format,$finisher)=@_;
    
    my $vessel;    
    if ($format == 1){
        $vessel = "tube";
    } else {
        $vessel = "well plate";
    }
    
    print OUTPUT "%%Page: 1 1\n";
    print OUTPUT "/Times-Italic findfont 22 scalefont setfont\n";   
    print OUTPUT  "sc (PCR VESSEL ID is $id ($format $vessel - $finisher)) sh\n";
    
    
}


####################################################
# Prints out the title for each page detailing the
# pcr-id, format 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 ($id,$format,$date)=@_;
    
    my $vessel;    
    if ($format == 1){
        $vessel = "tube";
    } else {
        $vessel = "well plate";
    }
    
    ########################
    # A title for this map #
    ########################
    my $title1 = "PCRVESSEL_ID is $id" . "   " . "FORMAT is $format $vessel" . "   " . "PRINTED on $date";
    print OUTPUT "50 770 m ($title1) sh\n";
    print OUTPUT "50 758 m ( ) sh\n";
    
}



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


sub dumporders {
    my ($format, $pcr_info, $sth_chkproj1,$sth_chkproj2,$sth_chkproj3,$type_ref) = @_;
    
    my $size =  '725';
    my $subin;        
    my %HASH;
    my %TYPE_HASH;
    %TYPE_HASH=%$type_ref;
    my $sth_chkproj;
    my %UNIV_PRIM;
    
    #print STDOUT "PCR_LOOKUPTYPEDICT INFO2 -----------------------\n";
    #print STDOUT Data::Dumper::Dumper(\%TYPE_HASH);    
    #print STDOUT "------------------------------\n";
    
    print OUTPUT "/Courier-New findfont 10 scalefont setfont\n";
    
    $subin = '12';
    $size = $size-$subin;
    
    if ($format=~ /96|384/){
        printf OUTPUT  "50 $size m (Well#) sh\n";
        printf OUTPUT  "100 $size m (Combi?) sh\n";
        printf OUTPUT  "150 $size m (PCR Template Name) sh\n";
        printf OUTPUT  "300 $size m (Type) sh\n";
        printf OUTPUT  "400 $size m (Source) sh\n";
        
    } else {
        
        printf OUTPUT  "50 $size m (PCR Template Name) sh\n";
        printf OUTPUT  "250 $size m (Combi?) sh\n";
        printf OUTPUT  "300 $size m (Source) sh\n";  
    }
    
    $subin = '24';
    $size = $size-$subin;
    printf OUTPUT  "np 50 $size m 545 $size l 1 setlinewidth s\n";
    $subin = '24';
    $size = $size-$subin;
    
    foreach my $pi (@{$pcr_info}){
        
        if ($size < 10) {
            print OUTPUT "showpage\n";
            print OUTPUT "%%Page: 1 2\n";
            print OUTPUT "/Courier-New findfont 10 scalefont setfont\n"; 
            $size =  '770';
        }
        
#this will not work with subclone pcr's.
#for subclone stuff might be best to use the source
#and resolve this to get the projectname.
        
        my $ent = @{$pi}[9];
#        if ($format=~ /96|384/){
#            $ent = @{$pi}[9];
#        } else {
#            $ent = @{$pi}[7];
#        } 
             
        ##get the type from the correct place.
        my $type_id = @{$pi}[8];
#        if ($format=~ /96|384/){
#            $type_id = @{$pi}[8];
#        } else {
#            $type_id = @{$pi}[6];
#        }
             
        #if genomic use a diff piece of sql.
        if ($type_id=~ /3/){
            $sth_chkproj = $sth_chkproj2;
        } elsif ($type_id=~ /2|4|5/) {
            $sth_chkproj = $sth_chkproj3;
        } else {
            $sth_chkproj = $sth_chkproj1;
        }
        
        $sth_chkproj->bind_param(1,$ent);
        $sth_chkproj->execute || die "ERROR:$DBI::errstr";
        $PROJECTNAME =$sth_chkproj->fetchrow();
        if (!$PROJECTNAME){
            $PROJECTNAME = $ent;
        }
        
        my $temp = @{$pi}[0];
        $HASH{$temp}=$PROJECTNAME;
        # What project is this sample from
        $this_project = $PROJECTNAME;
        
        # We can put a break in between blocks
        if (($this_project ne $old_project) && ($old_project ne '')){
            print OUTPUT "50 $size m (-------------o-------------) sh\n";
            $subin = '12';
            $size = $size-$subin;
        }
        
        $old_project = $this_project;
        
        ##obtain whether it's combinatorial .
        my $combi_id = @{$pi}[7];
#        if ($format=~ /96|384/){
#            $combi_id = @{$pi}[7];
#        } else {
#            $combi_id = @{$pi}[5];
#        }
             
        my $combinatorial;
        if (defined $combi_id){
            $combinatorial = '*';
        } else {
            $combinatorial ='';
        }
        
        #my $type = @{$pi}[8];
        my $type_desc = $TYPE_HASH{$type_id};
             
        if ($type_id=~ /4|5/){
            my $well  = "@{$pi}[5]@{$pi}[6]";
            push ( @{$UNIV_PRIM{$type_desc}},$well);
        }
        
        if ($ent!~ /\D+/){
            $ent = $PROJECTNAME;
        }
        
        #print "PRINTOUT INFORMATION - @{$pi}[0,1-4]\n";
        if ($format=~ /96|384/){
            printf OUTPUT  "50 $size m (@{$pi}[5]@{$pi}[6]) sh\n";
            printf OUTPUT  "100 $size m ($combinatorial) sh\n";
            printf OUTPUT  "150 $size m (@{$pi}[0,1-4]) sh\n";
            printf OUTPUT  "300 $size m ($type_desc) sh\n";
            printf OUTPUT  "400 $size m ($ent) sh\n";
            
        } else {
            
            printf OUTPUT  "50 $size m (@{$pi}[0,1-4]) sh\n";
            printf OUTPUT  "250 $size m ($combinatorial) sh\n";
            printf OUTPUT  "300 $size m ($ent) sh\n";  
        }
        
        $subin = '12';
        $size = $size-$subin;
    } 
    
    #layout group orders further down the page.
    $size = $size-30;
    
    $sth_chkproj->finish();
    $old_project="";
    $this_project="";
    
    return($size,\%HASH,\%UNIV_PRIM);   
}


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

sub grouporders {
    
    my ($apid,$date,$format, $size, $pcr_info, $HASH, $Prim_Hash) = @_;
    
    my %well_hash;
    my $well_no;
    my @allwell;
    my %proj;
    my %NHASH; 
    %NHASH = %$HASH;
    my %P_HASH;
    %P_HASH = %$Prim_Hash;
    
    $subin = '12';
    
    foreach my $pi (@{$pcr_info}){
        
        if ($format=~ /96|384/){
            # to create a well number the row and col info
            # have to be cocatenated together.
            $well_no="@{$pi}[5]"."@{$pi}[6]";
            
            my($UNIQUE_OLIGO);
            if (@{$pi}[1]){
                my $temp =@{$pi}[0]; 
                my $o_proj= $NHASH{$temp};
                $UNIQUE_OLIGO = "$o_proj"."_"."@{$pi}[1]";
                push ( @{$well_hash{$UNIQUE_OLIGO}}, $well_no);
            }
            if (@{$pi}[3]){
                my $temp =@{$pi}[0]; 
                my $o_proj= $NHASH{$temp};
                $UNIQUE_OLIGO = "$o_proj"."_"."@{$pi}[3]";
                push ( @{$well_hash{$UNIQUE_OLIGO}}, $well_no);
            }
        }
    }
    
    if($format=~ /96|384/){
        
        $size = &reset_page($apid,$date,$format), if $size < 10;
        
        #section to print out the primer, 
        #additive and p1c info etc...
        my $value1=(keys %well_hash);
        if ($value1 != 0){
            
            print OUTPUT "50 $size m ( ) sh\n";
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            
            print OUTPUT "50 $size m (---------- Primers and associated wells ----------) sh\n"; 
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            
            print OUTPUT "50 $size m ( ) sh\n";
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            
            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 "50 $size m ( ) sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                    
                    print OUTPUT "50 $size m (-------------o-------------) sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                    
                    print OUTPUT "50 $size m ( ) sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                }            
                $o_project = $t_project;
                
                #print out the project and the primer information.
                print OUTPUT "50 $size m ( ) sh\n";
                $size = $size-$subin;
                $size = &reset_page($apid,$date,$format), if $size < 10;
                
                print OUTPUT "50 $size m (Project : $key2) sh\n";
                $size = $size-$subin;
                $size = &reset_page($apid,$date,$format), if $size < 10;
                
                my @values;
                push @values, @{$proj{$key2}};
                foreach (sort {sensibly($a, $b)} @values){ 
                    print OUTPUT "50 $size m ( ) sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                    print OUTPUT "50 $size m (Primername: $_) sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                    @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;
                    
                    print OUTPUT "50 $size m (Associated wells :) sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                    print OUTPUT "50 $size m (",wrap(" ", " ",@allwell),") sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                }
            }
            
        } else {
            
            $size = &reset_page($apid,$date,$format), if $size < 10;
            
            print OUTPUT "50 $size m ( ) sh\n";
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            print OUTPUT "50 $size m (---------- Primers and associated wells ----------) sh\n"; 
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            print OUTPUT "50 $size m ( ) sh\n";
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            print OUTPUT "50 $size m (No custom primers were ordered) sh\n";
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            print OUTPUT "50 $size m ( ) sh\n";
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
        }
        
##########################################################
        
##NEW SECTION ADDED TO LIST THE UNIVERSAL PRIMER INFORMATION.
        
        $size = &reset_page($apid,$date,$format), if $size < 10;
        
        #section to print out the primer, 
        #additive and p1c info etc...
        my $p_val=(keys %P_HASH);
        if ($p_val != 0){
            
            print OUTPUT "50 $size m ( ) sh\n";
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            
            print OUTPUT "50 $size m (---------- Universal primers and associated wells ----------) sh\n"; 
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            
            print OUTPUT "50 $size m ( ) sh\n";
            $size = $size-$subin;
            $size = &reset_page($apid,$date,$format), if $size < 10;
            
            foreach my $univ_prim (sort keys %P_HASH){
                if ($univ_prim=~ /\S+\_(\S+)/){
                    my $primer_name = $1;
                    
                    print OUTPUT "50 $size m (Primername: $primer_name) sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                    
                    #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;
                    
                    print OUTPUT "50 $size m (Associated wells :) sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                    print OUTPUT "50 $size m (",wrap(" ", " ",@{$P_HASH{$univ_prim}}),") sh\n";
                    $size = $size-$subin;
                    $size = &reset_page($apid,$date,$format), if $size < 10;
                    
                }
            }
        }
        

##########################################################
        
    }
    &post();    
    &outputoff();
}


sub reset_page {
    my($apid,$date,$format)=@_;
    
    print OUTPUT "showpage\n";
    print OUTPUT "%%Page: 1 2\n";
    print OUTPUT "/Courier-New findfont 10 scalefont setfont\n"; 
    $size =  '746';
    
    &titles($apid, $format, $date);
    
    return $size;
}


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


sub post {
    
    print OUTPUT "showpage\n";
    print OUTPUT "grestore\n";
    print OUTPUT "%%EOF\n";
    
}


1;








