package retrans_printmap;

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

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

sub retransmaps_out {
    my ($dbh, $ret_id, $printer,$prog,$outfile,$ref_BB_RPLATE,$ref_DNA_RPLATE) = @_;

    my @all_retids = @$ret_id;
    my %BB_RPLATE = %$ref_BB_RPLATE;
    my %DNA_RPLATE = %$ref_DNA_RPLATE;
    
#    print ">>printout section : - @all_retids $printer,$prog,$outfile<<\n";
#    print STDOUT "BB_RPLATE CHECK ------------------------------>\n";
#    print STDOUT Data::Dumper::Dumper(\%BB_RPLATE);
#    print STDOUT "----------------------------------------->\n";
#    print STDOUT "DNA_RPLATE CHECK ------------------------------>\n";
#    print STDOUT Data::Dumper::Dumper(\%DNA_RPLATE);
#    print STDOUT "----------------------------------------->\n";

    #sql statement to get format info
    my $stat_format = "select plate_format from rrplate where id_rrplate = ?";
    my $sth_format = $dbh->prepare($stat_format) || die "ERROR:$DBI::errstr";
    
 #sql statement to get info on a retrans plate

#    my $stat_retransplate = "select distinct 'R'||rr.id_rrplate||rcm2.maprow||rcm2.mapcol RETRANAME, rr.id_rbatch, rr.dnaplate_name||rcm1.maprow||rcm2.mapcol DNANAME, dpm.id_dnaplate, p.email, rr.dp_idmap, bbm.id_bbmap, rr.rp_idmap RPMAP,NVL(f.name,'NOT KNOWN') F_NAME, rr.assign_order AO
#from retrans_request rr, 
#retrans_batch rb,
#rowcol_map rcm1,
#rowcol_map rcm2,
#beckman_box bb,
#bb_map bbm, 
#dnaplate_map dpm,
#dp_storage dps, 
#storage s, 
#freezer f,
#team_person_role tpr,
#person p
#where rr.id_rrplate = ?
#and rr.id_rbatch = rb.id_rbatch
#and rr.dp_idmap = rcm1.id_map
#and rr.rp_idmap = rcm2.id_map
#and rr.dnaplate_name = bb.name
#and rr.dp_idmap = bbm.id_map
#and bb.id_beckmanbox = bbm.id_beckmanbox
#and bbm.id_map = dpm.id_map (+)
#and bbm.id_bbmap = dpm.id_bbmap (+)
#and dpm.id_dnaplate = dps.id_dnaplate (+)
#and dps.id_storage = s.id_storage (+)
#and s.id_freezer = f.id_freezer (+)
#and rb.finisher = tpr.id_role
#and tpr.id_person = p.id_person
#order by rr.rp_idmap,rr.assign_order";

    my $stat_retransplate = "select distinct rcm2.maprow||rcm2.mapcol RETRANAME, p.email, rr.id_rbatch, rr.dnaplate_name||rcm1.maprow||rcm1.mapcol DNANAME, rr.rp_idmap RMID, rr.assign_order AO
from retrans_request rr,
retrans_batch rb, 
rowcol_map rcm1,
rowcol_map rcm2,
team_person_role tpr,
person p
where rr.id_rrplate = ?
and rr.id_rbatch = rb.id_rbatch
and rr.dp_idmap = rcm1.id_map
and rr.rp_idmap = rcm2.id_map
and rb.finisher = tpr.id_role
and tpr.id_person = p.id_person
order by rr.rp_idmap,rr.assign_order";
    

    # 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 $arid (@all_retids){
            
            my $bbox = $BB_RPLATE{$arid};
            my $dplate = $DNA_RPLATE{$arid};
            
            unless ($bbox){
                $bbox = 'N/A';
            }
            unless ($dplate){
                $splate = 'N/A';
            }
            
	    $sth_format->bind_param(1,$arid);
	    $sth_format->execute || die "ERROR:$DBI::errstr";
	    my $format = $sth_format->fetchrow();
	    
	    my $rplate_info;
	    $rplate_info = $dbh->selectall_arrayref($stat_retransplate,{},$arid) || die "ERROR:$DBI::errstr";

            #get unique list of batch ids
            my %seen;
            my @unique_list;
#	    print "FORMAT OF PLATE IS - $format\n\n";
	    foreach my $ref (@$rplate_info){
#		print "INFO RETRIEVED - @$ref[2]\n";
                unless($seen{@$ref[2]}){
                    push @unique_list,@$ref[2];
                    $seen{@$ref[2]}=1;
                }
	    }

            #for each plate a batch list needs to be defined and punctuated.
            my $batchlist=join',',sort(@unique_list);
#            print "constructed batch list is $batchlist\n";

            #get a unique list of dnaplates
            #for this map.
            my $dpref = get_ret->get_dnaname($dbh,$arid);
#            print "list of dnanames obtained - @$dpref\n";

#            ###############################
#            # Print the orders for the map 
#            ###############################
            
#           print "I am now printing out the map\n";
            &outputon($outfile, $printer, $prog);
            &init();
            &pre();
	    &printpage($arid,$format,$bbox,$dplate,$date,$batchlist,$rplate_info,$dpref);
            &post();
            &outputoff();

#            
##            ########################################
##            # Print the grouped orders for the map 
##            #######################################
##            if ($format=~ /96|384/){
##                &outputon($outfile, $printer, $prog);
##                &titles($apid, $format, $date);
##                &grouporders($format,$pcr_info,$hash);
##                &outputoff();
##            }
            
        } 

    $sth_format->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);
}

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

    local($map,$format,$bbox,$dplate,$date,$batchlist,$rplate_info,$dpref) = @_;

#    print "BBOX = $bbox DNAPLATE = $dplate\n";

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

#    print OUTPUT "landscape\n";
    print OUTPUT "gs\n";
    print OUTPUT "/Times-Italic findfont\n";
    print OUTPUT "24 scalefont\n";
    print OUTPUT "setfont\n";
    printf OUTPUT  "%d %d (Retransformation Plate ID is R$map) sc\n",290,780;
    print OUTPUT "gr\n";
    
    ############################################################
    # Additional information
    ############################################################
    print OUTPUT "gs\n";
    print OUTPUT "/Helvetica-Bold findfont 16 scalefont setfont\n";
    
    printf OUTPUT  "np 135 760 m 435 760 l 2 setlinewidth s\n";
    printf OUTPUT  "145 730 m (Additional Info:-) show\n";
    printf OUTPUT  "np 135 720 m 435 720 l 2 setlinewidth s\n";
    printf OUTPUT  "145 690 m (BeckmanBOX) show\n";
    printf OUTPUT  "290 690 m ($bbox) show\n";
    printf OUTPUT  "np 135 680 m 435 680 l 1 setlinewidth s\n";
    printf OUTPUT  "145 650 m (DNAPlate) show\n";
    printf OUTPUT  "290 650 m ($dplate) show\n";
    printf OUTPUT  "np 135 640 m 435 640 l 2 setlinewidth s\n";
    printf OUTPUT  "np 135 761 m 135 639.5 l 2 setlinewidth s\n";
    printf OUTPUT  "np 280 760 m 280 640 l 1 setlinewidth s\n";
    printf OUTPUT  "290 730 m (ID) show\n";
    printf OUTPUT  "np 435 761 m 435 639.5 l 2 setlinewidth s\n";
    printf OUTPUT  "/Helvetica-Bold findfont 10 scalefont setfont\n";
    printf OUTPUT  "50 620 m (Retransformation batches - $batchlist) show\n";

    printf OUTPUT  "np 50 600 m 545 600 l 2 setlinewidth s\n";

    printf OUTPUT  "50 580 m (Well#) show\n";
    printf OUTPUT  "100 580 m (Req by) show\n";
    printf OUTPUT  "175 580 m (RBatch#) show\n";
    printf OUTPUT  "250 580 m (Original DNAplatename) show\n";
    printf OUTPUT  "450 580 m (Assign order) show\n";

    &dumporders($format,$date,$map,$rplate_info,$dpref);

}

############################################################
# 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
%%Page: 1 3
/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
#;

#/landscape {
#  800 0 translate
#  90 rotate
#} def

}

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

sub init {
    local($format);
    
    $platex = 75;
    $platey = 750;
    $plateheight = 300;
    $platewidth = 300*12/8;

#    $platex = 75;
#    $platey = 730;
#    $plateheight = 480;
#    $platewidth = 720;
    
}


sub print_id {
    my($id,$format)=@_;
    
    my $vessel;    
    if ($format == 1){
        $vessel = "tube";
    } else {
        $vessel = "well plate";
    }

    print OUTPUT "%%Page: 1 3\n";
    print OUTPUT "/Times-Italic findfont 10 scalefont setfont\n";   
    print OUTPUT  "50 800 moveto (Retrans ID is $id, Plate format is $format $vessel) 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 = "Retrans ID is $id" . "   " . "FORMAT is $format $vessel" . "   " . "PRINTED at $date";
    ##############################
    printf OUTPUT "50 800 moveto ($title1) sh\n\n";
    
}


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

sub dumporders {
    my ($format,$date,$map,$pcr_info,$dpref) = @_;
    
    my $size =  '565';
    my $subin;        
    my %HASH;
    
    print OUTPUT "/Courier-New findfont 10 scalefont setfont\n";
    my $pi_count = 0;
    foreach my $pi (@{$pcr_info}){
        $pi_count++;
#        print "LINE $pi_count - @$pi[0 .. 3]\n";
        
        if ($size < 30) {
            print OUTPUT "showpage\n";
            print OUTPUT "%%Page: 1 3\n";
            &titles($map, $format, $date); 
            
            printf OUTPUT  "/Helvetica-Bold findfont 10 scalefont setfont\n";
            printf OUTPUT  "50 770 m (Well#) show\n";
            printf OUTPUT  "100 770 m (Req by) show\n";
            printf OUTPUT  "175 770 m (RBatch#) show\n";
            printf OUTPUT  "250 770 m (Original DNAplatename) show\n";
            printf OUTPUT  "450 770 m (Assign order) show\n";
            
            print OUTPUT "/Courier-New findfont 10 scalefont setfont\n"; 
            $size =  '755';
        }
        
        $this_project = @$pi[2];
        
        # We can put a break in between blocks
        if ($this_project ne $old_project){
            print OUTPUT "50 $size m ( ) sh\n";
            $subin = '12';
            $size = $size-$subin;
        }
        
        $old_project = $this_project;
        
        printf OUTPUT  "50 $size m (@$pi[0]) sh\n";  
        printf OUTPUT  "100 $size m (@$pi[1]) sh\n";
        printf OUTPUT  "175 $size m (@$pi[2]) sh\n";
        printf OUTPUT  "250 $size m (@$pi[3]) sh\n"; 
        printf OUTPUT  "450 $size m (@$pi[5]) sh\n";     
        
        $subin = '12';
        $size = $size-$subin;
    } 

    #list the dnaplates involved.
    if (scalar(@$dpref)>0){
        print OUTPUT "showpage\n";
        print OUTPUT "%%Page: 1 3\n";
        &titles($map, $format, $date);
        $size =  '755';
        $subin = '12';
        printf OUTPUT  "/Helvetica-Bold findfont 10 scalefont setfont\n";
        printf OUTPUT  "50 $size m (DNA plates involved :-) sh\n";
        $size = $size-$subin;
        printf OUTPUT  "np 50 $size m 245 $size l 2 setlinewidth s\n";
        $size = $size-($subin*2);
        printf OUTPUT "/Courier-New findfont 10 scalefont setfont\n"; 
        foreach my $dname (sort {sensibly($a, $b)} @$dpref){
            printf OUTPUT  "50 $size m ($dname) sh\n";
            $size = $size-$subin;
        }
    }
    
    
}


#############################################################
## &grouporders
## groups the associated wells with their primername and 
## their additive name. 
##############################################################
#
#sub grouporders {
#    
#    my ($format, $pcr_info, $HASH) = @_;
#    
#    my %well_hash;
#    my $well_no;
#    my @allwell;
#    my %proj;
#    my %NHASH; 
#    %NHASH = %$HASH;
#
#    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/){
#        
#        #section to print out the primer, additive and p1c info etc...
#        my $value1=(keys %well_hash);
#        if ($value1 != 0){
#            print OUTPUT "\n";
#            print OUTPUT "---------- Primers and associated wells ----------\n"; 
#            print OUTPUT "\n";
#            
#            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;
#                    
#                    print OUTPUT "Associated wells :\n";
#                    print OUTPUT wrap(" ", " ",@allwell), "\n";
#                }
#            }
#            
#        } else {
#            
#            print OUTPUT "\n";
#            print OUTPUT "---------- Primers and associated wells ----------\n"; 
#            print OUTPUT "\n";
#            print OUTPUT "No Primers were ordered\n";
#            print OUTPUT "\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;
        }
    }
}


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


1;








